53 Commits

Author SHA1 Message Date
danieljsummers 3a19952f39 Move redirect rule to 2 row, remove no-wrap (#55)
- Fix redirect rule handling with endpoint routing (#59)
- Make subtitle non-nullable string (#47)
2026-07-18 12:50:27 -04:00
danieljsummers 816a156d79 Fix default theme page title (#47) 2026-07-17 23:02:00 -04:00
danieljsummers 84025a5eb2 Change log off to POST (#61) 2026-07-17 22:49:38 -04:00
danieljsummers 03dc289991 Use favicon if OG image URL is not specified (#52) 2026-07-17 22:23:39 -04:00
danieljsummers abfae6786d JS tweaks for showing messages (#60) 2026-07-17 21:19:32 -04:00
danieljsummers 76f0506de7 WIP on htmx 4; change target from window to body (#60) 2026-07-14 19:55:55 -04:00
danieljsummers e8ee236c1e WIP on htmx 4; seeing console errors (#60) 2026-07-13 21:30:42 -04:00
danieljsummers 0fcb40fbdd WIP on htmx 4; user messages now work (#60) 2026-07-12 14:08:32 -04:00
danieljsummers d31b508359 WIP on htmx 4 integration (#60) 2026-07-11 21:33:07 -04:00
danieljsummers 32372a3f9f Remove DotLiquid (#47) 2026-07-11 17:58:00 -04:00
danieljsummers b3eab09576 Add Fluid where filter, fix slug (#47)
- Fix issue with path base and logon redirects
2026-07-07 22:57:57 -04:00
danieljsummers 8e0b2df870 Add true/false to auto-htmx converter (#59)
- This will allow backups to be restored, converting the value as part of the restoration
2026-07-07 20:26:34 -04:00
danieljsummers edb376c06c Remove htmx script from view context (#59) 2026-07-06 08:32:38 -04:00
danieljsummers be6251b6ec Add log for auto-htmx migration step (#59) 2026-07-06 08:24:24 -04:00
danieljsummers fcd02ecbec Implement htmax as auto-htmx selection (#59)
- Move program support items to MyWebLog namespace
- Fix parameter ordering in some tests
2026-07-05 21:28:58 -04:00
danieljsummers 9d2277ab32 WIP on adding htmax option (#59) 2026-07-05 17:54:36 -04:00
danieljsummers 7c588662d2 Update SDK; htmx serving now works (#59) 2026-07-04 20:27:39 -04:00
danieljsummers 84444e4789 Edit formatting for handlers 2026-07-03 19:23:45 -04:00
danieljsummers 0de1bff190 More WIP to get htmx served; still no luck (#59) 2026-07-03 16:59:41 -04:00
danieljsummers 38a06b53f4 Convert all but regex routes to endpoints (#59) 2026-07-03 12:53:24 -04:00
danieljsummers be094fb07e WIP on endpoint routing conversion (#59) 2026-07-01 23:43:48 -04:00
danieljsummers cb9ec52a7d WIP on pulling embedded htmx 2026-06-28 20:05:49 -04:00
danieljsummers 2755b250e4 Upgrade to htmx 4 (#58)
- There may be more htmx work to do, but the package is updated
2026-06-20 16:15:49 -04:00
danieljsummers 1b7010bff8 Update all deps but Giraffe.Htmx; migrate sln to slnx (#58) 2026-06-20 15:40:23 -04:00
danieljsummers f9936bf6ae Implement central package management (#58) 2026-06-20 15:27:31 -04:00
danieljsummers 5635e2be32 Add .NET 10 target (#58) 2026-06-20 15:14:13 -04:00
danieljsummers 7374440621 WIP on OpenGraph form; first cut done (#52) 2025-08-03 22:03:07 -04:00
danieljsummers 60a22747ac WIP on OpenGraph form; add media files (#52) 2025-08-03 21:08:34 -04:00
danieljsummers 9b295263f9 WIP on OpenGraph form; items field complete (#52) 2025-08-03 17:01:02 -04:00
danieljsummers bc1d17d916 WIP on OpenGraph edit form (#52) 2025-08-02 20:57:29 -04:00
danieljsummers cba1bbfa28 Support relative URLs in OpenGraph properties (#52) 2025-08-01 22:16:19 -04:00
danieljsummers 8b190a6c23 Add tests for OpenGraph view model properties 2025-07-26 20:33:30 -04:00
danieljsummers e33966b3df WIP on OpenGraph post/page model (#52)
- Removed SecureUrl prop; will generate if URL starts with https:
2025-07-15 23:38:02 -04:00
danieljsummers 3ad6b5a521 Move OpenGraph property generation to models (#52)
- Add auto-OpenGraph field to web log
- Only generate properties for posts/pages without them if this flag is set
- Set flag to yes on v3 database migration
- Add JSON converter for OpenGraph type
- Add tests for models
2025-07-10 23:03:16 -04:00
danieljsummers 210dd41cee Add OG types to page/post, add rendering in page head (#52) 2025-07-09 22:04:37 -04:00
danieljsummers fa4e1d327a WIP on OpenGraph types (#52) 2025-07-06 22:09:36 -04:00
danieljsummers c19f92889e Return client refresh from redir rule if htmx (#54) 2025-07-05 18:32:46 -04:00
danieljsummers 1f7d415868 Add model alias for payload (#47)
- Update post/page canonical URLs for Fluid
2025-07-05 16:48:15 -04:00
danieljsummers ba5e27e011 Simplify catch-all route; bump admin theme version 2025-07-05 13:40:06 -04:00
danieljsummers 161a61823f Remove CSRF from admin/upload delete endpoints 2025-07-05 12:07:58 -04:00
danieljsummers d1840f63e5 Remove CSRF from page, post, category delete routes (#56)
- Chapter delete swap target needs work
2025-07-04 22:24:32 -04:00
danieljsummers 87fbb1a8c7 Vendor htmx 2.0.6 (#57) 2025-07-04 18:18:13 -04:00
danieljsummers e8953d6072 Update deps; fix SQLite web log delete query 2025-07-04 11:06:34 -04:00
danieljsummers dc30716b83 Update deps; WIP on comments 2025-01-23 22:11:12 -05:00
danieljsummers 88841fd3f8 Update to .NET 8/9; minor tweaks 2024-12-23 21:16:34 -05:00
danieljsummers 870f87cb17 Update for v4-rc5 of doc library 2024-09-18 19:54:45 -04:00
danieljsummers 0032d15c0a Update for doc lib v4-rc4 2024-09-17 08:05:30 -04:00
danieljsummers 95be82cc84 WIP on Fluid model/filters 2024-08-26 21:42:47 -04:00
danieljsummers d047035173 WIP: conversion to Fluid (#47) 2024-08-24 20:47:23 -04:00
danieljsummers cc3e41ddc5 Incorporate doc lib v4 ordering 2024-08-22 23:00:25 -04:00
danieljsummers d4c0e4e26c Tweak PostgreSQL calls 2024-08-19 22:45:14 -04:00
danieljsummers fbc4e891bd Integrate v4 document library for SQLite
- Eliminate warnings for PostgreSQL
2024-08-19 22:23:22 -04:00
danieljsummers cd450a05e5 Update to new doc library
Still need to remove deprecated calls
2024-08-19 20:30:33 -04:00
69 changed files with 6050 additions and 4108 deletions
+1 -1
View File
@@ -33,7 +33,7 @@ let zipTheme (name : string) (_ : TargetParameter) =
|> Zip.zipSpec $"{releasePath}/{name}-theme.zip" |> Zip.zipSpec $"{releasePath}/{name}-theme.zip"
/// Frameworks supported by this build /// 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) = let publishFor rid (_ : TargetParameter) =
+6 -4
View File
@@ -1,9 +1,11 @@
<Project> <Project>
<PropertyGroup> <PropertyGroup>
<TargetFrameworks>net6.0;net8.0</TargetFrameworks> <TargetFrameworks>net8.0;net9.0;net10.0</TargetFrameworks>
<DebugType>embedded</DebugType> <DebugType>embedded</DebugType>
<AssemblyVersion>2.2.0.0</AssemblyVersion> <GenerateDocumentationFile>true</GenerateDocumentationFile>
<FileVersion>2.2.0.0</FileVersion> <AssemblyVersion>3.0.0.0</AssemblyVersion>
<Version>2.2.0</Version> <FileVersion>3.0.0.0</FileVersion>
<Version>3.0.0</Version>
<VersionSuffix>beta1</VersionSuffix>
</PropertyGroup> </PropertyGroup>
</Project> </Project>
+32
View File
@@ -0,0 +1,32 @@
<Project>
<PropertyGroup>
<ManagePackageVersionsCentrally>true</ManagePackageVersionsCentrally>
</PropertyGroup>
<ItemGroup>
<PackageVersion Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.1.0" />
<PackageVersion Include="BitBadger.Documents.Postgres" Version="4.2.0" />
<PackageVersion Include="BitBadger.Documents.Sqlite" Version="4.2.0" />
<PackageVersion Include="Expecto" Version="11.1.0" />
<PackageVersion Include="Fluid.Core" Version="2.31.0" />
<PackageVersion Include="FSharp.Core" Version="10.1.301" />
<PackageVersion Include="Giraffe" Version="8.2.0" />
<PackageVersion Include="Giraffe.Htmx" Version="4.0.0-beta5" />
<PackageVersion Include="Giraffe.ViewEngine.Htmx" Version="4.0.0-beta5" />
<PackageVersion Include="Markdig" Version="1.3.2" />
<PackageVersion Include="Markdown.ColorCode" Version="3.0.1" />
<PackageVersion Include="Microsoft.Data.Sqlite" Version="10.0.9" />
<PackageVersion Include="Microsoft.Extensions.Caching.Abstractions" Version="10.0.9" />
<PackageVersion Include="Microsoft.Extensions.Configuration.Abstractions" Version="10.0.9" />
<PackageVersion Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
<PackageVersion Include="NeoSmart.Caching.Sqlite.AspNetCore" Version="9.0.1" />
<PackageVersion Include="Newtonsoft.Json" Version="13.0.4" />
<PackageVersion Include="NodaTime" Version="3.3.2" />
<PackageVersion Include="NodaTime.Serialization.JsonNet" Version="3.3.0" />
<PackageVersion Include="Npgsql.NodaTime" Version="10.0.3" />
<PackageVersion Include="RethinkDB.DistributedCache" Version="1.0.0-rc1" />
<PackageVersion Include="RethinkDb.Driver" Version="2.3.150" />
<PackageVersion Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-07" />
<PackageVersion Include="System.ServiceModel.Syndication" Version="10.0.9" />
<PackageVersion Include="ThrowawayDb.Postgres" Version="1.4.0" />
</ItemGroup>
</Project>
+47 -7
View File
@@ -1,14 +1,26 @@
/// Converters for discriminated union types /// <summary>Converters for discriminated union types</summary>
module MyWebLog.Converters module MyWebLog.Converters
open MyWebLog open MyWebLog
open System open System
/// JSON.NET converters for discriminated union types /// <summary>JSON.NET converters for discriminated union types</summary>
module Json = module Json =
open Newtonsoft.Json open Newtonsoft.Json
/// <summary>Converter for the <see cref="AutoHtmxType" /> type</summary>
type AutoHtmxTypeConverter() =
inherit JsonConverter<AutoHtmxType>()
override _.WriteJson(writer: JsonWriter, value: AutoHtmxType, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: AutoHtmxType, _: bool, _: JsonSerializer) =
// Backups prior to v3 will still have true/false for this field
match reader.TokenType with
| JsonToken.Boolean -> if reader.Value :?> bool then AutoHtmx else NoAutoHtmx
| _ -> (string >> AutoHtmxType.Parse) reader.Value
/// <summary>Converter for the <see cref="CategoryId" /> type</summary>
type CategoryIdConverter() = type CategoryIdConverter() =
inherit JsonConverter<CategoryId>() inherit JsonConverter<CategoryId>()
override _.WriteJson(writer: JsonWriter, value: CategoryId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: CategoryId, _: JsonSerializer) =
@@ -16,6 +28,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CategoryId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: CategoryId, _: bool, _: JsonSerializer) =
(string >> CategoryId) reader.Value (string >> CategoryId) reader.Value
/// <summary>Converter for the <see cref="CommentId" /> type</summary>
type CommentIdConverter() = type CommentIdConverter() =
inherit JsonConverter<CommentId>() inherit JsonConverter<CommentId>()
override _.WriteJson(writer: JsonWriter, value: CommentId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: CommentId, _: JsonSerializer) =
@@ -23,6 +36,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CommentId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: CommentId, _: bool, _: JsonSerializer) =
(string >> CommentId) reader.Value (string >> CommentId) reader.Value
/// <summary>Converter for the <see cref="CommentStatus" /> type</summary>
type CommentStatusConverter() = type CommentStatusConverter() =
inherit JsonConverter<CommentStatus>() inherit JsonConverter<CommentStatus>()
override _.WriteJson(writer: JsonWriter, value: CommentStatus, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: CommentStatus, _: JsonSerializer) =
@@ -30,6 +44,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CommentStatus, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: CommentStatus, _: bool, _: JsonSerializer) =
(string >> CommentStatus.Parse) reader.Value (string >> CommentStatus.Parse) reader.Value
/// <summary>Converter for the <see cref="CustomFeedId" /> type</summary>
type CustomFeedIdConverter() = type CustomFeedIdConverter() =
inherit JsonConverter<CustomFeedId>() inherit JsonConverter<CustomFeedId>()
override _.WriteJson(writer: JsonWriter, value: CustomFeedId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: CustomFeedId, _: JsonSerializer) =
@@ -37,6 +52,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedId, _: bool, _: JsonSerializer) =
(string >> CustomFeedId) reader.Value (string >> CustomFeedId) reader.Value
/// <summary>Converter for the <see cref="CustomFeedSource" /> type</summary>
type CustomFeedSourceConverter() = type CustomFeedSourceConverter() =
inherit JsonConverter<CustomFeedSource>() inherit JsonConverter<CustomFeedSource>()
override _.WriteJson(writer: JsonWriter, value: CustomFeedSource, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: CustomFeedSource, _: JsonSerializer) =
@@ -44,6 +60,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedSource, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedSource, _: bool, _: JsonSerializer) =
(string >> CustomFeedSource.Parse) reader.Value (string >> CustomFeedSource.Parse) reader.Value
/// <summary>Converter for the <see cref="ExplicitRating" /> type</summary>
type ExplicitRatingConverter() = type ExplicitRatingConverter() =
inherit JsonConverter<ExplicitRating>() inherit JsonConverter<ExplicitRating>()
override _.WriteJson(writer: JsonWriter, value: ExplicitRating, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: ExplicitRating, _: JsonSerializer) =
@@ -51,6 +68,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: ExplicitRating, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: ExplicitRating, _: bool, _: JsonSerializer) =
(string >> ExplicitRating.Parse) reader.Value (string >> ExplicitRating.Parse) reader.Value
/// <summary>Converter for the <see cref="MarkupText" /> type</summary>
type MarkupTextConverter() = type MarkupTextConverter() =
inherit JsonConverter<MarkupText>() inherit JsonConverter<MarkupText>()
override _.WriteJson(writer: JsonWriter, value: MarkupText, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: MarkupText, _: JsonSerializer) =
@@ -58,6 +76,15 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: MarkupText, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: MarkupText, _: bool, _: JsonSerializer) =
(string >> MarkupText.Parse) reader.Value (string >> MarkupText.Parse) reader.Value
/// <summary>Converter for the <see cref="OpenGraphType" /> type</summary>
type OpenGraphTypeConverter() =
inherit JsonConverter<OpenGraphType>()
override _.WriteJson(writer: JsonWriter, value: OpenGraphType, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: OpenGraphType, _: bool, _: JsonSerializer) =
(string >> OpenGraphType.Parse) reader.Value
/// <summary>Converter for the <see cref="Permalink" /> type</summary>
type PermalinkConverter() = type PermalinkConverter() =
inherit JsonConverter<Permalink>() inherit JsonConverter<Permalink>()
override _.WriteJson(writer: JsonWriter, value: Permalink, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: Permalink, _: JsonSerializer) =
@@ -65,6 +92,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: Permalink, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: Permalink, _: bool, _: JsonSerializer) =
(string >> Permalink) reader.Value (string >> Permalink) reader.Value
/// <summary>Converter for the <see cref="PageId" /> type</summary>
type PageIdConverter() = type PageIdConverter() =
inherit JsonConverter<PageId>() inherit JsonConverter<PageId>()
override _.WriteJson(writer: JsonWriter, value: PageId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: PageId, _: JsonSerializer) =
@@ -72,6 +100,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: PageId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: PageId, _: bool, _: JsonSerializer) =
(string >> PageId) reader.Value (string >> PageId) reader.Value
/// <summary>Converter for the <see cref="PodcastMedium" /> type</summary>
type PodcastMediumConverter() = type PodcastMediumConverter() =
inherit JsonConverter<PodcastMedium>() inherit JsonConverter<PodcastMedium>()
override _.WriteJson(writer: JsonWriter, value: PodcastMedium, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: PodcastMedium, _: JsonSerializer) =
@@ -79,6 +108,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: PodcastMedium, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: PodcastMedium, _: bool, _: JsonSerializer) =
(string >> PodcastMedium.Parse) reader.Value (string >> PodcastMedium.Parse) reader.Value
/// <summary>Converter for the <see cref="PostId" /> type</summary>
type PostIdConverter() = type PostIdConverter() =
inherit JsonConverter<PostId>() inherit JsonConverter<PostId>()
override _.WriteJson(writer: JsonWriter, value: PostId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: PostId, _: JsonSerializer) =
@@ -86,6 +116,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: PostId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: PostId, _: bool, _: JsonSerializer) =
(string >> PostId) reader.Value (string >> PostId) reader.Value
/// <summary>Converter for the <see cref="TagMapId" /> type</summary>
type TagMapIdConverter() = type TagMapIdConverter() =
inherit JsonConverter<TagMapId>() inherit JsonConverter<TagMapId>()
override _.WriteJson(writer: JsonWriter, value: TagMapId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: TagMapId, _: JsonSerializer) =
@@ -93,6 +124,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: TagMapId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: TagMapId, _: bool, _: JsonSerializer) =
(string >> TagMapId) reader.Value (string >> TagMapId) reader.Value
/// <summary>Converter for the <see cref="ThemeAssetId" /> type</summary>
type ThemeAssetIdConverter() = type ThemeAssetIdConverter() =
inherit JsonConverter<ThemeAssetId>() inherit JsonConverter<ThemeAssetId>()
override _.WriteJson(writer: JsonWriter, value: ThemeAssetId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: ThemeAssetId, _: JsonSerializer) =
@@ -100,6 +132,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: ThemeAssetId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: ThemeAssetId, _: bool, _: JsonSerializer) =
(string >> ThemeAssetId.Parse) reader.Value (string >> ThemeAssetId.Parse) reader.Value
/// <summary>Converter for the <see cref="ThemeId" /> type</summary>
type ThemeIdConverter() = type ThemeIdConverter() =
inherit JsonConverter<ThemeId>() inherit JsonConverter<ThemeId>()
override _.WriteJson(writer: JsonWriter, value: ThemeId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: ThemeId, _: JsonSerializer) =
@@ -107,6 +140,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: ThemeId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: ThemeId, _: bool, _: JsonSerializer) =
(string >> ThemeId) reader.Value (string >> ThemeId) reader.Value
/// <summary>Converter for the <see cref="UploadId" /> type</summary>
type UploadIdConverter() = type UploadIdConverter() =
inherit JsonConverter<UploadId>() inherit JsonConverter<UploadId>()
override _.WriteJson(writer: JsonWriter, value: UploadId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: UploadId, _: JsonSerializer) =
@@ -114,6 +148,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: UploadId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: UploadId, _: bool, _: JsonSerializer) =
(string >> UploadId) reader.Value (string >> UploadId) reader.Value
/// <summary>Converter for the <see cref="WebLogId" /> type</summary>
type WebLogIdConverter() = type WebLogIdConverter() =
inherit JsonConverter<WebLogId>() inherit JsonConverter<WebLogId>()
override _.WriteJson(writer: JsonWriter, value: WebLogId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: WebLogId, _: JsonSerializer) =
@@ -121,6 +156,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: WebLogId, _: bool, _: JsonSerializer) = override _.ReadJson(reader: JsonReader, _: Type, _: WebLogId, _: bool, _: JsonSerializer) =
(string >> WebLogId) reader.Value (string >> WebLogId) reader.Value
/// <summary>Converter for the <see cref="WebLogUserId" /> type</summary>
type WebLogUserIdConverter() = type WebLogUserIdConverter() =
inherit JsonConverter<WebLogUserId> () inherit JsonConverter<WebLogUserId> ()
override _.WriteJson(writer: JsonWriter, value: WebLogUserId, _: JsonSerializer) = override _.WriteJson(writer: JsonWriter, value: WebLogUserId, _: JsonSerializer) =
@@ -132,16 +168,18 @@ module Json =
open NodaTime open NodaTime
open NodaTime.Serialization.JsonNet open NodaTime.Serialization.JsonNet
/// Configure a serializer to use these converters /// <summary>Configure a serializer to use these converters (and other settings)</summary>
let configure (ser : JsonSerializer) = let configure (ser: JsonSerializer) =
// Our converters // Our converters
[ CategoryIdConverter() :> JsonConverter [ AutoHtmxTypeConverter() :> JsonConverter
CategoryIdConverter()
CommentIdConverter() CommentIdConverter()
CommentStatusConverter() CommentStatusConverter()
CustomFeedIdConverter() CustomFeedIdConverter()
CustomFeedSourceConverter() CustomFeedSourceConverter()
ExplicitRatingConverter() ExplicitRatingConverter()
MarkupTextConverter() MarkupTextConverter()
OpenGraphTypeConverter()
PermalinkConverter() PermalinkConverter()
PageIdConverter() PageIdConverter()
PodcastMediumConverter() PodcastMediumConverter()
@@ -164,8 +202,10 @@ module Json =
/// Serializer settings extracted from a JsonSerializer (a property sure would be nice...) /// Serializer settings extracted from a JsonSerializer (a property sure would be nice...)
let mutable private serializerSettings : JsonSerializerSettings option = None let mutable private serializerSettings : JsonSerializerSettings option = None
/// Extract settings from the serializer to be used in JsonConvert calls /// <summary>Extract settings from the serializer to be used in <c>JsonConvert</c> calls</summary>
let settings (ser : JsonSerializer) = /// <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 if Option.isNone serializerSettings then
serializerSettings <- JsonSerializerSettings ( serializerSettings <- JsonSerializerSettings (
ConstructorHandling = ser.ConstructorHandling, ConstructorHandling = ser.ConstructorHandling,
+11 -11
View File
@@ -5,17 +5,17 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="BitBadger.Documents.Postgres" Version="3.1.0" /> <PackageReference Include="BitBadger.Documents.Postgres" />
<PackageReference Include="BitBadger.Documents.Sqlite" Version="3.1.0" /> <PackageReference Include="BitBadger.Documents.Sqlite" />
<PackageReference Include="Microsoft.Data.Sqlite" Version="8.0.6" /> <PackageReference Include="FSharp.Core" />
<PackageReference Include="Microsoft.Extensions.Caching.Abstractions" Version="8.0.0" /> <PackageReference Include="Microsoft.Data.Sqlite" />
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="8.0.0" /> <PackageReference Include="Microsoft.Extensions.Caching.Abstractions" />
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" /> <PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" />
<PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.1.0" /> <PackageReference Include="Microsoft.FSharpLu.Json" />
<PackageReference Include="Npgsql.NodaTime" Version="8.0.3" /> <PackageReference Include="NodaTime.Serialization.JsonNet" />
<PackageReference Include="RethinkDb.Driver" Version="2.3.150" /> <PackageReference Include="Npgsql.NodaTime" />
<PackageReference Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-07" /> <PackageReference Include="RethinkDb.Driver" />
<PackageReference Update="FSharp.Core" Version="8.0.300" /> <PackageReference Include="RethinkDb.Driver.FSharp" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
@@ -19,38 +19,41 @@ type PostgresCategoryData(log: ILogger) =
let countTopLevel webLogId = let countTopLevel webLogId =
log.LogTrace "Category.countTopLevel" log.LogTrace "Category.countTopLevel"
Custom.scalar Custom.scalar
$"""{Query.Count.byContains Table.Category} $"""{Query.byContains (Query.count Table.Category)}
AND {Query.whereByField (Field.NEX (nameof Category.Empty.ParentId)) ""}""" AND {Query.whereByFields Any [ Field.NotExists (nameof Category.Empty.ParentId) ]}"""
[ webLogContains webLogId ] [ webLogContains webLogId ]
toCount 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 /// Retrieve all categories for the given web log in a DotLiquid-friendly format
let findAllForView webLogId = backgroundTask { let findAllForView webLogId = backgroundTask {
log.LogTrace "Category.findAllForView" log.LogTrace "Category.findAllForView"
let! cats = let! cats = findByWebLog webLogId
Custom.list let ordered = Utils.orderByHierarchy (cats |> List.sortBy _.Name.ToLowerInvariant()) None None []
$"{selectWithCriteria Table.Category} ORDER BY LOWER(data ->> '{nameof Category.Empty.Name}')" let counts =
[ webLogContains webLogId ]
fromData<Category>
let ordered = Utils.orderByHierarchy cats None None []
let counts =
ordered ordered
|> Seq.map (fun it -> |> Seq.map (fun it ->
// Parent category post counts include posts in subcategories // Parent category post counts include posts in subcategories
let catIdSql, catIdParams = let catIdField =
ordered ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name) |> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map _.Id |> Seq.map _.Id
|> Seq.append (Seq.singleton it.Id) |> Seq.append (Seq.singleton it.Id)
|> List.ofSeq |> Field.InArray (nameof Post.Empty.CategoryIds) Table.Post
|> arrayContains (nameof Post.Empty.CategoryIds) id 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 = let postCount =
Custom.scalar Custom.scalar
$"""SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') AS it query
FROM {Table.Post} (addFieldParams
WHERE {Query.whereDataContains "@criteria"} [ catIdField ] [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ])
AND {catIdSql}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catIdParams ]
toCount toCount
|> Async.AwaitTask |> Async.AwaitTask
|> Async.RunSynchronously |> Async.RunSynchronously
@@ -71,11 +74,6 @@ type PostgresCategoryData(log: ILogger) =
log.LogTrace "Category.findById" log.LogTrace "Category.findById"
Document.findByIdAndWebLog<CategoryId, Category> Table.Category catId webLogId 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 /// Delete a category
let delete catId webLogId = backgroundTask { let delete catId webLogId = backgroundTask {
log.LogTrace "Category.delete" log.LogTrace "Category.delete"
@@ -87,14 +85,14 @@ type PostgresCategoryData(log: ILogger) =
if hasChildren then if hasChildren then
let childQuery, childParams = let childQuery, childParams =
if cat.ParentId.IsSome then if cat.ParentId.IsSome then
Query.Patch.byId Table.Category, Query.byId (Query.patch Table.Category) "",
children children
|> List.map (fun child -> [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ]) |> List.map (fun child -> [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ])
else else
Query.RemoveFields.byId Table.Category, Query.byId (Query.removeFields Table.Category) "",
children children
|> List.map (fun child -> |> List.map (fun child ->
[ idParam child.Id; fieldNameParam [ nameof Category.Empty.ParentId ] ]) [ idParam child.Id; fieldNameParams [ nameof Category.Empty.ParentId ] ])
let! _ = let! _ =
Configuration.dataSource () Configuration.dataSource ()
|> Sql.fromDataSource |> Sql.fromDataSource
@@ -103,7 +101,7 @@ type PostgresCategoryData(log: ILogger) =
// Delete the category off all posts where it is assigned // Delete the category off all posts where it is assigned
let! posts = let! posts =
Custom.list 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 |] ] [ jsonParam "@id" [| string catId |] ]
fromData<Post> fromData<Post>
if not (List.isEmpty posts) then if not (List.isEmpty posts) then
@@ -111,7 +109,7 @@ type PostgresCategoryData(log: ILogger) =
Configuration.dataSource () Configuration.dataSource ()
|> Sql.fromDataSource |> Sql.fromDataSource
|> Sql.executeTransactionAsync |> Sql.executeTransactionAsync
[ Query.Patch.byId Table.Post, [ Query.byId (Query.patch Table.Post) "",
posts posts
|> List.map (fun post -> |> List.map (fun post ->
[ idParam post.Id [ idParam post.Id
+3 -28
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 /// A SQL string to select data from a table with the given JSON document contains criteria
let selectWithCriteria tableName = let selectWithCriteria tableName =
$"""{Query.selectFromTable tableName} WHERE {Query.whereDataContains "@criteria"}""" Query.byContains (Query.find tableName)
/// 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))
/// Get the first result of the given query /// Get the first result of the given query
let tryHead<'T> (query: Task<'T list>) = backgroundTask { let tryHead<'T> (query: Task<'T list>) = backgroundTask {
@@ -162,14 +141,10 @@ module Document =
/// Find a document by its ID for the given web log /// Find a document by its ID for the given web log
let findByIdAndWebLog<'TKey, 'TDoc> table (key: 'TKey) webLogId = let findByIdAndWebLog<'TKey, 'TDoc> table (key: 'TKey) webLogId =
Custom.single 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 ] [ "@id", Sql.string (string key); webLogContains webLogId ]
fromData<'TDoc> 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 /// Functions to support revisions
module Revisions = module Revisions =
@@ -186,7 +161,7 @@ module Revisions =
Custom.list Custom.list
$"""SELECT pr.* $"""SELECT pr.*
FROM %s{revTable} 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"} WHERE p.{Query.whereDataContains "@criteria"}
ORDER BY as_of DESC""" ORDER BY as_of DESC"""
[ webLogContains webLogId ] [ webLogContains webLogId ]
+17 -19
View File
@@ -33,6 +33,10 @@ type PostgresPageData(log: ILogger) =
log.LogTrace "Page.pageExists" log.LogTrace "Page.pageExists"
Document.existsByWebLog Table.Page pageId webLogId 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 // IMPLEMENTATION FUNCTIONS
/// Add a page /// Add a page
@@ -47,7 +51,7 @@ type PostgresPageData(log: ILogger) =
let all webLogId = let all webLogId =
log.LogTrace "Page.all" log.LogTrace "Page.all"
Custom.list Custom.list
$"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" sortedPages
[ webLogContains webLogId ] [ webLogContains webLogId ]
(fun row -> { fromData<Page> row with Text = ""; Metadata = []; PriorPermalinks = [] }) (fun row -> { fromData<Page> row with Text = ""; Metadata = []; PriorPermalinks = [] })
@@ -86,8 +90,8 @@ type PostgresPageData(log: ILogger) =
match! pageExists pageId webLogId with match! pageExists pageId webLogId with
| true -> | true ->
do! Custom.nonQuery do! Custom.nonQuery
$"""DELETE FROM {Table.PageRevision} WHERE page_id = @id; $"""{Query.delete Table.PageRevision} WHERE page_id = @id;
DELETE FROM {Table.Page} WHERE {Query.whereById "@id"}""" {Query.delete Table.Page} WHERE {Query.whereById "@id"}"""
[ idParam pageId ] [ idParam pageId ]
return true return true
| false -> return false | false -> return false
@@ -107,21 +111,19 @@ type PostgresPageData(log: ILogger) =
log.LogTrace "Page.findCurrentPermalink" log.LogTrace "Page.findCurrentPermalink"
if List.isEmpty permalinks then return None if List.isEmpty permalinks then return None
else else
let linkSql, linkParam = arrayContains (nameof Page.Empty.PriorPermalinks) string permalinks let linkField = Field.InArray (nameof Page.Empty.PriorPermalinks) Table.Page (List.map string permalinks)
return! let query =
Custom.single (Query.statementWhere
$"""SELECT data ->> '{nameof Page.Empty.Permalink}' AS permalink (Query.find Table.Page)
FROM page $"""{Query.whereDataContains "@criteria"} AND {Query.whereByFields All [ linkField ]}""")
WHERE {Query.whereDataContains "@criteria"} .Replace("SELECT data", $"SELECT data->>'{nameof Page.Empty.Permalink}' AS permalink")
AND {linkSql}""" return! Custom.single query (addFieldParams [ linkField ] [ webLogContains webLogId ]) Map.toPermalink
[ webLogContains webLogId; linkParam ]
Map.toPermalink
} }
/// Get all complete pages for the given web log /// Get all complete pages for the given web log
let findFullByWebLog webLogId = backgroundTask { let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Page.findFullByWebLog" 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 let! revisions = Revisions.findByWebLog Table.PageRevision Table.Page PageId webLogId
return return
pages pages
@@ -133,17 +135,13 @@ type PostgresPageData(log: ILogger) =
let findListed webLogId = let findListed webLogId =
log.LogTrace "Page.findListed" log.LogTrace "Page.findListed"
Custom.list Custom.list
$"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" sortedPages [ jsonParam "@criteria" {| webLogDoc webLogId with IsInPageList = true |} ] pageWithoutText
[ jsonParam "@criteria" {| webLogDoc webLogId with IsInPageList = true |} ]
pageWithoutText
/// Get a page of pages for the given web log (without revisions) /// Get a page of pages for the given web log (without revisions)
let findPageOfPages webLogId pageNbr = let findPageOfPages webLogId pageNbr =
log.LogTrace "Page.findPageOfPages" log.LogTrace "Page.findPageOfPages"
Custom.list Custom.list
$"{selectWithCriteria Table.Page} $"{sortedPages} LIMIT @pageSize OFFSET @toSkip"
ORDER BY LOWER(data->>'{nameof Page.Empty.Title}')
LIMIT @pageSize OFFSET @toSkip"
[ webLogContains webLogId; "@pageSize", Sql.int 26; "@toSkip", Sql.int ((pageNbr - 1) * 25) ] [ webLogContains webLogId; "@pageSize", Sql.int 26; "@toSkip", Sql.int ((pageNbr - 1) * 25) ]
(fun row -> { fromData<Page> row with Metadata = []; PriorPermalinks = [] }) (fun row -> { fromData<Page> row with Metadata = []; PriorPermalinks = [] })
+35 -34
View File
@@ -84,9 +84,9 @@ type PostgresPostData(log: ILogger) =
match! postExists postId webLogId with match! postExists postId webLogId with
| true -> | true ->
do! Custom.nonQuery do! Custom.nonQuery
$"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"}; $"""{Query.delete Table.PostComment} WHERE {Query.whereDataContains "@criteria"};
DELETE FROM {Table.PostRevision} WHERE post_id = @id; {Query.delete Table.PostRevision} WHERE post_id = @id;
DELETE FROM {Table.Post} WHERE {Query.whereById "@id"}""" {Query.delete Table.Post} WHERE {Query.whereById "@id"}"""
[ idParam postId; jsonParam "@criteria" {| PostId = postId |} ] [ idParam postId; jsonParam "@criteria" {| PostId = postId |} ]
return true return true
| false -> return false | false -> return false
@@ -97,21 +97,19 @@ type PostgresPostData(log: ILogger) =
log.LogTrace "Post.findCurrentPermalink" log.LogTrace "Post.findCurrentPermalink"
if List.isEmpty permalinks then return None if List.isEmpty permalinks then return None
else else
let linkSql, linkParam = arrayContains (nameof Post.Empty.PriorPermalinks) string permalinks let linkField = Field.InArray (nameof Post.Empty.PriorPermalinks) Table.Post (List.map string permalinks)
return! let query =
Custom.single (Query.statementWhere
$"""SELECT data ->> '{nameof Post.Empty.Permalink}' AS permalink (Query.find Table.Post)
FROM {Table.Post} $"""{Query.whereDataContains "@criteria"} AND {Query.whereByFields All [ linkField ]}""")
WHERE {Query.whereDataContains "@criteria"} .Replace("SELECT data", $"SELECT data->>'{nameof Post.Empty.Permalink}' AS permalink")
AND {linkSql}""" return! Custom.single query (addFieldParams [ linkField ] [ webLogContains webLogId ]) Map.toPermalink
[ webLogContains webLogId; linkParam ]
Map.toPermalink
} }
/// Get all complete posts for the given web log /// Get all complete posts for the given web log
let findFullByWebLog webLogId = backgroundTask { let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Post.findFullByWebLog" 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 let! revisions = Revisions.findByWebLog Table.PostRevision Table.Post PostId webLogId
return return
posts posts
@@ -122,23 +120,26 @@ type PostgresPostData(log: ILogger) =
/// Get a page of categorized posts for the given web log (excludes revisions) /// Get a page of categorized posts for the given web log (excludes revisions)
let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfCategorizedPosts" 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 Custom.list
$"{selectWithCriteria Table.Post} $"""{selectWithCriteria Table.Post}
AND {catSql} AND {Query.whereByFields All [ catIdField ]}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC {Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} DESC" ] PostgreSQL}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catParam ] (addFieldParams [ catIdField] [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ])
postWithoutLinks postWithoutLinks
/// Get a page of posts for the given web log (excludes text and revisions) /// Get a page of posts for the given web log (excludes text and revisions)
let findPageOfPosts webLogId pageNbr postsPerPage = let findPageOfPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPosts" 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 Custom.list
$"{selectWithCriteria Table.Post} $"{selectWithCriteria Table.Post}{order}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC NULLS FIRST, LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
data ->> '{nameof Post.Empty.UpdatedOn}'
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ webLogContains webLogId ] [ webLogContains webLogId ]
postWithoutText postWithoutText
@@ -146,9 +147,9 @@ type PostgresPostData(log: ILogger) =
let findPageOfPublishedPosts webLogId pageNbr postsPerPage = let findPageOfPublishedPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPublishedPosts" log.LogTrace "Post.findPageOfPublishedPosts"
Custom.list Custom.list
$"{selectWithCriteria Table.Post} $"""{selectWithCriteria Table.Post}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC {Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} DESC" ] PostgreSQL}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ] [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ]
postWithoutLinks postWithoutLinks
@@ -156,10 +157,10 @@ type PostgresPostData(log: ILogger) =
let findPageOfTaggedPosts webLogId (tag: string) pageNbr postsPerPage = let findPageOfTaggedPosts webLogId (tag: string) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfTaggedPosts" log.LogTrace "Post.findPageOfTaggedPosts"
Custom.list Custom.list
$"{selectWithCriteria Table.Post} $"""{selectWithCriteria Table.Post}
AND data['{nameof Post.Empty.Tags}'] @> @tag AND data['{nameof Post.Empty.Tags}'] @> @tag
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC {Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} DESC" ] PostgreSQL}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; jsonParam "@tag" [| tag |] ] [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; jsonParam "@tag" [| tag |] ]
postWithoutLinks postWithoutLinks
@@ -170,10 +171,10 @@ type PostgresPostData(log: ILogger) =
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}
"@publishedOn", Sql.timestamptz (publishedOn.ToDateTimeOffset()) ] "@publishedOn", Sql.timestamptz (publishedOn.ToDateTimeOffset()) ]
let query op direction = let query op direction =
$"{selectWithCriteria Table.Post} $"""{selectWithCriteria Table.Post}
AND (data ->> '{nameof Post.Empty.PublishedOn}')::timestamp with time zone %s{op} @publishedOn AND (data->>'{nameof Post.Empty.PublishedOn}')::timestamp with time zone %s{op} @publishedOn
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' %s{direction} {Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} %s{direction}" ] PostgreSQL}
LIMIT 1" LIMIT 1"""
let! older = Custom.list (query "<" "DESC") (queryParams ()) postWithoutLinks let! older = Custom.list (query "<" "DESC") (queryParams ()) postWithoutLinks
let! newer = Custom.list (query ">" "") (queryParams ()) postWithoutLinks let! newer = Custom.list (query ">" "") (queryParams ()) postWithoutLinks
return List.tryHead older, List.tryHead newer return List.tryHead older, List.tryHead newer
@@ -33,18 +33,15 @@ type PostgresTagMapData(log: ILogger) =
/// Get all tag mappings for the given web log /// Get all tag mappings for the given web log
let findByWebLog webLogId = let findByWebLog webLogId =
log.LogTrace "TagMap.findByWebLog" log.LogTrace "TagMap.findByWebLog"
Custom.list Find.byContainsOrdered<TagMap> Table.TagMap (webLogDoc webLogId) [ Field.Named (nameof TagMap.Empty.Tag) ]
$"{selectWithCriteria Table.TagMap} ORDER BY data ->> 'tag'"
[ webLogContains webLogId ]
fromData<TagMap>
/// Find any tag mappings in a list of tags for the given web log /// 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" 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 Custom.list
$"{selectWithCriteria Table.TagMap} AND {tagSql}" $"{selectWithCriteria Table.TagMap} AND {Query.whereByFields All [ tagField ]}"
[ webLogContains webLogId; tagParam ] (addFieldParams [ tagField ] [ webLogContains webLogId ])
fromData<TagMap> fromData<TagMap>
/// Save a tag mapping /// Save a tag mapping
@@ -17,11 +17,11 @@ type PostgresThemeData(log: ILogger) =
/// Retrieve all themes (except 'admin'; excludes template text) /// Retrieve all themes (except 'admin'; excludes template text)
let all () = let all () =
log.LogTrace "Theme.all" log.LogTrace "Theme.all"
let fields = [ Field.NotEqual (nameof Theme.Empty.Id) "admin" ]
Custom.list Custom.list
$"{Query.selectFromTable Table.Theme} (Query.byFields (Query.find Table.Theme) Any fields
WHERE data ->> '{nameof Theme.Empty.Id}' <> 'admin' + Query.orderBy [ Field.Named (nameof Theme.Empty.Id) ] PostgreSQL)
ORDER BY data ->> '{nameof Theme.Empty.Id}'" (addFieldParams fields [])
[]
withoutTemplateText withoutTemplateText
/// Does a given theme exist? /// Does a given theme exist?
@@ -37,7 +37,7 @@ type PostgresThemeData(log: ILogger) =
/// Find a theme by its ID (excludes the text of templates) /// Find a theme by its ID (excludes the text of templates)
let findByIdWithoutText (themeId: ThemeId) = let findByIdWithoutText (themeId: ThemeId) =
log.LogTrace "Theme.findByIdWithoutText" 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 /// Delete a theme by its ID
let delete themeId = backgroundTask { let delete themeId = backgroundTask {
@@ -45,8 +45,8 @@ type PostgresThemeData(log: ILogger) =
match! exists themeId with match! exists themeId with
| true -> | true ->
do! Custom.nonQuery do! Custom.nonQuery
$"""DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; $"""{Query.delete Table.ThemeAsset} WHERE theme_id = @id;
DELETE FROM {Table.Theme} WHERE {Query.whereById "@id"}""" {Query.delete Table.Theme} WHERE {Query.whereById "@id"}"""
[ idParam themeId ] [ idParam themeId ]
return true return true
| false -> return false | false -> return false
@@ -77,7 +77,7 @@ type PostgresThemeAssetData(log: ILogger) =
/// Delete all assets for the given theme /// Delete all assets for the given theme
let deleteByTheme (themeId: ThemeId) = let deleteByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.deleteByTheme" 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 /// Find a theme asset by its ID
let findById assetId = let findById assetId =
@@ -23,22 +23,22 @@ type PostgresWebLogData(log: ILogger) =
let delete webLogId = let delete webLogId =
log.LogTrace "WebLog.delete" log.LogTrace "WebLog.delete"
Custom.nonQuery Custom.nonQuery
$"""DELETE FROM {Table.PostComment} $"""{Query.delete Table.PostComment}
WHERE data ->> '{nameof Comment.Empty.PostId}' WHERE data->>'{nameof Comment.Empty.PostId}'
IN (SELECT data ->> '{nameof Post.Empty.Id}' IN (SELECT data->>'{nameof Post.Empty.Id}'
FROM {Table.Post} FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"}); WHERE {Query.whereDataContains "@criteria"});
DELETE FROM {Table.PostRevision} {Query.delete Table.PostRevision}
WHERE post_id IN (SELECT data ->> 'Id' FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"}); WHERE post_id IN (SELECT data->>'Id' FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"});
DELETE FROM {Table.PageRevision} {Query.delete Table.PageRevision}
WHERE page_id IN (SELECT data ->> 'Id' FROM {Table.Page} WHERE {Query.whereDataContains "@criteria"}); WHERE page_id IN (SELECT data->>'Id' FROM {Table.Page} WHERE {Query.whereDataContains "@criteria"});
{Query.Delete.byContains Table.Post}; {Query.byContains (Query.delete Table.Post)};
{Query.Delete.byContains Table.Page}; {Query.byContains (Query.delete Table.Page)};
{Query.Delete.byContains Table.Category}; {Query.byContains (Query.delete Table.Category)};
{Query.Delete.byContains Table.TagMap}; {Query.byContains (Query.delete Table.TagMap)};
{Query.Delete.byContains Table.WebLogUser}; {Query.byContains (Query.delete Table.WebLogUser)};
DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId; {Query.delete Table.Upload} WHERE web_log_id = @webLogId;
DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}""" {Query.delete Table.WebLog} WHERE data->>'Id' = @webLogId"""
[ webLogIdParam webLogId; webLogContains webLogId ] [ webLogIdParam webLogId; webLogContains webLogId ]
/// Find a web log by its host (URL base) /// Find a web log by its host (URL base)
@@ -49,19 +49,17 @@ type PostgresWebLogUserData(log: ILogger) =
/// Get all users for the given web log /// Get all users for the given web log
let findByWebLog webLogId = let findByWebLog webLogId =
log.LogTrace "WebLogUser.findByWebLog" log.LogTrace "WebLogUser.findByWebLog"
Custom.list Find.byContainsOrdered<WebLogUser>
$"{selectWithCriteria Table.WebLogUser} ORDER BY LOWER(data ->> '{nameof WebLogUser.Empty.PreferredName}')" Table.WebLogUser (webLogDoc webLogId) [ Field.Named $"i:{nameof WebLogUser.Empty.PreferredName}" ]
[ webLogContains webLogId ]
fromData<WebLogUser>
/// Find the names of users by their IDs for the given web log /// Find the names of users by their IDs for the given web log
let findNames webLogId (userIds: WebLogUserId list) = backgroundTask { let findNames webLogId (userIds: WebLogUserId list) = backgroundTask {
log.LogTrace "WebLogUser.findNames" 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 = let! users =
Custom.list Custom.list
$"{selectWithCriteria Table.WebLogUser} {idSql}" $"{selectWithCriteria Table.WebLogUser} AND {Query.whereByFields All [ idField ]}"
(webLogContains webLogId :: idParams) (addFieldParams [ idField ] [ webLogContains webLogId ])
fromData<WebLogUser> fromData<WebLogUser>
return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName })
} }
+38 -20
View File
@@ -25,7 +25,7 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
// Theme tables // Theme tables
if needsTable Table.Theme then if needsTable Table.Theme then
Query.Definition.ensureTable Table.Theme Query.Definition.ensureTable Table.Theme
Query.Definition.ensureKey Table.Theme Query.Definition.ensureKey Table.Theme PostgreSQL
if needsTable Table.ThemeAsset then if needsTable Table.ThemeAsset then
$"CREATE TABLE {Table.ThemeAsset} ( $"CREATE TABLE {Table.ThemeAsset} (
theme_id TEXT NOT NULL, theme_id TEXT NOT NULL,
@@ -37,28 +37,28 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
// Web log table // Web log table
if needsTable Table.WebLog then if needsTable Table.WebLog then
Query.Definition.ensureTable Table.WebLog Query.Definition.ensureTable Table.WebLog
Query.Definition.ensureKey Table.WebLog Query.Definition.ensureKey Table.WebLog PostgreSQL
Query.Definition.ensureDocumentIndex Table.WebLog Optimized Query.Definition.ensureDocumentIndex Table.WebLog Optimized
// Category table // Category table
if needsTable Table.Category then if needsTable Table.Category then
Query.Definition.ensureTable Table.Category Query.Definition.ensureTable Table.Category
Query.Definition.ensureKey Table.Category Query.Definition.ensureKey Table.Category PostgreSQL
Query.Definition.ensureDocumentIndex Table.Category Optimized Query.Definition.ensureDocumentIndex Table.Category Optimized
// Web log user table // Web log user table
if needsTable Table.WebLogUser then if needsTable Table.WebLogUser then
Query.Definition.ensureTable Table.WebLogUser Query.Definition.ensureTable Table.WebLogUser
Query.Definition.ensureKey Table.WebLogUser Query.Definition.ensureKey Table.WebLogUser PostgreSQL
Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized
// Page tables // Page tables
if needsTable Table.Page then if needsTable Table.Page then
Query.Definition.ensureTable Table.Page Query.Definition.ensureTable Table.Page
Query.Definition.ensureKey Table.Page Query.Definition.ensureKey Table.Page PostgreSQL
Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ] Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ] PostgreSQL
Query.Definition.ensureIndexOn 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 if needsTable Table.PageRevision then
$"CREATE TABLE {Table.PageRevision} ( $"CREATE TABLE {Table.PageRevision} (
page_id TEXT NOT NULL, page_id TEXT NOT NULL,
@@ -69,14 +69,15 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
// Post tables // Post tables
if needsTable Table.Post then if needsTable Table.Post then
Query.Definition.ensureTable Table.Post Query.Definition.ensureTable Table.Post
Query.Definition.ensureKey Table.Post Query.Definition.ensureKey Table.Post PostgreSQL
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ] Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ] PostgreSQL
Query.Definition.ensureIndexOn 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 Query.Definition.ensureIndexOn
Table.Post Table.Post
"status" "status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ] [ 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_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}']))" $"CREATE INDEX idx_post_tag ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))"
if needsTable Table.PostRevision then if needsTable Table.PostRevision then
@@ -87,13 +88,13 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
PRIMARY KEY (post_id, as_of))" PRIMARY KEY (post_id, as_of))"
if needsTable Table.PostComment then if needsTable Table.PostComment then
Query.Definition.ensureTable Table.PostComment Query.Definition.ensureTable Table.PostComment
Query.Definition.ensureKey Table.PostComment Query.Definition.ensureKey Table.PostComment PostgreSQL
Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ] Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ] PostgreSQL
// Tag map table // Tag map table
if needsTable Table.TagMap then if needsTable Table.TagMap then
Query.Definition.ensureTable Table.TagMap Query.Definition.ensureTable Table.TagMap
Query.Definition.ensureKey Table.TagMap Query.Definition.ensureKey Table.TagMap PostgreSQL
Query.Definition.ensureDocumentIndex Table.TagMap Optimized Query.Definition.ensureDocumentIndex Table.TagMap Optimized
// Uploaded file table // Uploaded file table
@@ -153,7 +154,8 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
Table.WebLogUser ] Table.WebLogUser ]
Utils.Migration.logStep log migration "Adding unique indexes on ID fields" 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" Utils.Migration.logStep log migration "Removing constraints"
let fkToDrop = let fkToDrop =
@@ -187,24 +189,25 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
Utils.Migration.logStep log migration "Adding new indexes" Utils.Migration.logStep log migration "Adding new indexes"
let newIdx = 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.Category Optimized
Query.Definition.ensureDocumentIndex Table.TagMap Optimized Query.Definition.ensureDocumentIndex Table.TagMap Optimized
Query.Definition.ensureDocumentIndex Table.WebLog Optimized Query.Definition.ensureDocumentIndex Table.WebLog Optimized
Query.Definition.ensureDocumentIndex Table.WebLogUser 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 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
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ] Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ] PostgreSQL
Query.Definition.ensureIndexOn 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 Query.Definition.ensureIndexOn
Table.Post Table.Post
"status" "status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ] [ 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_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}']))" $"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 "; ") [] do! Custom.nonQuery (newIdx |> String.concat "; ") []
Utils.Migration.logStep log migration "Setting database to version 2.1.1" Utils.Migration.logStep log migration "Setting database to version 2.1.1"
@@ -221,6 +224,17 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
return! setDbVersion "v2.2" return! setDbVersion "v2.2"
} }
/// Migrate from v2.2 to v3
let migrateV2point2ToV3 () = backgroundTask {
Utils.Migration.logStep log "v2.2 to v3" "Adding auto-OpenGraph flag to all web logs"
do! Patch.byFields Table.WebLog Any [ Field.Exists (nameof WebLog.Empty.Id) ] {| AutoOpenGraph = true |}
Utils.Migration.logStep log "v2.2 to v3" "Converting auto-htmx flag to choices"
do! Patch.byContains Table.WebLog {| AutoHtmx = true |} {| AutoHtmx = "Yes" |}
do! Patch.byContains Table.WebLog {| AutoHtmx = false |} {| AutoHtmx = "No" |}
Utils.Migration.logStep log "v2.2 to v3" "Setting database version to v3"
return! setDbVersion "v3"
}
/// Do required data migration between versions /// Do required data migration between versions
let migrate version = backgroundTask { let migrate version = backgroundTask {
let mutable v = defaultArg version "" let mutable v = defaultArg version ""
@@ -240,6 +254,10 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
let! ver = migrateV2point1point1ToV2point2 () let! ver = migrateV2point1point1ToV2point2 ()
v <- ver v <- ver
if v = "v2.2" then
let! ver = migrateV2point2ToV3 ()
v <- ver
if v <> Utils.Migration.currentDbVersion then if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}" log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
let! _ = setDbVersion Utils.Migration.currentDbVersion let! _ = setDbVersion Utils.Migration.currentDbVersion
+38 -2
View File
@@ -256,6 +256,31 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
do! setDbVersion "v2.2" do! setDbVersion "v2.2"
} }
/// Migrate from v2.2 to v3
let migrateV2point2ToV3 () = backgroundTask {
Utils.Migration.logStep log "v2.2 to v3" "Adding auto-OpenGraph flag to all web logs"
do! rethink {
withTable Table.WebLog
update [ nameof WebLog.Empty.AutoOpenGraph, true :> obj ]
write; withRetryOnce; ignoreResult conn
}
Utils.Migration.logStep log "v2.2 to v3" "Converting auto-htmx flag to choices"
do! rethink {
withTable Table.WebLog
filter (nameof WebLog.Empty.AutoHtmx) true
update [ nameof WebLog.Empty.AutoHtmx, "Yes" :> obj ]
write; withRetryOnce; ignoreResult conn
}
do! rethink {
withTable Table.WebLog
filter (nameof WebLog.Empty.AutoHtmx) false
update [ nameof WebLog.Empty.AutoHtmx, "No" :> obj ]
write; withRetryOnce; ignoreResult conn
}
Utils.Migration.logStep log "v2.2 to v3" "Setting database version to v3"
do! setDbVersion "v3"
}
/// Migrate data between versions /// Migrate data between versions
let migrate version = backgroundTask { let migrate version = backgroundTask {
let mutable v = defaultArg version "" let mutable v = defaultArg version ""
@@ -280,6 +305,10 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
do! migrateV2point1point1ToV2point2 () do! migrateV2point1point1ToV2point2 ()
v <- "v2.2" v <- "v2.2"
if v = "v2.2" then
do! migrateV2point2ToV3 ()
v <- "v3"
if v <> Utils.Migration.currentDbVersion then if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}" log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
do! setDbVersion Utils.Migration.currentDbVersion do! setDbVersion Utils.Migration.currentDbVersion
@@ -1234,8 +1263,15 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
log.LogInformation $"Creating table {tbl}..." log.LogInformation $"Creating table {tbl}..."
do! rethink { tableCreate tbl [ PrimaryKey "Id" ]; write; withRetryOnce; ignoreResult conn } do! rethink { tableCreate tbl [ PrimaryKey "Id" ]; write; withRetryOnce; ignoreResult conn }
if not (List.contains Table.DbVersion tables) then if List.isEmpty tables then
// Version table added in v2-rc2; this will flag that migration to be run // New install; set version to current version
do! rethink {
withTable Table.DbVersion
insert {| Id = Utils.Migration.currentDbVersion |}
write; withRetryOnce; ignoreResult conn
}
elif not (List.contains Table.DbVersion tables) then
// Other tables, but not version, added in v2-rc2; this will flag that migration to be run
do! rethink { do! rethink {
withTable Table.DbVersion withTable Table.DbVersion
insert {| Id = "v2-rc1" |} insert {| Id = "v2-rc1" |}
+29 -32
View File
@@ -16,22 +16,23 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge
let parentIdField = nameof Category.Empty.ParentId let parentIdField = nameof Category.Empty.ParentId
/// Count all categories for the given web log /// Count all categories for the given web log
let countAll webLogId = let countAll webLogId = backgroundTask {
log.LogTrace "Category.countAll" 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 /// Count all top-level categories for the given web log
let countTopLevel webLogId = let countTopLevel webLogId = backgroundTask {
log.LogTrace "Category.countTopLevel" log.LogTrace "Category.countTopLevel"
conn.customScalar let! count = conn.countByFields Table.Category All [ webLogField webLogId; Field.NotExists parentIdField ]
$"{Document.Query.countByWebLog Table.Category} AND data ->> '{parentIdField}' IS NULL" return int count
[ webLogParam webLogId ] }
(toCount >> int)
/// Find all categories for the given web log /// Find all categories for the given web log
let findByWebLog webLogId = let findByWebLog webLogId =
log.LogTrace "Category.findByWebLog" 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 /// Retrieve all categories for the given web log in a DotLiquid-friendly format
let findAllForView webLogId = backgroundTask { let findAllForView webLogId = backgroundTask {
@@ -42,20 +43,18 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge
ordered ordered
|> Seq.map (fun it -> backgroundTask { |> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories // Parent category post counts include posts in subcategories
let catSql, catParams = let childField =
ordered ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name) |> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map _.Id |> Seq.map _.Id
|> Seq.append (Seq.singleton it.Id) |> Seq.append (Seq.singleton it.Id)
|> List.ofSeq |> Field.InArray (nameof Post.Empty.CategoryIds) Table.Post
|> inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId" let fields =
let query = $""" [ webLogField webLogId; Field.Equal (nameof Post.Empty.Status) (string Published); childField ]
SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') let query =
FROM {Table.Post} (Query.statementWhere (Query.count Table.Post) (Query.whereByFields All fields))
WHERE {Document.Query.whereByWebLog} .Replace("(*)", $"(DISTINCT data->>'{nameof Post.Empty.Id}')")
AND {Query.whereByField (Field.EQ (nameof Post.Empty.Status) "") $"'{string Published}'"} let! postCount = conn.customScalar query (addFieldParams fields []) toCount
AND {catSql}"""
let! postCount = conn.customScalar query (webLogParam webLogId :: catParams) toCount
return it.Id, int postCount return it.Id, int postCount
}) })
|> Task.WhenAll |> 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 /// Find a category by its ID for the given web log
let findById catId webLogId = let findById (catId: CategoryId) webLogId =
log.LogTrace "Category.findById" 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 /// Delete a category
let delete catId webLogId = backgroundTask { let delete catId webLogId = backgroundTask {
@@ -79,24 +78,22 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge
match! findById catId webLogId with match! findById catId webLogId with
| Some cat -> | Some cat ->
// Reassign any children to the category's parent category // 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 if children > 0L then
let parent = Field.EQ parentIdField (string catId) let parent = [ Field.Equal parentIdField (string catId) ]
match cat.ParentId with match cat.ParentId with
| Some _ -> do! conn.patchByField Table.Category parent {| ParentId = cat.ParentId |} | Some _ -> do! conn.patchByFields Table.Category Any parent {| ParentId = cat.ParentId |}
| None -> do! conn.removeFieldsByField Table.Category parent [ parentIdField ] | None -> do! conn.removeFieldsByFields Table.Category Any parent [ parentIdField ]
// Delete the category off all posts where it is assigned, and the category itself // Delete the category off all posts where it is assigned, and the category itself
let catIdField = nameof Post.Empty.CategoryIds 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 = let! posts =
conn.customList conn.customList
$"SELECT data ->> '{nameof Post.Empty.Id}', data -> '{catIdField}' query
FROM {Table.Post} (addFieldParams fields [])
WHERE {Document.Query.whereByWebLog}
AND EXISTS
(SELECT 1
FROM json_each({Table.Post}.data -> '{catIdField}')
WHERE json_each.value = @id)"
[ idParam catId; webLogParam webLogId ]
(fun rdr -> rdr.GetString 0, Utils.deserialize<string list> ser (rdr.GetString 1)) (fun rdr -> rdr.GetString 0, Utils.deserialize<string list> ser (rdr.GetString 1))
for postId, cats in posts do for postId, cats in posts do
do! conn.patchById do! conn.patchById
+19 -85
View File
@@ -82,39 +82,6 @@ let instantParam =
let maybeInstant = let maybeInstant =
Option.map instantParam >> maybe 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 /// Functions to map domain items from a data reader
module Map = module Map =
@@ -218,6 +185,8 @@ module Map =
Data = data } Data = data }
open BitBadger.Documents
/// Create a named parameter /// Create a named parameter
let sqlParam name (value: obj) = let sqlParam name (value: obj) =
SqliteParameter(name, value) SqliteParameter(name, value)
@@ -226,82 +195,47 @@ let sqlParam name (value: obj) =
let webLogParam (webLogId: WebLogId) = let webLogParam (webLogId: WebLogId) =
sqlParam "@webLogId" (string 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
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 /// Functions to support revisions
module Revisions = module Revisions =
/// Find all revisions for the given entity /// Find all revisions for the given entity
let findByEntityId<'TKey> revTable entityTable (key: 'TKey) conn = let findByEntityId<'TKey> revTable entityTable (key: 'TKey) (conn: SqliteConnection) =
Custom.list conn.customList
$"SELECT as_of, revision_text FROM %s{revTable} WHERE %s{entityTable}_id = @id ORDER BY as_of DESC" $"SELECT as_of, revision_text FROM %s{revTable} WHERE %s{entityTable}_id = @id ORDER BY as_of DESC"
[ idParam key ] [ idParam key ]
Map.toRevision Map.toRevision
conn
/// Find all revisions for all posts for the given web log /// Find all revisions for all posts for the given web log
let findByWebLog<'TKey> revTable entityTable (keyFunc: string -> 'TKey) webLogId conn = let findByWebLog<'TKey> revTable entityTable (keyFunc: string -> 'TKey) webLogId (conn: SqliteConnection) =
Custom.list conn.customList
$"SELECT pr.* $"SELECT pr.*
FROM %s{revTable} pr FROM %s{revTable} pr
INNER JOIN %s{entityTable} p ON p.data ->> 'Id' = pr.{entityTable}_id INNER JOIN %s{entityTable} p ON p.data->>'Id' = pr.{entityTable}_id
WHERE p.{Document.Query.whereByWebLog} WHERE p.{Query.whereByFields Any [ webLogField webLogId ]}
ORDER BY as_of DESC" ORDER BY as_of DESC"
[ webLogParam webLogId ] [ webLogParam webLogId ]
(fun rdr -> keyFunc (Map.getString $"{entityTable}_id" rdr), Map.toRevision rdr) (fun rdr -> keyFunc (Map.getString $"{entityTable}_id" rdr), Map.toRevision rdr)
conn
/// Update a page or post's revisions /// 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 let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs
for delRev in toDelete do for delRev in toDelete do
do! Custom.nonQuery do! conn.customNonQuery
$"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf" $"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf"
[ idParam key; sqlParam "@asOf" (instantParam delRev.AsOf) ] [ idParam key; sqlParam "@asOf" (instantParam delRev.AsOf) ]
conn
for addRev in toAdd do for addRev in toAdd do
do! Custom.nonQuery do! conn.customNonQuery
$"INSERT INTO {revTable} VALUES (@id, @asOf, @text)" $"INSERT INTO {revTable} VALUES (@id, @asOf, @text)"
[ idParam key; sqlParam "asOf" (instantParam addRev.AsOf); sqlParam "@text" (string addRev.Text) ] [ idParam key; sqlParam "asOf" (instantParam addRev.AsOf); sqlParam "@text" (string addRev.Text) ]
conn
} }
+36 -34
View File
@@ -17,8 +17,10 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
/// The JSON field name for the "is in page list" flag /// The JSON field name for the "is in page list" flag
let pgListName = nameof Page.Empty.IsInPageList let pgListName = nameof Page.Empty.IsInPageList
/// The JSON field for the title of the page /// Query to return pages sorted by title
let titleField = $"data ->> '{nameof Page.Empty.Title}'" let sortedPages fields =
Query.byFields (Query.find Table.Page) All fields
+ Query.orderBy [ Field.Named $"i:{nameof Page.Empty.Title}" ] SQLite
// SUPPORT FUNCTIONS // 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) /// Get all pages for a web log (without text, metadata, revisions, or prior permalinks)
let all webLogId = let all webLogId =
log.LogTrace "Page.all" log.LogTrace "Page.all"
let field = [ webLogField webLogId ]
conn.customList conn.customList
$"{Query.selectFromTable Table.Page} WHERE {Document.Query.whereByWebLog} ORDER BY LOWER({titleField})" (sortedPages field)
[ webLogParam webLogId ] (addFieldParams field [])
(fun rdr -> { fromData<Page> rdr with Text = ""; Metadata = []; PriorPermalinks = [] }) (fun rdr -> { fromData<Page> rdr with Text = ""; Metadata = []; PriorPermalinks = [] })
/// Count all pages for the given web log /// Count all pages for the given web log
let countAll webLogId = let countAll webLogId = backgroundTask {
log.LogTrace "Page.countAll" 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 /// Count all pages shown in the page list for the given web log
let countListed webLogId = let countListed webLogId = backgroundTask {
log.LogTrace "Page.countListed" log.LogTrace "Page.countListed"
conn.customScalar let! count = conn.countByFields Table.Page All [ webLogField webLogId; Field.Equal pgListName true ]
$"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"}""" return int count
[ webLogParam webLogId ] }
(toCount >> int)
/// Find a page by its ID (without revisions and prior permalinks) /// 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" 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 = [] } | Some page -> return Some { page with PriorPermalinks = [] }
| None -> return None | None -> return None
} }
/// Find a complete page by its ID /// Find a complete page by its ID
let findFullById pageId webLogId = backgroundTask { let findFullById (pageId: PageId) webLogId = backgroundTask {
log.LogTrace "Page.findFullById" 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 -> | Some page ->
let! page = appendPageRevisions page let! page = appendPageRevisions page
return Some page return Some page
@@ -93,7 +97,8 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
match! findById pageId webLogId with match! findById pageId webLogId with
| Some _ -> | Some _ ->
do! conn.customNonQuery 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 ] [ idParam pageId ]
return true return true
| None -> return false | None -> return false
@@ -102,27 +107,25 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
/// Find a page by its permalink for the given web log /// Find a page by its permalink for the given web log
let findByPermalink (permalink: Permalink) webLogId = let findByPermalink (permalink: Permalink) webLogId =
log.LogTrace "Page.findByPermalink" log.LogTrace "Page.findByPermalink"
let linkParam = Field.EQ linkName (string permalink) let fields = [ webLogField webLogId; Field.Equal linkName (string permalink) ]
conn.customSingle conn.customSingle
$"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkParam "@link"}""" (Query.byFields (Query.find Table.Page) All fields) (addFieldParams fields []) pageWithoutLinks
(addFieldParam "@link" linkParam [ webLogParam webLogId ])
pageWithoutLinks
/// Find the current permalink within a set of potential prior permalinks for the given web log /// Find the current permalink within a set of potential prior permalinks for the given web log
let findCurrentPermalink (permalinks: Permalink list) webLogId = let findCurrentPermalink (permalinks: Permalink list) webLogId =
log.LogTrace "Page.findCurrentPermalink" log.LogTrace "Page.findCurrentPermalink"
let linkSql, linkParams = inJsonArray Table.Page (nameof Page.Empty.PriorPermalinks) "link" permalinks let fields =
conn.customSingle [ webLogField webLogId
$"SELECT data ->> '{linkName}' AS permalink Field.InArray (nameof Page.Empty.PriorPermalinks) Table.Page (List.map string permalinks) ]
FROM {Table.Page} let query =
WHERE {Document.Query.whereByWebLog} AND {linkSql}" (Query.statementWhere (Query.find Table.Page) (Query.whereByFields All fields))
(webLogParam webLogId :: linkParams) .Replace("SELECT data", $"SELECT data->>'{linkName}' AS permalink")
Map.toPermalink conn.customSingle query (addFieldParams fields []) Map.toPermalink
/// Get all complete pages for the given web log /// Get all complete pages for the given web log
let findFullByWebLog webLogId = backgroundTask { let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Page.findFullByWebLog" 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 let! withRevs = pages |> List.map appendPageRevisions |> Task.WhenAll
return List.ofArray withRevs 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) /// Get all listed pages for the given web log (without revisions or text)
let findListed webLogId = let findListed webLogId =
log.LogTrace "Page.findListed" log.LogTrace "Page.findListed"
let fields = [ webLogField webLogId; Field.Equal pgListName true ]
conn.customList conn.customList
$"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"} (sortedPages fields) (addFieldParams fields []) (fun rdr -> { fromData<Page> rdr with Text = "" })
ORDER BY LOWER({titleField})"""
[ webLogParam webLogId ]
(fun rdr -> { fromData<Page> rdr with Text = "" })
/// Get a page of pages for the given web log (without revisions) /// Get a page of pages for the given web log (without revisions)
let findPageOfPages webLogId pageNbr = let findPageOfPages webLogId pageNbr =
log.LogTrace "Page.findPageOfPages" log.LogTrace "Page.findPageOfPages"
let field = [ webLogField webLogId ]
conn.customList conn.customList
$"{Document.Query.selectByWebLog Table.Page} ORDER BY LOWER({titleField}) LIMIT @pageSize OFFSET @toSkip" $"{sortedPages field} LIMIT @pageSize OFFSET @toSkip"
[ webLogParam webLogId; SqliteParameter("@pageSize", 26); SqliteParameter("@toSkip", (pageNbr - 1) * 25) ] (addFieldParams field [ sqlParam "@pageSize" 26; sqlParam "@toSkip" ((pageNbr - 1) * 25) ])
(fun rdr -> { pageWithoutLinks rdr with Metadata = [] }) (fun rdr -> { pageWithoutLinks rdr with Metadata = [] })
/// Update a page /// Update a page
+57 -52
View File
@@ -16,7 +16,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
let linkName = nameof Post.Empty.Permalink let linkName = nameof Post.Empty.Permalink
/// The JSON field for when the post was published /// 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 /// The name of the JSON field for the post's status
let statName = nameof Post.Empty.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 /// 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 /// Return a post with no revisions or prior permalinks
let postWithoutLinks rdr = 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 /// The SELECT statement to retrieve published posts with a web log ID parameter
let publishedPostByWebLog = let publishedPostByWebLog =
$"""{postByWebLog} AND {Query.whereByField (Field.EQ statName "") $"'{string Published}'"}""" $"{postByWebLog} AND data->>'{statName}' = '{string Published}'"
/// Update a post's revisions /// Update a post's revisions
let updatePostRevisions (postId: PostId) oldRevs newRevs = 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 /// 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" log.LogTrace "Post.countByStatus"
let statParam = Field.EQ statName (string status) let! count = conn.countByFields Table.Post All [ webLogField webLogId; Field.Equal statName (string status) ]
conn.customScalar return int count
$"""{Document.Query.countByWebLog Table.Post} AND {Query.whereByField statParam "@status"}""" }
(addFieldParam "@status" statParam [ webLogParam webLogId ])
(toCount >> int)
/// Find a post by its ID for the given web log (excluding revisions) /// 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" 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 = [] } | Some post -> return Some { post with PriorPermalinks = [] }
| None -> return None | 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) /// Find a post by its permalink for the given web log (excluding revisions)
let findByPermalink (permalink: Permalink) webLogId = let findByPermalink (permalink: Permalink) webLogId =
log.LogTrace "Post.findByPermalink" log.LogTrace "Post.findByPermalink"
let linkParam = Field.EQ linkName (string permalink) let fields = [ webLogField webLogId; Field.Equal linkName (string permalink) ]
conn.customSingle conn.customSingle
$"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkParam "@link"}""" (Query.byFields (Query.find Table.Post) All fields) (addFieldParams fields []) postWithoutLinks
(addFieldParam "@link" linkParam [ webLogParam webLogId ])
postWithoutLinks
/// Find a complete post by its ID for the given web log /// Find a complete post by its ID for the given web log
let findFullById postId webLogId = backgroundTask { let findFullById postId webLogId = backgroundTask {
log.LogTrace "Post.findFullById" 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 -> | Some post ->
let! post = appendPostRevisions post let! post = appendPostRevisions post
return Some post return Some post
@@ -101,10 +100,12 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
match! findById postId webLogId with match! findById postId webLogId with
| Some _ -> | Some _ ->
do! conn.customNonQuery do! conn.customNonQuery
$"""DELETE FROM {Table.PostRevision} WHERE post_id = @id; $"""{Query.delete Table.PostRevision} WHERE post_id = @id;
DELETE FROM {Table.PostComment} {Query.byFields
WHERE {Query.whereByField (Field.EQ (nameof Comment.Empty.PostId) "") "@id"}; (Query.delete Table.PostComment)
{Query.Delete.byId Table.Post}""" Any
[ { Field.EQ (nameof Comment.Empty.PostId) postId with ParameterName = Some "@id" }]};
{Query.byId (Query.delete Table.Post) (string postId)}"""
[ idParam postId ] [ idParam postId ]
return true return true
| None -> return false | 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 /// Find the current permalink from a list of potential prior permalinks for the given web log
let findCurrentPermalink (permalinks: Permalink list) webLogId = let findCurrentPermalink (permalinks: Permalink list) webLogId =
log.LogTrace "Post.findCurrentPermalink" log.LogTrace "Post.findCurrentPermalink"
let linkSql, linkParams = inJsonArray Table.Post (nameof Post.Empty.PriorPermalinks) "link" permalinks let fields =
conn.customSingle [ webLogField webLogId
$"SELECT data ->> '{linkName}' AS permalink Field.InArray (nameof Post.Empty.PriorPermalinks) Table.Post (List.map string permalinks) ]
FROM {Table.Post} let query =
WHERE {Document.Query.whereByWebLog} AND {linkSql}" (Query.statementWhere (Query.find Table.Post) (Query.whereByFields All fields))
(webLogParam webLogId :: linkParams) .Replace("SELECT data", $"SELECT data->>'{linkName}' AS permalink")
Map.toPermalink conn.customSingle query (addFieldParams fields []) Map.toPermalink
/// Get all complete posts for the given web log /// Get all complete posts for the given web log
let findFullByWebLog webLogId = backgroundTask { let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Post.findFullByWebLog" 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 let! withRevs = posts |> List.map appendPostRevisions |> Task.WhenAll
return List.ofArray withRevs 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) /// Get a page of categorized posts for the given web log (excludes revisions)
let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfCategorizedPosts" 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 conn.customList
$"{publishedPostByWebLog} AND {catSql} $"""{publishedPostByWebLog} AND {Query.whereByFields Any [ catIdField ]}
ORDER BY {publishField} DESC {Query.orderBy [ Field.Named $"{publishName} DESC" ] SQLite}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
(webLogParam webLogId :: catParams) (addFieldParams [ webLogField webLogId; catIdField ] [])
postWithoutLinks postWithoutLinks
/// Get a page of posts for the given web log (excludes text and revisions) /// Get a page of posts for the given web log (excludes text and revisions)
let findPageOfPosts webLogId pageNbr postsPerPage = let findPageOfPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPosts" log.LogTrace "Post.findPageOfPosts"
let order =
Query.orderBy
[ Field.Named $"{publishName} DESC NULLS FIRST"; Field.Named (nameof Post.Empty.UpdatedOn) ] SQLite
conn.customList conn.customList
$"{postByWebLog} $"{postByWebLog}{order} LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}'
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ webLogParam webLogId ] [ webLogParam webLogId ]
postWithoutText postWithoutText
@@ -154,36 +156,39 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
let findPageOfPublishedPosts webLogId pageNbr postsPerPage = let findPageOfPublishedPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPublishedPosts" log.LogTrace "Post.findPageOfPublishedPosts"
conn.customList conn.customList
$"{publishedPostByWebLog} $"""{publishedPostByWebLog}
ORDER BY {publishField} DESC {Query.orderBy [ Field.Named $"{publishName} DESC" ] SQLite}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
[ webLogParam webLogId ] [ webLogParam webLogId ]
postWithoutLinks postWithoutLinks
/// Get a page of tagged posts for the given web log (excludes revisions) /// Get a page of tagged posts for the given web log (excludes revisions)
let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfTaggedPosts" 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 conn.customList
$"{publishedPostByWebLog} AND {tagSql} $"""{publishedPostByWebLog} AND {Query.whereByFields Any [ tagField ]}
ORDER BY {publishField} DESC {Query.orderBy [ Field.Named $"{publishName} DESC" ] SQLite}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
(webLogParam webLogId :: tagParams) (addFieldParams [ webLogField webLogId; tagField ] [])
postWithoutLinks postWithoutLinks
/// Find the next newest and oldest post from a publish date for the given web log /// Find the next newest and oldest post from a publish date for the given web log
let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask { let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask {
log.LogTrace "Post.findSurroundingPosts" 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 conn.customSingle
$"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1" (Query.byFields (Query.find Table.Post) All fields
[ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ] + Query.orderBy [ Field.Named (publishName + order) ] SQLite + " LIMIT 1")
postWithoutLinks (addFieldParams fields [])
let! newer =
conn.customSingle
$"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1"
[ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ]
postWithoutLinks postWithoutLinks
let! older = adjacent "<" " DESC"
let! newer = adjacent ">" ""
return older, newer return older, newer
} }
+6 -13
View File
@@ -11,9 +11,9 @@ open MyWebLog.Data
type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) = type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) =
/// Find a tag mapping by its ID for the given web log /// 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" 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 /// Delete a tag mapping for the given web log
let delete tagMapId webLogId = backgroundTask { 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 /// Find a tag mapping by its URL value for the given web log
let findByUrlValue (urlValue: string) webLogId = let findByUrlValue (urlValue: string) webLogId =
log.LogTrace "TagMap.findByUrlValue" log.LogTrace "TagMap.findByUrlValue"
let urlParam = Field.EQ (nameof TagMap.Empty.UrlValue) urlValue conn.findFirstByFields<TagMap>
conn.customSingle Table.TagMap All [ webLogField webLogId; Field.Equal (nameof TagMap.Empty.UrlValue) urlValue ]
$"""{Document.Query.selectByWebLog Table.TagMap} AND {Query.whereByField urlParam "@urlValue"}"""
(addFieldParam "@urlValue" urlParam [ webLogParam webLogId ])
fromData<TagMap>
/// Get all tag mappings for the given web log /// Get all tag mappings for the given web log
let findByWebLog webLogId = let findByWebLog webLogId =
log.LogTrace "TagMap.findByWebLog" 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 /// Find any tag mappings in a list of tags for the given web log
let findMappingForTags (tags: string list) webLogId = let findMappingForTags (tags: string list) webLogId =
log.LogTrace "TagMap.findMappingForTags" log.LogTrace "TagMap.findMappingForTags"
let mapSql, mapParams = inClause $"AND data ->> '{nameof TagMap.Empty.Tag}'" "tag" id tags conn.findByFields<TagMap> Table.TagMap All [ webLogField webLogId; Field.In (nameof TagMap.Empty.Tag) tags ]
conn.customList
$"{Document.Query.selectByWebLog Table.TagMap} {mapSql}"
(webLogParam webLogId :: mapParams)
fromData<TagMap>
/// Save a tag mapping /// Save a tag mapping
let save (tagMap: TagMap) = let save (tagMap: TagMap) =
+9 -7
View File
@@ -10,8 +10,8 @@ open MyWebLog.Data
/// SQLite myWebLog theme data implementation /// SQLite myWebLog theme data implementation
type SQLiteThemeData(conn : SqliteConnection, log: ILogger) = type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
/// The JSON field for the theme ID /// The name of the theme ID field
let idField = $"data ->> '{nameof Theme.Empty.Id}'" let idName = nameof Theme.Empty.Id
/// Convert a document to a theme with no template text /// Convert a document to a theme with no template text
let withoutTemplateText (rdr: SqliteDataReader) = let withoutTemplateText (rdr: SqliteDataReader) =
@@ -25,9 +25,10 @@ type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
/// Retrieve all themes (except 'admin'; excludes template text) /// Retrieve all themes (except 'admin'; excludes template text)
let all () = let all () =
log.LogTrace "Theme.all" log.LogTrace "Theme.all"
let fields = [ Field.NE idName "admin" ]
conn.customList 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 withoutTemplateText
/// Does a given theme exist? /// 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) /// Find a theme by its ID (excludes the text of templates)
let findByIdWithoutText (themeId: ThemeId) = let findByIdWithoutText (themeId: ThemeId) =
log.LogTrace "Theme.findByIdWithoutText" 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 /// Delete a theme by its ID
let delete themeId = backgroundTask { let delete themeId = backgroundTask {
@@ -51,7 +52,8 @@ type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
match! findByIdWithoutText themeId with match! findByIdWithoutText themeId with
| Some _ -> | Some _ ->
do! conn.customNonQuery 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 ] [ idParam themeId ]
return true return true
| None -> return false | None -> return false
@@ -89,7 +91,7 @@ type SQLiteThemeAssetData(conn : SqliteConnection, log: ILogger) =
/// Delete all assets for the given theme /// Delete all assets for the given theme
let deleteByTheme (themeId: ThemeId) = let deleteByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.deleteByTheme" 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 /// Find a theme asset by its ID
let findById assetId = let findById assetId =
+14 -13
View File
@@ -23,25 +23,26 @@ type SQLiteWebLogData(conn: SqliteConnection, log: ILogger) =
/// Delete a web log by its ID /// Delete a web log by its ID
let delete webLogId = let delete webLogId =
log.LogTrace "WebLog.delete" log.LogTrace "WebLog.delete"
let webLogMatches = Query.whereByField (Field.EQ "WebLogId" "") "@webLogId" let webLogMatches =
let subQuery table = $"(SELECT data ->> 'Id' FROM {table} WHERE {webLogMatches})" Query.whereByFields Any [ { Field.Equal "WebLogId" "" with ParameterName = Some "@webLogId" } ]
let subQuery table = $"(SELECT data->>'Id' FROM {table} WHERE {webLogMatches})"
Custom.nonQuery Custom.nonQuery
$"""DELETE FROM {Table.PostComment} WHERE data ->> 'PostId' IN {subQuery Table.Post}; $"""{Query.delete Table.PostComment} WHERE data ->> 'PostId' IN {subQuery Table.Post};
DELETE FROM {Table.PostRevision} WHERE post_id IN {subQuery Table.Post}; {Query.delete Table.PostRevision} WHERE post_id IN {subQuery Table.Post};
DELETE FROM {Table.PageRevision} WHERE page_id IN {subQuery Table.Page}; {Query.delete Table.PageRevision} WHERE page_id IN {subQuery Table.Page};
DELETE FROM {Table.Post} WHERE {webLogMatches}; {Query.delete Table.Post} WHERE {webLogMatches};
DELETE FROM {Table.Page} WHERE {webLogMatches}; {Query.delete Table.Page} WHERE {webLogMatches};
DELETE FROM {Table.Category} WHERE {webLogMatches}; {Query.delete Table.Category} WHERE {webLogMatches};
DELETE FROM {Table.TagMap} WHERE {webLogMatches}; {Query.delete Table.TagMap} WHERE {webLogMatches};
DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId; {Query.delete Table.WebLogUser} WHERE {webLogMatches};
DELETE FROM {Table.WebLogUser} WHERE {webLogMatches}; {Query.delete Table.Upload} WHERE web_log_id = @webLogId;
DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}""" {Query.delete Table.WebLog} WHERE data->>'Id' = @webLogId"""
[ webLogParam webLogId ] [ webLogParam webLogId ]
/// Find a web log by its host (URL base) /// Find a web log by its host (URL base)
let findByHost (url: string) = let findByHost (url: string) =
log.LogTrace "WebLog.findByHost" 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 /// Find a web log by its ID
let findById webLogId = let findById webLogId =
@@ -16,17 +16,18 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) =
conn.insert<WebLogUser> Table.WebLogUser user conn.insert<WebLogUser> Table.WebLogUser user
/// Find a user by their ID for the given web log /// Find a user by their ID for the given web log
let findById userId webLogId = let findById (userId: WebLogUserId) webLogId =
log.LogTrace "WebLogUser.findById" 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 /// Delete a user if they have no posts or pages
let delete userId webLogId = backgroundTask { let delete userId webLogId = backgroundTask {
log.LogTrace "WebLogUser.delete" log.LogTrace "WebLogUser.delete"
match! findById userId webLogId with match! findById userId webLogId with
| Some _ -> | Some _ ->
let! pageCount = conn.countByField Table.Page (Field.EQ (nameof Page.Empty.AuthorId) (string userId)) let author = [ Field.Equal (nameof Page.Empty.AuthorId) (string userId) ]
let! postCount = conn.countByField Table.Post (Field.EQ (nameof Post.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 if pageCount + postCount > 0 then
return Error "User has pages or posts; cannot delete" return Error "User has pages or posts; cannot delete"
else else
@@ -38,27 +39,24 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) =
/// Find a user by their e-mail address for the given web log /// Find a user by their e-mail address for the given web log
let findByEmail (email: string) webLogId = let findByEmail (email: string) webLogId =
log.LogTrace "WebLogUser.findByEmail" log.LogTrace "WebLogUser.findByEmail"
let emailParam = Field.EQ (nameof WebLogUser.Empty.Email) email conn.findFirstByFields
conn.customSingle Table.WebLogUser All [ webLogField webLogId; Field.Equal (nameof WebLogUser.Empty.Email) email ]
$"""{Document.Query.selectByWebLog Table.WebLogUser}
AND {Query.whereByField emailParam "@email"}"""
(addFieldParam "@email" emailParam [ webLogParam webLogId ])
fromData<WebLogUser>
/// Get all users for the given web log /// Get all users for the given web log
let findByWebLog webLogId = backgroundTask { let findByWebLog webLogId = backgroundTask {
log.LogTrace "WebLogUser.findByWebLog" 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() return users |> List.sortBy _.PreferredName.ToLowerInvariant()
} }
/// Find the names of users by their IDs for the given web log /// Find the names of users by their IDs for the given web log
let findNames webLogId (userIds: WebLogUserId list) = let findNames webLogId (userIds: WebLogUserId list) =
log.LogTrace "WebLogUser.findNames" 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 conn.customList
$"{Document.Query.selectByWebLog Table.WebLogUser} {nameSql}" query
(webLogParam webLogId :: nameParams) (addFieldParams fields [])
(fun rdr -> (fun rdr ->
let user = fromData<WebLogUser> rdr let user = fromData<WebLogUser> rdr
{ Name = string user.Id; Value = user.DisplayName }) { Name = string user.Id; Value = user.DisplayName })
+87 -64
View File
@@ -1,7 +1,6 @@
namespace MyWebLog.Data namespace MyWebLog.Data
open System open System
open System.Threading.Tasks
open BitBadger.Documents open BitBadger.Documents
open BitBadger.Documents.Sqlite open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite open Microsoft.Data.Sqlite
@@ -24,98 +23,107 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
let needsTable table = let needsTable table =
not (List.contains table tables) not (List.contains table tables)
let jsonTable table = let creatingTable = "Creating {Table} table..."
$"{Query.Definition.ensureTable table}; {Query.Definition.ensureKey table}"
let tasks = // Theme tables
seq { if needsTable Table.Theme then
// Theme tables log.LogInformation(creatingTable, Table.Theme)
if needsTable Table.Theme then jsonTable Table.Theme do! conn.ensureTable Table.Theme
if needsTable Table.ThemeAsset then
if needsTable Table.ThemeAsset then
log.LogInformation(creatingTable, Table.ThemeAsset)
do! conn.customNonQuery
$"CREATE TABLE {Table.ThemeAsset} ( $"CREATE TABLE {Table.ThemeAsset} (
theme_id TEXT NOT NULL, theme_id TEXT NOT NULL,
path TEXT NOT NULL, path TEXT NOT NULL,
updated_on TEXT NOT NULL, updated_on TEXT NOT NULL,
data BLOB NOT NULL, data BLOB NOT NULL,
PRIMARY KEY (theme_id, path))" PRIMARY KEY (theme_id, path))" []
// Web log table // Web log table
if needsTable Table.WebLog then jsonTable Table.WebLog if needsTable Table.WebLog then
log.LogInformation(creatingTable, Table.WebLog)
do! conn.ensureTable Table.WebLog
// Category table // Category table
if needsTable Table.Category then if needsTable Table.Category then
$"""{jsonTable Table.Category}; log.LogInformation(creatingTable, Table.Category)
{Query.Definition.ensureIndexOn Table.Category "web_log" [ nameof Category.Empty.WebLogId ]}""" do! conn.ensureTable Table.Category
do! conn.ensureFieldIndex Table.Category "web_log" [ nameof Category.Empty.WebLogId ]
// Web log user table // Web log user table
if needsTable Table.WebLogUser then if needsTable Table.WebLogUser then
$"""{jsonTable Table.WebLogUser}; log.LogInformation(creatingTable, Table.WebLogUser)
{Query.Definition.ensureIndexOn do! conn.ensureTable Table.WebLogUser
Table.WebLogUser do! conn.ensureFieldIndex
"email" Table.WebLogUser "email" [ nameof WebLogUser.Empty.WebLogId; nameof WebLogUser.Empty.Email ]
[ nameof WebLogUser.Empty.WebLogId; nameof WebLogUser.Empty.Email ]}"""
// Page tables // Page tables
if needsTable Table.Page then if needsTable Table.Page then
$"""{jsonTable Table.Page}; log.LogInformation(creatingTable, Table.Page)
{Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ]}; do! conn.ensureTable Table.Page
{Query.Definition.ensureIndexOn do! conn.ensureFieldIndex Table.Page "author" [ nameof Page.Empty.AuthorId ]
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]}""" do! conn.ensureFieldIndex Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]
if needsTable Table.PageRevision then
if needsTable Table.PageRevision then
log.LogInformation(creatingTable, Table.PageRevision)
do! conn.customNonQuery
$"CREATE TABLE {Table.PageRevision} ( $"CREATE TABLE {Table.PageRevision} (
page_id TEXT NOT NULL, page_id TEXT NOT NULL,
as_of TEXT NOT NULL, as_of TEXT NOT NULL,
revision_text TEXT NOT NULL, revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))" PRIMARY KEY (page_id, as_of))" []
// Post tables // Post tables
if needsTable Table.Post then if needsTable Table.Post then
$"""{jsonTable Table.Post}; log.LogInformation(creatingTable, Table.Post)
{Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ]}; do! conn.ensureTable Table.Post
{Query.Definition.ensureIndexOn do! conn.ensureFieldIndex Table.Post "author" [ nameof Post.Empty.AuthorId ]
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]}; do! conn.ensureFieldIndex Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]
{Query.Definition.ensureIndexOn do! conn.ensureFieldIndex
Table.Post Table.Post
"status" "status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]}""" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]
// TODO: index categories by post? // TODO: index categories by post?
if needsTable Table.PostRevision then
if needsTable Table.PostRevision then
log.LogInformation(creatingTable, Table.PostRevision)
do! conn.customNonQuery
$"CREATE TABLE {Table.PostRevision} ( $"CREATE TABLE {Table.PostRevision} (
post_id TEXT NOT NULL, post_id TEXT NOT NULL,
as_of TEXT NOT NULL, as_of TEXT NOT NULL,
revision_text TEXT NOT NULL, revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))" 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.PostComment then
if needsTable Table.TagMap then log.LogInformation(creatingTable, Table.PostComment)
$"""{jsonTable Table.TagMap}; do! conn.ensureTable Table.PostComment
{Query.Definition.ensureIndexOn do! conn.ensureFieldIndex Table.PostComment "post" [ nameof Comment.Empty.PostId ]
Table.TagMap "url" [ nameof TagMap.Empty.WebLogId; nameof TagMap.Empty.UrlValue ]}"""
// Uploaded file table // Tag map table
if needsTable Table.Upload then 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} ( $"CREATE TABLE {Table.Upload} (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL, web_log_id TEXT NOT NULL,
path TEXT NOT NULL, path TEXT NOT NULL,
updated_on TEXT NOT NULL, updated_on TEXT NOT NULL,
data BLOB NOT NULL); data BLOB NOT NULL);
CREATE INDEX idx_{Table.Upload}_path ON {Table.Upload} (web_log_id, path)" CREATE INDEX idx_{Table.Upload}_path ON {Table.Upload} (web_log_id, path)" []
// Database version table // Database version table
if needsTable Table.DbVersion then if needsTable Table.DbVersion then
log.LogInformation(creatingTable, Table.DbVersion)
do! conn.customNonQuery
$"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY); $"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY);
INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')" 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 [])
let! _ = Task.WhenAll tasks
()
} }
/// Set the database version to the specified version /// Set the database version to the specified version
@@ -444,6 +452,17 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
do! setDbVersion "v2.2" do! setDbVersion "v2.2"
} }
/// Migrate from v2.2 to v3
let migrateV2point2ToV3 () = backgroundTask {
Utils.Migration.logStep log "v2.2 to v3" "Adding auto-OpenGraph flag to all web logs"
do! Patch.byFields Table.WebLog Any [ Field.Exists (nameof WebLog.Empty.Id) ] {| AutoOpenGraph = true |}
Utils.Migration.logStep log "v2.2 to v3" "Converting auto-htmx flag to choices"
do! Patch.byFields Table.WebLog Any [ Field.Equal (nameof WebLog.Empty.AutoHtmx) true ] {| AutoHtmx = "Yes" |}
do! Patch.byFields Table.WebLog Any [ Field.Equal (nameof WebLog.Empty.AutoHtmx) false ] {| AutoHtmx = "No" |}
Utils.Migration.logStep log "v2.2 to v3" "Setting database version to v3"
do! setDbVersion "v3"
}
/// Migrate data among versions (up only) /// Migrate data among versions (up only)
let migrate version = backgroundTask { let migrate version = backgroundTask {
let mutable v = defaultArg version "" let mutable v = defaultArg version ""
@@ -468,6 +487,10 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
do! migrateV2point1point1ToV2point2 () do! migrateV2point1point1ToV2point2 ()
v <- "v2.2" v <- "v2.2"
if v = "v2.2" then
do! migrateV2point2ToV3 ()
v <- "v3"
if v <> Utils.Migration.currentDbVersion then if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}" log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
do! setDbVersion Utils.Migration.currentDbVersion do! setDbVersion Utils.Migration.currentDbVersion
+44 -13
View File
@@ -1,11 +1,16 @@
/// Utility functions for manipulating data /// <summary>Utility functions for manipulating data</summary>
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module internal MyWebLog.Data.Utils module internal MyWebLog.Data.Utils
open MyWebLog open MyWebLog
open MyWebLog.ViewModels 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 { let rec orderByHierarchy (cats: Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.Slug 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) 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 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)) 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 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 = let diffRevisions (oldRevs: Revision list) newRevs =
diffLists oldRevs newRevs (fun rev -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text}") diffLists oldRevs newRevs (fun rev -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text}")
open MyWebLog.Converters open MyWebLog.Converters
open Newtonsoft.Json 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) = let serialize<'T> ser (item: 'T) =
JsonConvert.SerializeObject(item, Json.settings ser) 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 = let deserialize<'T> (ser: JsonSerializer) value =
JsonConvert.DeserializeObject<'T>(value, Json.settings ser) JsonConvert.DeserializeObject<'T>(value, Json.settings ser)
open BitBadger.Documents 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 = let createDocumentSerializer ser =
{ new IDocumentSerializer with { new IDocumentSerializer with
member _.Serialize<'T>(it: 'T) : string = serialize ser it member _.Serialize<'T>(it: 'T) : string = serialize ser it
member _.Deserialize<'T>(it: string) : 'T = deserialize ser it member _.Deserialize<'T>(it: string) : 'T = deserialize ser it
} }
/// Data migration utilities /// <summary>Data migration utilities</summary>
module Migration = module Migration =
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
/// The current database version /// <summary>The current database version</summary>
let currentDbVersion = "v2.2" let currentDbVersion = "v3"
/// 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 = let logStep<'T> (log: ILogger<'T>) migration message =
log.LogInformation $"Migrating %s{migration}: %s{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 = let backupAndRestoreRequired log oldVersion newVersion webLogs =
logStep log $"%s{oldVersion} to %s{newVersion}" "Requires Using Action" logStep log $"%s{oldVersion} to %s{newVersion}" "Requires Using Action"
@@ -77,4 +109,3 @@ module Migration =
log.LogCritical "myWebLog will now exit" log.LogCritical "myWebLog will now exit"
exit 1 |> ignore exit 1 |> ignore
+140 -112
View File
@@ -3,29 +3,29 @@
open MyWebLog open MyWebLog
open NodaTime 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>] [<CLIMutable; NoComparison; NoEquality>]
type Category = { type Category = {
/// The ID of the category /// <summary>The ID of the category</summary>
Id: CategoryId 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 WebLogId: WebLogId
/// The displayed name /// <summary>The displayed name</summary>
Name: string Name: string
/// The slug (used in category URLs) /// <summary>The slug (used in category URLs)</summary>
Slug: string Slug: string
/// A longer description of the category /// <summary>A longer description of the category</summary>
Description: string option 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 ParentId: CategoryId option
} with } with
/// An empty category /// <summary>An empty category</summary>
static member Empty = static member Empty =
{ Id = CategoryId.Empty { Id = CategoryId.Empty
WebLogId = WebLogId.Empty WebLogId = WebLogId.Empty
@@ -35,38 +35,38 @@ type Category = {
ParentId = None } ParentId = None }
/// A comment on a post /// <summary>A comment on a post</summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type Comment = { type Comment = {
/// The ID of the comment /// <summary>The ID of the comment</summary>
Id: CommentId 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 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 InReplyToId: CommentId option
/// The name of the commentor /// <summary>The name of the commentor</summary>
Name: string Name: string
/// The e-mail address of the commentor /// <summary>The e-mail address of the commentor</summary>
Email: string Email: string
/// The URL of the commentor's personal website /// <summary>The URL of the commentor's personal website</summary>
Url: string option Url: string option
/// The status of the comment /// <summary>The status of the comment</summary>
Status: CommentStatus Status: CommentStatus
/// When the comment was posted /// <summary>When the comment was posted</summary>
PostedOn: Instant PostedOn: Instant
/// The text of the comment /// <summary>The text of the comment</summary>
Text: string Text: string
} with } with
/// An empty comment /// <summary>An empty comment</summary>
static member Empty = static member Empty =
{ Id = CommentId.Empty { Id = CommentId.Empty
PostId = PostId.Empty PostId = PostId.Empty
@@ -79,50 +79,53 @@ type Comment = {
Text = "" } Text = "" }
/// A page (text not associated with a date/time) /// <summary>A page (text not associated with a date/time)</summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type Page = { type Page = {
/// The ID of this page /// <summary>The ID of this page</summary>
Id: PageId 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 WebLogId: WebLogId
/// The ID of the author of this page /// <summary>The ID of the author of this page</summary>
AuthorId: WebLogUserId AuthorId: WebLogUserId
/// The title of the page /// <summary>The title of the page</summary>
Title: string Title: string
/// The link at which this page is displayed /// <summary>The link at which this page is displayed</summary>
Permalink: Permalink Permalink: Permalink
/// When this page was published /// <summary>When this page was published</summary>
PublishedOn: Instant PublishedOn: Instant
/// When this page was last updated /// <summary>When this page was last updated</summary>
UpdatedOn: Instant 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 IsInPageList: bool
/// The template to use when rendering this page /// <summary>The template to use when rendering this page</summary>
Template: string option Template: string option
/// The current text of the page /// <summary>The current text of the page</summary>
Text: string Text: string
/// Metadata for this page /// <summary>Metadata for this page</summary>
Metadata: MetaItem list 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 PriorPermalinks: Permalink list
/// Revisions of this page /// <summary>Revisions of this page</summary>
Revisions: Revision list Revisions: Revision list
/// <summary>Common OpenGraph information for this post</summary>
OpenGraph: OpenGraphProperties option
} with } with
/// An empty page /// <summary>An empty page</summary>
static member Empty = static member Empty =
{ Id = PageId.Empty { Id = PageId.Empty
WebLogId = WebLogId.Empty WebLogId = WebLogId.Empty
@@ -136,62 +139,66 @@ type Page = {
Text = "" Text = ""
Metadata = [] Metadata = []
PriorPermalinks = [] PriorPermalinks = []
Revisions = [] } Revisions = []
OpenGraph = None }
/// A web log post /// <summary>A web log post</summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type Post = { type Post = {
/// The ID of this post /// <summary>The ID of this post</summary>
Id: PostId 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 WebLogId: WebLogId
/// The ID of the author of this post /// <summary>The ID of the author of this post</summary>
AuthorId: WebLogUserId AuthorId: WebLogUserId
/// The status /// <summary>The status</summary>
Status: PostStatus Status: PostStatus
/// The title /// <summary>The title</summary>
Title: string Title: string
/// The link at which the post resides /// <summary>The link at which the post resides</summary>
Permalink: Permalink 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 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 UpdatedOn: Instant
/// The template to use in displaying the post /// <summary>The template to use in displaying the post</summary>
Template: string option 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 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 CategoryIds: CategoryId list
/// The tags for the post /// <summary>The tags for the post</summary>
Tags: string list Tags: string list
/// Podcast episode information for this post /// <summary>Podcast episode information for this post</summary>
Episode: Episode option Episode: Episode option
/// Metadata for the post /// <summary>Metadata for the post</summary>
Metadata: MetaItem list 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 PriorPermalinks: Permalink list
/// The revisions for this post /// <summary>The revisions for this post</summary>
Revisions: Revision list Revisions: Revision list
/// <summary>OpenGraph information for this post</summary>
OpenGraph: OpenGraphProperties option
} with } with
/// An empty post /// <summary>An empty post</summary>
static member Empty = static member Empty =
{ Id = PostId.Empty { Id = PostId.Empty
WebLogId = WebLogId.Empty WebLogId = WebLogId.Empty
@@ -208,139 +215,145 @@ type Post = {
Episode = None Episode = None
Metadata = [] Metadata = []
PriorPermalinks = [] PriorPermalinks = []
Revisions = [] } Revisions = []
OpenGraph = None }
/// <summary>
/// A mapping between a tag and its URL value, used to translate restricted characters (ex. "#1" -> "number-1") /// A mapping between a tag and its URL value, used to translate restricted characters (ex. "#1" -> "number-1")
/// </summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type TagMap = { type TagMap = {
/// The ID of this tag mapping /// <summary>The ID of this tag mapping</summary>
Id: TagMapId 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 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 Tag: string
/// The value by which the tag should be linked /// <summary>The value by which the tag should be linked</summary>
UrlValue: string UrlValue: string
} with } with
/// An empty tag mapping /// <summary>An empty tag mapping</summary>
static member Empty = static member Empty =
{ Id = TagMapId.Empty; WebLogId = WebLogId.Empty; Tag = ""; UrlValue = "" } { Id = TagMapId.Empty; WebLogId = WebLogId.Empty; Tag = ""; UrlValue = "" }
/// A theme /// <summary>A theme</summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type Theme = { type Theme = {
/// The ID / path of the theme /// <summary>The ID / path of the theme</summary>
Id: ThemeId Id: ThemeId
/// A long name of the theme /// <summary>A long name of the theme</summary>
Name: string Name: string
/// The version of the theme /// <summary>The version of the theme</summary>
Version: string Version: string
/// The templates for this theme /// <summary>The templates for this theme</summary>
Templates: ThemeTemplate list Templates: ThemeTemplate list
} with } with
/// An empty theme /// <summary>An empty theme</summary>
static member Empty = static member Empty =
{ Id = ThemeId.Empty; Name = ""; Version = ""; Templates = [] } { 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>] [<CLIMutable; NoComparison; NoEquality>]
type ThemeAsset = { 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 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 UpdatedOn: Instant
/// The data for the asset /// <summary>The data for the asset</summary>
Data: byte array Data: byte array
} with } with
/// An empty theme asset /// <summary>An empty theme asset</summary>
static member Empty = static member Empty =
{ Id = ThemeAssetId.Empty; UpdatedOn = Noda.epoch; Data = [||] } { Id = ThemeAssetId.Empty; UpdatedOn = Noda.epoch; Data = [||] }
/// An uploaded file /// <summary>An uploaded file</summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type Upload = { type Upload = {
/// The ID of the upload /// <summary>The ID of the upload</summary>
Id: UploadId 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 WebLogId: WebLogId
/// The link at which this upload is served /// <summary>The link at which this upload is served</summary>
Path: Permalink Path: Permalink
/// The updated date/time for this upload /// <summary>The updated date/time for this upload</summary>
UpdatedOn: Instant UpdatedOn: Instant
/// The data for the upload /// <summary>The data for the upload</summary>
Data: byte array Data: byte array
} with } with
/// An empty upload /// <summary>An empty upload</summary>
static member Empty = static member Empty =
{ Id = UploadId.Empty; WebLogId = WebLogId.Empty; Path = Permalink.Empty; UpdatedOn = Noda.epoch; Data = [||] } { Id = UploadId.Empty; WebLogId = WebLogId.Empty; Path = Permalink.Empty; UpdatedOn = Noda.epoch; Data = [||] }
open Newtonsoft.Json open Newtonsoft.Json
/// A web log /// <summary>A web log</summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type WebLog = { type WebLog = {
/// The ID of the web log /// <summary>The ID of the web log</summary>
Id: WebLogId Id: WebLogId
/// The name of the web log /// <summary>The name of the web log</summary>
Name: string Name: string
/// The slug of the web log /// <summary>The slug of the web log</summary>
Slug: string Slug: string
/// A subtitle for the web log /// <summary>A subtitle for the web log</summary>
Subtitle: string option Subtitle: string option
/// The default page ("posts" or a page Id) /// <summary>The default page ("posts" or a page Id)</summary>
DefaultPage: string 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 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 ThemeId: ThemeId
/// The URL base /// <summary>The URL base</summary>
UrlBase: string 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 TimeZone: string
/// The RSS options for this web log /// <summary>The RSS options for this web log</summary>
Rss: RssOptions Rss: RssOptions
/// Whether to automatically load htmx /// <summary>Whether to automatically load htmx</summary>
AutoHtmx: bool AutoHtmx: AutoHtmxType
/// Where uploads are placed /// <summary>Where uploads are placed</summary>
Uploads: UploadDestination Uploads: UploadDestination
/// Redirect rules for this weblog /// <summary>Redirect rules for this weblog</summary>
RedirectRules: RedirectRule list RedirectRules: RedirectRule list
/// <summary>Whether to automatically apply OpenGraph properties to all pages / posts</summary>
AutoOpenGraph: bool
} with } with
/// An empty web log /// <summary>An empty web log</summary>
static member Empty = static member Empty =
{ Id = WebLogId.Empty { Id = WebLogId.Empty
Name = "" Name = ""
@@ -352,11 +365,14 @@ type WebLog = {
UrlBase = "" UrlBase = ""
TimeZone = "" TimeZone = ""
Rss = RssOptions.Empty Rss = RssOptions.Empty
AutoHtmx = false AutoHtmx = NoAutoHtmx
Uploads = Database Uploads = Database
RedirectRules = [] } RedirectRules = []
AutoOpenGraph = true }
/// <summary>
/// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain) /// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain)
/// </summary>
[<JsonIgnore>] [<JsonIgnore>]
member this.ExtraPath = member this.ExtraPath =
let pathParts = this.UrlBase.Split "://" let pathParts = this.UrlBase.Split "://"
@@ -366,15 +382,27 @@ type WebLog = {
let path = pathParts[1].Split "/" let path = pathParts[1].Split "/"
if path.Length > 1 then $"""/{path |> Array.skip 1 |> String.concat "/"}""" else "" 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) = member this.AbsoluteUrl(permalink: Permalink) =
$"{this.UrlBase}/{permalink}" $"{this.UrlBase}/{permalink}"
/// Generate a relative URL for the given link /// <summary>Convert a string URL to an absolute URL for this web log if required</summary>
/// <param name="url">The URL which may be translated to an absolute one</param>
/// <returns>The given URL if it was already absolute, or a corresponding absolute URL if not</returns>
member this.UrlToAbsolute(url: string) =
if url.StartsWith "http" then url else this.AbsoluteUrl(Permalink url)
/// <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) = member this.RelativeUrl(permalink: Permalink) =
$"{this.ExtraPath}/{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) = member this.LocalTime(date: Instant) =
DateTimeZoneProviders.Tzdb.GetZoneOrNull this.TimeZone DateTimeZoneProviders.Tzdb.GetZoneOrNull this.TimeZone
|> Option.ofObj |> Option.ofObj
@@ -382,44 +410,44 @@ type WebLog = {
|> Option.defaultValue (date.ToDateTimeUtc()) |> Option.defaultValue (date.ToDateTimeUtc())
/// A user of the web log /// <summary>A user of the web log</summary>
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type WebLogUser = { type WebLogUser = {
/// The ID of the user /// <summary>The ID of the user</summary>
Id: WebLogUserId 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 WebLogId: WebLogId
/// The user name (e-mail address) /// <summary>The user name (e-mail address)</summary>
Email: string Email: string
/// The user's first name /// <summary>The user's first name</summary>
FirstName: string FirstName: string
/// The user's last name /// <summary>The user's last name</summary>
LastName: string LastName: string
/// The user's preferred name /// <summary>The user's preferred name</summary>
PreferredName: string PreferredName: string
/// The hash of the user's password /// <summary>The hash of the user's password</summary>
PasswordHash: string PasswordHash: string
/// The URL of the user's personal site /// <summary>The URL of the user's personal site</summary>
Url: string option Url: string option
/// The user's access level /// <summary>The user's access level</summary>
AccessLevel: AccessLevel AccessLevel: AccessLevel
/// When the user was created /// <summary>When the user was created</summary>
CreatedOn: Instant CreatedOn: Instant
/// When the user last logged on /// <summary>When the user last logged on</summary>
LastSeenOn: Instant option LastSeenOn: Instant option
} with } with
/// An empty web log user /// <summary>An empty web log user</summary>
static member Empty = static member Empty =
{ Id = WebLogUserId.Empty { Id = WebLogUserId.Empty
WebLogId = WebLogId.Empty WebLogId = WebLogId.Empty
@@ -433,7 +461,7 @@ type WebLogUser = {
CreatedOn = Noda.epoch CreatedOn = Noda.epoch
LastSeenOn = None } LastSeenOn = None }
/// Get the user's displayed name /// <summary>Get the user's displayed name</summary>
[<JsonIgnore>] [<JsonIgnore>]
member this.DisplayName = member this.DisplayName =
(seq { (match this.PreferredName with "" -> this.FirstName | n -> n); " "; this.LastName } (seq { (match this.PreferredName with "" -> this.FirstName | n -> n); " "; this.LastName }
+5 -5
View File
@@ -7,11 +7,11 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Markdig" Version="0.37.0" /> <PackageReference Include="FSharp.Core" />
<PackageReference Include="Markdown.ColorCode" Version="2.2.2" /> <PackageReference Include="Markdig" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.3" /> <PackageReference Include="Markdown.ColorCode" />
<PackageReference Include="NodaTime" Version="3.1.11" /> <PackageReference Include="Newtonsoft.Json" />
<PackageReference Update="FSharp.Core" Version="8.0.300" /> <PackageReference Include="NodaTime" />
</ItemGroup> </ItemGroup>
</Project> </Project>
File diff suppressed because it is too large Load Diff
File diff suppressed because it is too large Load Diff
+38 -2
View File
@@ -6,6 +6,24 @@ open MyWebLog
open MyWebLog.Converters.Json open MyWebLog.Converters.Json
open Newtonsoft.Json open Newtonsoft.Json
/// Unit tests for the AutoHtmxTypeConverter type
let autoHtmxTypeConverterTests = testList "AutoHtmxTypeConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(AutoHtmxTypeConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(AutoHtmax, opts)
Expect.equal after "\"Max\"" "Auto htmx type serialized incorrectly"
}
test "succeeds when deserializing a string" {
let after = JsonConvert.DeserializeObject<AutoHtmxType>("\"Yes\"", opts)
Expect.equal after AutoHtmx "Auto htmx type deserialized incorrectly"
}
test "succeeds when deserializing a boolean value" {
let after = JsonConvert.DeserializeObject<AutoHtmxType>("false", opts)
Expect.equal after NoAutoHtmx "Auto htmx type deserialized incorrectly"
}
]
/// Unit tests for the CategoryIdConverter type /// Unit tests for the CategoryIdConverter type
let categoryIdConverterTests = testList "CategoryIdConverter" [ let categoryIdConverterTests = testList "CategoryIdConverter" [
let opts = JsonSerializerSettings() let opts = JsonSerializerSettings()
@@ -16,7 +34,7 @@ let categoryIdConverterTests = testList "CategoryIdConverter" [
} }
test "succeeds when deserializing" { test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<CategoryId>("\"test-cat-id\"", opts) let after = JsonConvert.DeserializeObject<CategoryId>("\"test-cat-id\"", opts)
Expect.equal after (CategoryId "test-cat-id") "Category ID not serialized incorrectly" Expect.equal after (CategoryId "test-cat-id") "Category ID deserialized incorrectly"
} }
] ]
@@ -90,7 +108,7 @@ let explicitRatingConverterTests = testList "ExplicitRatingConverter" [
} }
] ]
/// Unit tests for the MarkupText type /// Unit tests for the MarkupTextConverter type
let markupTextConverterTests = testList "MarkupTextConverter" [ let markupTextConverterTests = testList "MarkupTextConverter" [
let opts = JsonSerializerSettings() let opts = JsonSerializerSettings()
opts.Converters.Add(MarkupTextConverter()) opts.Converters.Add(MarkupTextConverter())
@@ -104,6 +122,20 @@ let markupTextConverterTests = testList "MarkupTextConverter" [
} }
] ]
/// Unit tests for the OpenGraphTypeConverter type
let openGraphTypeConverterTests = testList "OpenGraphTypeConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(OpenGraphTypeConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(VideoTvShow, opts)
Expect.equal after "\"video.tv_show\"" "OpenGraph type serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<OpenGraphType>("\"book\"", opts)
Expect.equal after Book "OpenGraph type deserialized incorrectly"
}
]
/// Unit tests for the PermalinkConverter type /// Unit tests for the PermalinkConverter type
let permalinkConverterTests = testList "PermalinkConverter" [ let permalinkConverterTests = testList "PermalinkConverter" [
let opts = JsonSerializerSettings() let opts = JsonSerializerSettings()
@@ -250,6 +282,7 @@ open NodaTime.Serialization.JsonNet
let configureTests = test "Json.configure succeeds" { let configureTests = test "Json.configure succeeds" {
let has typ (converter: JsonConverter) = converter.GetType() = typ let has typ (converter: JsonConverter) = converter.GetType() = typ
let ser = configure (JsonSerializer.Create()) let ser = configure (JsonSerializer.Create())
Expect.hasCountOf ser.Converters 1u (has typeof<AutoHtmxTypeConverter>) "Auto htmx type converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<CategoryIdConverter>) "Category ID converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<CategoryIdConverter>) "Category ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<CommentIdConverter>) "Comment ID converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<CommentIdConverter>) "Comment ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<CommentStatusConverter>) "Comment status converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<CommentStatusConverter>) "Comment status converter not found"
@@ -257,6 +290,7 @@ let configureTests = test "Json.configure succeeds" {
Expect.hasCountOf ser.Converters 1u (has typeof<CustomFeedSourceConverter>) "Custom feed source converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<CustomFeedSourceConverter>) "Custom feed source converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<ExplicitRatingConverter>) "Explicit rating converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<ExplicitRatingConverter>) "Explicit rating converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<MarkupTextConverter>) "Markup text converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<MarkupTextConverter>) "Markup text converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<OpenGraphTypeConverter>) "OpenGraph type converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PermalinkConverter>) "Permalink converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<PermalinkConverter>) "Permalink converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PageIdConverter>) "Page ID converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<PageIdConverter>) "Page ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PodcastMediumConverter>) "Podcast medium converter not found" Expect.hasCountOf ser.Converters 1u (has typeof<PodcastMediumConverter>) "Podcast medium converter not found"
@@ -275,6 +309,7 @@ let configureTests = test "Json.configure succeeds" {
/// All tests for the Data.Converters file /// All tests for the Data.Converters file
let all = testList "Converters" [ let all = testList "Converters" [
autoHtmxTypeConverterTests
categoryIdConverterTests categoryIdConverterTests
commentIdConverterTests commentIdConverterTests
commentStatusConverterTests commentStatusConverterTests
@@ -282,6 +317,7 @@ let all = testList "Converters" [
customFeedSourceConverterTests customFeedSourceConverterTests
explicitRatingConverterTests explicitRatingConverterTests
markupTextConverterTests markupTextConverterTests
openGraphTypeConverterTests
permalinkConverterTests permalinkConverterTests
pageIdConverterTests pageIdConverterTests
podcastMediumConverterTests podcastMediumConverterTests
+3 -1
View File
@@ -35,7 +35,8 @@ let ``Add succeeds`` (data: IData) = task {
Text = "<h1>A new page</h1>" Text = "<h1>A new page</h1>"
Metadata = [ { Name = "Meta Item"; Value = "Meta Value" } ] Metadata = [ { Name = "Meta Item"; Value = "Meta Value" } ]
PriorPermalinks = [ Permalink "2024/the-new-page.htm" ] PriorPermalinks = [ Permalink "2024/the-new-page.htm" ]
Revisions = [ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<h1>A new page</h1>" } ] } Revisions = [ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<h1>A new page</h1>" } ]
OpenGraph = Some { OpenGraphProperties.Empty with Type = Book } }
do! data.Page.Add page do! data.Page.Add page
let! stored = data.Page.FindFullById (PageId "added-page") (WebLogId "test") let! stored = data.Page.FindFullById (PageId "added-page") (WebLogId "test")
Expect.isSome stored "The page should have been added" Expect.isSome stored "The page should have been added"
@@ -53,6 +54,7 @@ let ``Add succeeds`` (data: IData) = task {
Expect.equal pg.Metadata page.Metadata "Metadata not saved properly" Expect.equal pg.Metadata page.Metadata "Metadata not saved properly"
Expect.equal pg.PriorPermalinks page.PriorPermalinks "Prior permalinks not saved properly" Expect.equal pg.PriorPermalinks page.PriorPermalinks "Prior permalinks not saved properly"
Expect.equal pg.Revisions page.Revisions "Revisions not saved properly" Expect.equal pg.Revisions page.Revisions "Revisions not saved properly"
Expect.equal pg.OpenGraph page.OpenGraph "OpenGraph properties not saved properly"
} }
let ``All succeeds`` (data: IData) = task { let ``All succeeds`` (data: IData) = task {
+3 -1
View File
@@ -66,7 +66,8 @@ let ``Add succeeds`` (data: IData) = task {
Episode = Some { Episode.Empty with Media = "test-ep.mp3" } Episode = Some { Episode.Empty with Media = "test-ep.mp3" }
Metadata = [ { Name = "Meta"; Value = "Data" } ] Metadata = [ { Name = "Meta"; Value = "Data" } ]
PriorPermalinks = [ Permalink "2020/test-post-a.html" ] PriorPermalinks = [ Permalink "2020/test-post-a.html" ]
Revisions = [ { AsOf = Noda.epoch + Duration.FromMinutes 1L; Text = Html "<p>Test text here" } ] } Revisions = [ { AsOf = Noda.epoch + Duration.FromMinutes 1L; Text = Html "<p>Test text here" } ]
OpenGraph = Some { OpenGraphProperties.Empty with Type = VideoMovie } }
do! data.Post.Add post do! data.Post.Add post
let! stored = data.Post.FindFullById post.Id post.WebLogId let! stored = data.Post.FindFullById post.Id post.WebLogId
Expect.isSome stored "The added post should have been retrieved" Expect.isSome stored "The added post should have been retrieved"
@@ -87,6 +88,7 @@ let ``Add succeeds`` (data: IData) = task {
Expect.equal it.Metadata post.Metadata "Metadata items not saved properly" Expect.equal it.Metadata post.Metadata "Metadata items not saved properly"
Expect.equal it.PriorPermalinks post.PriorPermalinks "Prior permalinks not saved properly" Expect.equal it.PriorPermalinks post.PriorPermalinks "Prior permalinks not saved properly"
Expect.equal it.Revisions post.Revisions "Revisions not saved properly" Expect.equal it.Revisions post.Revisions "Revisions not saved properly"
Expect.equal it.OpenGraph post.OpenGraph "OpenGraph properties not saved correctly"
} }
let ``CountByStatus succeeds`` (data: IData) = task { let ``CountByStatus succeeds`` (data: IData) = task {
+8 -6
View File
@@ -30,9 +30,10 @@ let ``Add succeeds`` (data: IData) = task {
IsTagEnabled = false IsTagEnabled = false
Copyright = Some "go for it" Copyright = Some "go for it"
CustomFeeds = [] } CustomFeeds = [] }
AutoHtmx = true AutoHtmx = AutoHtmax
Uploads = Disk Uploads = Disk
RedirectRules = [ { From = "/here"; To = "/there"; IsRegex = false } ] } RedirectRules = [ { From = "/here"; To = "/there"; IsRegex = false } ]
AutoOpenGraph = false }
let! webLog = data.WebLog.FindById (WebLogId "new-weblog") let! webLog = data.WebLog.FindById (WebLogId "new-weblog")
Expect.isSome webLog "The web log should have been returned" Expect.isSome webLog "The web log should have been returned"
let it = webLog.Value let it = webLog.Value
@@ -45,9 +46,10 @@ let ``Add succeeds`` (data: IData) = task {
Expect.equal it.ThemeId (ThemeId "default") "Theme ID is incorrect" Expect.equal it.ThemeId (ThemeId "default") "Theme ID is incorrect"
Expect.equal it.UrlBase "https://example.com/new" "URL base is incorrect" Expect.equal it.UrlBase "https://example.com/new" "URL base is incorrect"
Expect.equal it.TimeZone "America/Los_Angeles" "Time zone is incorrect" Expect.equal it.TimeZone "America/Los_Angeles" "Time zone is incorrect"
Expect.isTrue it.AutoHtmx "Auto htmx flag is incorrect" Expect.equal it.AutoHtmx AutoHtmax "Auto htmx type is incorrect"
Expect.equal it.Uploads Disk "Upload destination is incorrect" Expect.equal it.Uploads Disk "Upload destination is incorrect"
Expect.equal it.RedirectRules [ { From = "/here"; To = "/there"; IsRegex = false } ] "Redirect rules are incorrect" Expect.equal it.RedirectRules [ { From = "/here"; To = "/there"; IsRegex = false } ] "Redirect rules are incorrect"
Expect.isFalse it.AutoOpenGraph "Auto OpenGraph flag is incorrect"
let rss = it.Rss let rss = it.Rss
Expect.isTrue rss.IsFeedEnabled "Is feed enabled flag is incorrect" Expect.isTrue rss.IsFeedEnabled "Is feed enabled flag is incorrect"
Expect.equal rss.FeedName "my-feed.xml" "Feed name is incorrect" Expect.equal rss.FeedName "my-feed.xml" "Feed name is incorrect"
@@ -89,7 +91,7 @@ let ``FindById succeeds when a web log is found`` (data: IData) = task {
Expect.equal it.ThemeId (ThemeId "default") "Theme ID is incorrect" Expect.equal it.ThemeId (ThemeId "default") "Theme ID is incorrect"
Expect.equal it.UrlBase "http://localhost:8081" "URL base is incorrect" Expect.equal it.UrlBase "http://localhost:8081" "URL base is incorrect"
Expect.equal it.TimeZone "America/Denver" "Time zone is incorrect" Expect.equal it.TimeZone "America/Denver" "Time zone is incorrect"
Expect.isTrue it.AutoHtmx "Auto htmx flag is incorrect" Expect.equal it.AutoHtmx AutoHtmx "Auto htmx type is incorrect"
Expect.equal it.Uploads Database "Upload destination is incorrect" Expect.equal it.Uploads Database "Upload destination is incorrect"
Expect.isEmpty it.RedirectRules "Redirect rules are incorrect" Expect.isEmpty it.RedirectRules "Redirect rules are incorrect"
let rss = it.Rss let rss = it.Rss
@@ -163,10 +165,10 @@ let ``UpdateRssOptions succeeds when the web log does not exist`` (data: IData)
let ``UpdateSettings succeeds when the web log exists`` (data: IData) = task { let ``UpdateSettings succeeds when the web log exists`` (data: IData) = task {
let! webLog = data.WebLog.FindById rootId let! webLog = data.WebLog.FindById rootId
Expect.isSome webLog "The root web log should have been returned" Expect.isSome webLog "The root web log should have been returned"
do! data.WebLog.UpdateSettings { webLog.Value with AutoHtmx = false; Subtitle = None } do! data.WebLog.UpdateSettings { webLog.Value with AutoHtmx = NoAutoHtmx; Subtitle = None }
let! updated = data.WebLog.FindById rootId let! updated = data.WebLog.FindById rootId
Expect.isSome updated "The updated web log should have been returned" Expect.isSome updated "The updated web log should have been returned"
Expect.isFalse updated.Value.AutoHtmx "Auto htmx flag not updated correctly" Expect.equal updated.Value.AutoHtmx NoAutoHtmx "Auto htmx type not updated correctly"
Expect.isNone updated.Value.Subtitle "Subtitle not updated correctly" Expect.isNone updated.Value.Subtitle "Subtitle not updated correctly"
} }
@@ -34,6 +34,18 @@ let webLogTests = testList "WebLog" [
"https://my.site/blog/page.html" "https://my.site/blog/page.html"
"Absolute URL is incorrect" "Absolute URL is incorrect"
} }
testList "UrlToAbsolute" [
test "succeeds for relative URL" {
Expect.equal
({ WebLog.Empty with UrlBase = "https://my.site" }.UrlToAbsolute "blog/page.html")
"https://my.site/blog/page.html"
"Absolute URL is incorrect"
}
test "succeeds for absolute URL" {
Expect.equal
(WebLog.Empty.UrlToAbsolute "https://test.units") "https://test.units" "Absolute URL is incorrect"
}
]
testList "RelativeUrl" [ testList "RelativeUrl" [
test "succeeds for domain root URL" { test "succeeds for domain root URL" {
Expect.equal Expect.equal
+443 -10
View File
@@ -31,16 +31,16 @@ let nodaTests = testList "Noda" [
let accessLevelTests = testList "AccessLevel" [ let accessLevelTests = testList "AccessLevel" [
testList "Parse" [ testList "Parse" [
test "succeeds for \"Author\"" { test "succeeds for \"Author\"" {
Expect.equal Author (AccessLevel.Parse "Author") "Author not parsed correctly" Expect.equal (AccessLevel.Parse "Author") Author "Author not parsed correctly"
} }
test "succeeds for \"Editor\"" { test "succeeds for \"Editor\"" {
Expect.equal Editor (AccessLevel.Parse "Editor") "Editor not parsed correctly" Expect.equal (AccessLevel.Parse "Editor") Editor "Editor not parsed correctly"
} }
test "succeeds for \"WebLogAdmin\"" { test "succeeds for \"WebLogAdmin\"" {
Expect.equal WebLogAdmin (AccessLevel.Parse "WebLogAdmin") "WebLogAdmin not parsed correctly" Expect.equal (AccessLevel.Parse "WebLogAdmin") WebLogAdmin "WebLogAdmin not parsed correctly"
} }
test "succeeds for \"Administrator\"" { test "succeeds for \"Administrator\"" {
Expect.equal Administrator (AccessLevel.Parse "Administrator") "Administrator not parsed correctly" Expect.equal (AccessLevel.Parse "Administrator") Administrator "Administrator not parsed correctly"
} }
test "fails when given an unrecognized value" { test "fails when given an unrecognized value" {
Expect.throwsT<ArgumentException> Expect.throwsT<ArgumentException>
@@ -113,17 +113,47 @@ let accessLevelTests = testList "AccessLevel" [
] ]
] ]
/// Tests for the AutoHtmxType type
let autoHtmxTypeTests = testList "AutoHtmxType" [
testList "Parse" [
test "succeeds for \"NoAutoHtmx\"" {
Expect.equal (AutoHtmxType.Parse "No") NoAutoHtmx "No not parsed correctly"
}
test "succeeds for \"AutoHtmx\"" {
Expect.equal (AutoHtmxType.Parse "Yes") AutoHtmx "Yes not parsed correctly"
}
test "succeeds for \"AutoHtmax\"" {
Expect.equal (AutoHtmxType.Parse "Max") AutoHtmax "Max not parsed correctly"
}
test "fails for unrecognized value" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (AutoHtmxType.Parse "Sure")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "NoAutoHtmx succeeds" {
Expect.equal (string NoAutoHtmx) "No" "NoAutoHtmx string incorrect"
}
test "AutoHtmx succeeds" {
Expect.equal (string AutoHtmx) "Yes" "AutoHtmx string incorrect"
}
test "AutoHtmax succeeds" {
Expect.equal (string AutoHtmax) "Max" "AutoHtmax string incorrect"
}
]
]
/// Tests for the CommentStatus type /// Tests for the CommentStatus type
let commentStatusTests = testList "CommentStatus" [ let commentStatusTests = testList "CommentStatus" [
testList "Parse" [ testList "Parse" [
test "succeeds for \"Approved\"" { test "succeeds for \"Approved\"" {
Expect.equal Approved (CommentStatus.Parse "Approved") "Approved not parsed correctly" Expect.equal (CommentStatus.Parse "Approved") Approved "Approved not parsed correctly"
} }
test "succeeds for \"Pending\"" { test "succeeds for \"Pending\"" {
Expect.equal Pending (CommentStatus.Parse "Pending") "Pending not parsed correctly" Expect.equal (CommentStatus.Parse "Pending") Pending "Pending not parsed correctly"
} }
test "succeeds for \"Spam\"" { test "succeeds for \"Spam\"" {
Expect.equal Spam (CommentStatus.Parse "Spam") "Spam not parsed correctly" Expect.equal (CommentStatus.Parse "Spam") Spam "Spam not parsed correctly"
} }
test "fails for unrecognized value" { test "fails for unrecognized value" {
Expect.throwsT<ArgumentException> Expect.throwsT<ArgumentException>
@@ -147,13 +177,13 @@ let commentStatusTests = testList "CommentStatus" [
let explicitRatingTests = testList "ExplicitRating" [ let explicitRatingTests = testList "ExplicitRating" [
testList "Parse" [ testList "Parse" [
test "succeeds for \"yes\"" { test "succeeds for \"yes\"" {
Expect.equal Yes (ExplicitRating.Parse "yes") "\"yes\" not parsed correctly" Expect.equal (ExplicitRating.Parse "yes") Yes "\"yes\" not parsed correctly"
} }
test "succeeds for \"no\"" { test "succeeds for \"no\"" {
Expect.equal No (ExplicitRating.Parse "no") "\"no\" not parsed correctly" Expect.equal (ExplicitRating.Parse "no") No "\"no\" not parsed correctly"
} }
test "succeeds for \"clean\"" { test "succeeds for \"clean\"" {
Expect.equal Clean (ExplicitRating.Parse "clean") "\"clean\" not parsed correctly" Expect.equal (ExplicitRating.Parse "clean") Clean "\"clean\" not parsed correctly"
} }
test "fails for unrecognized value" { test "fails for unrecognized value" {
Expect.throwsT<ArgumentException> Expect.throwsT<ArgumentException>
@@ -257,6 +287,403 @@ let markupTextTests = testList "MarkupText" [
] ]
] ]
/// Unit tests for the OpenGraphAudio type
let openGraphAudioTests = testList "OpenGraphAudio" [
let webLog = { WebLog.Empty with UrlBase = "https://unit.test/taco" }
let transform = webLog.UrlToAbsolute
testList "ToProperties" [
test "succeeds with minimum required" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "http://test.this" }.ToProperties transform)
Expect.hasLength props 1 "There should be one property"
Expect.equal props[0] ("og:audio", "http://test.this") "The URL was not written correctly"
}
test "succeeds with secure URL" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "https://test.this" }.ToProperties transform)
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[0] ("og:audio", "https://test.this") "The URL was not written correctly"
Expect.equal
props[1] ("og:audio:secure_url", "https://test.this") "The Secure URL was not written correctly"
}
test "succeeds with all properties filled" {
let props = Array.ofSeq ({ Url = "http://test.this"; Type = Some "audio/mpeg" }.ToProperties transform)
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[0] ("og:audio", "http://test.this") "The URL was not written correctly"
Expect.equal props[1] ("og:audio:type", "audio/mpeg") "The MIME type was not written correctly"
}
test "succeeds when deriving AAC and transforming URL" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "this/cool.file.aac" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal
props[0]
("og:audio", "https://unit.test/taco/this/cool.file.aac")
"The URL was not transformed correctly"
Expect.equal
props[1]
("og:audio:secure_url", "https://unit.test/taco/this/cool.file.aac")
"The URL was not transformed correctly"
Expect.equal props[2] ("og:audio:type", "audio/aac") "The MIME type for AAC was not derived correctly"
}
test "succeeds when deriving MP3" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "an.other/song.mp3" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:audio:type", "audio/mpeg") "The MIME type for MP3 was not derived correctly"
}
test "succeeds when deriving OGA" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "talks/speex.oga" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:audio:type", "audio/ogg") "The MIME type for OGA was not derived correctly"
}
test "succeeds when deriving WAV" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "some/old.school.wav" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:audio:type", "audio/wav") "The MIME type for WAV was not derived correctly"
}
test "succeeds when deriving WEBA" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "new/format/file.weba" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:audio:type", "audio/webm") "The MIME type for WEBA was not derived correctly"
}
test "succeeds when type cannot be derived" {
let props = Array.ofSeq ({ OpenGraphAudio.Empty with Url = "profile.jpg" }.ToProperties transform)
Expect.hasLength props 2 "There should be two properties (only URLs; no type derived)"
}
]
]
/// Tests for the OpenGraphImage type
let openGraphImageTests = testList "OpenGraphImage" [
let webLog = { WebLog.Empty with UrlBase = "https://unit.test/taco" }
let transform = webLog.UrlToAbsolute
testList "ToProperties" [
test "succeeds with minimum required" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "http://test.url" }.ToProperties(transform, None))
Expect.hasLength props 1 "There should be one property"
Expect.equal props[0] ("og:image", "http://test.url") "The URL was not written correctly"
}
test "succeeds with fallback URL" {
let props = Array.ofSeq (OpenGraphImage.Empty.ToProperties(transform, Some "theme/it/favicon.ico"))
Expect.hasLength props 2 "There should be one property"
Expect.equal
props[0] ("og:image", "https://unit.test/taco/theme/it/favicon.ico") "The URL was not written correctly"
Expect.equal
props[1]
("og:image:secure_url", "https://unit.test/taco/theme/it/favicon.ico")
"The secure URL was not written correctly"
}
test "succeeds with secure URL" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "https://secure.url" }.ToProperties(transform, None))
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[0] ("og:image", "https://secure.url") "The URL was not written correctly"
Expect.equal
props[1] ("og:image:secure_url", "https://secure.url") "The Secure URL was not written correctly"
}
test "succeeds with all properties filled" {
let props =
{ Url = "http://test.this"
Type = Some "image/jpeg"
Width = Some 400
Height = Some 600
Alt = Some "This ought to be good" }.ToProperties(transform, None)
|> Array.ofSeq
Expect.hasLength props 5 "There should be five properties"
Expect.equal props[0] ("og:image", "http://test.this") "The URL was not written correctly"
Expect.equal props[1] ("og:image:type", "image/jpeg") "The MIME type was not written correctly"
Expect.equal props[2] ("og:image:width", "400") "The width was not written correctly"
Expect.equal props[3] ("og:image:height", "600") "The height was not written correctly"
Expect.equal props[4] ("og:image:alt", "This ought to be good") "The alt text was not written correctly"
}
test "succeeds when deriving BMP and transforming URL" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "old/windows.bmp" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal
props[0] ("og:image", "https://unit.test/taco/old/windows.bmp") "The URL was not transformed correctly"
Expect.equal
props[1]
("og:image:secure_url", "https://unit.test/taco/old/windows.bmp")
"The URL was not transformed correctly"
Expect.equal props[2] ("og:image:type", "image/bmp") "The MIME type for BMP was not derived correctly"
}
test "succeeds when deriving GIF" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "its.a.soft.g.gif" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:image:type", "image/gif") "The MIME type for GIF was not derived correctly"
}
test "succeeds when deriving ICO" {
let props = Array.ofSeq ({ OpenGraphImage.Empty with Url = "favicon.ico" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal
props[2] ("og:image:type", "image/vnd.microsoft.icon") "The MIME type for ICO was not derived correctly"
}
test "succeeds when deriving JPEG" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "big/name/photo.jpeg" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:image:type", "image/jpeg") "The MIME type for JPEG was not derived correctly"
}
test "succeeds when deriving PNG" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "some/nice/graphic.png" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:image:type", "image/png") "The MIME type for PNG was not derived correctly"
}
test "succeeds when deriving SVG" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "fancy-new-vector.svg" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:image:type", "image/svg+xml") "The MIME type for SVG was not derived correctly"
}
test "succeeds when deriving TIF" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "tagged/file.tif" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:image:type", "image/tiff") "The MIME type for TIF was not derived correctly"
}
test "succeeds when deriving TIFF" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "tagged/file.two.tiff" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:image:type", "image/tiff") "The MIME type for TIFF was not derived correctly"
}
test "succeeds when deriving WEBP" {
let props =
Array.ofSeq ({ OpenGraphImage.Empty with Url = "modern/photo.webp" }.ToProperties(transform, None))
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:image:type", "image/webp") "The MIME type for WEBP was not derived correctly"
}
test "succeeds when type cannot be derived" {
let props = Array.ofSeq ({ OpenGraphImage.Empty with Url = "intro.mp3" }.ToProperties(transform, None))
Expect.hasLength props 2 "There should be two properties (only URLs; no type derived)"
}
]
]
/// Unit tests for the OpenGraphVideo type
let openGraphVideoTests = testList "OpenGraphVideo" [
let webLog = { WebLog.Empty with UrlBase = "https://unit.test/taco" }
let transform = webLog.UrlToAbsolute
testList "ToProperties" [
test "succeeds with minimum required" {
let props = Array.ofSeq ({ OpenGraphVideo.Empty with Url = "http://url.test" }.ToProperties transform)
Expect.hasLength props 1 "There should be one property"
Expect.equal props[0] ("og:video", "http://url.test") "The URL was not written correctly"
}
test "succeeds with secure URL" {
let props = Array.ofSeq ({ OpenGraphVideo.Empty with Url = "https://url.secure" }.ToProperties transform)
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[0] ("og:video", "https://url.secure") "The URL was not written correctly"
Expect.equal
props[1] ("og:video:secure_url", "https://url.secure") "The Secure URL was not written correctly"
}
test "succeeds with all properties filled" {
let props =
{ Url = "http://test.this"
Type = Some "video/mpeg"
Width = Some 1200
Height = Some 900 }.ToProperties transform
|> Array.ofSeq
Expect.hasLength props 4 "There should be five properties"
Expect.equal props[0] ("og:video", "http://test.this") "The URL was not written correctly"
Expect.equal props[1] ("og:video:type", "video/mpeg") "The MIME type was not written correctly"
Expect.equal props[2] ("og:video:width", "1200") "The width was not written correctly"
Expect.equal props[3] ("og:video:height", "900") "The height was not written correctly"
}
test "succeeds when deriving AVI and transforming URL" {
let props = Array.ofSeq ({ OpenGraphVideo.Empty with Url = "my.video.avi" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal
props[0] ("og:video", "https://unit.test/taco/my.video.avi") "The URL not transformed correctly"
Expect.equal
props[1]
("og:video:secure_url", "https://unit.test/taco/my.video.avi")
"The URL not transformed correctly"
Expect.equal props[2] ("og:video:type", "video/x-msvideo") "The MIME type for AVI was not derived correctly"
}
test "succeeds when deriving MP4" {
let props = Array.ofSeq ({ OpenGraphVideo.Empty with Url = "chapters/1/01.mp4" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:video:type", "video/mp4") "The MIME type for MP4 was not derived correctly"
}
test "succeeds when deriving MPEG" {
let props = Array.ofSeq ({ OpenGraphVideo.Empty with Url = "viral/video.mpeg" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:video:type", "video/mpeg") "The MIME type for MPEG was not derived correctly"
}
test "succeeds when deriving OGV" {
let props =
Array.ofSeq ({ OpenGraphVideo.Empty with Url = "open/video/example.ogv" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:video:type", "video/ogg") "The MIME type for OGV was not derived correctly"
}
test "succeeds when deriving WEBM" {
let props = Array.ofSeq ({ OpenGraphVideo.Empty with Url = "images/hero.webm" }.ToProperties transform)
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[2] ("og:video:type", "video/webm") "The MIME type for WEBM was not derived correctly"
}
test "succeeds when type cannot be derived" {
let props = Array.ofSeq ({ OpenGraphVideo.Empty with Url = "favicon.ico" }.ToProperties transform)
Expect.hasLength props 2 "There should be two properties (only URLs; no type derived)"
}
]
]
/// Unit tests for the OpenGraphType type
let openGraphTypeTests = testList "OpenGraphType" [
testList "Parse" [
test "succeeds for \"article\"" {
Expect.equal (OpenGraphType.Parse "article") Article "\"article\" not parsed correctly"
}
test "succeeds for \"book\"" {
Expect.equal (OpenGraphType.Parse "book") Book "\"book\" not parsed correctly"
}
test "succeeds for \"music.album\"" {
Expect.equal (OpenGraphType.Parse "music.album") MusicAlbum "\"music.album\" not parsed correctly"
}
test "succeeds for \"music.playlist\"" {
Expect.equal (OpenGraphType.Parse "music.playlist") MusicPlaylist "\"music.playlist\" not parsed correctly"
}
test "succeeds for \"music.radio_station\"" {
Expect.equal
(OpenGraphType.Parse "music.radio_station")
MusicRadioStation
"\"music.radio_station\" not parsed correctly"
}
test "succeeds for \"music.song\"" {
Expect.equal (OpenGraphType.Parse "music.song") MusicSong "\"music.song\" not parsed correctly"
}
test "succeeds for \"payment.link\"" {
Expect.equal (OpenGraphType.Parse "payment.link") PaymentLink "\"payment.link\" not parsed correctly"
}
test "succeeds for \"profile\"" {
Expect.equal (OpenGraphType.Parse "profile") Profile "\"profile\" not parsed correctly"
}
test "succeeds for \"video.episode\"" {
Expect.equal (OpenGraphType.Parse "video.episode") VideoEpisode "\"video.episode\" not parsed correctly"
}
test "succeeds for \"video.movie\"" {
Expect.equal (OpenGraphType.Parse "video.movie") VideoMovie "\"video.movie\" not parsed correctly"
}
test "succeeds for \"video.other\"" {
Expect.equal (OpenGraphType.Parse "video.other") VideoOther "\"video.other\" not parsed correctly"
}
test "succeeds for \"video.tv_show\"" {
Expect.equal (OpenGraphType.Parse "video.tv_show") VideoTvShow "\"video.tv_show\" not parsed correctly"
}
test "succeeds for \"website\"" {
Expect.equal (OpenGraphType.Parse "website") Website "\"website\" not parsed correctly"
}
test "fails for invalid type" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (OpenGraphType.Parse "anthology")) "Invalid value should have raised an exception"
}
]
test "Selections succeeds" {
let it = OpenGraphType.Selections
Expect.hasLength it 13 "There should be 13 selections"
Expect.equal (List.head it) ("article", "Article") "Article not found where expected"
Expect.equal (it |> List.item 1) ("book", "Book") "Book not found where expected"
Expect.equal (it |> List.item 2) ("music.album", "Music: Album") "MusicAlbum not found where expected"
Expect.equal (it |> List.item 3) ("music.playlist", "Music: Playlist") "MusicPlaylist not found where expected"
Expect.equal
(it |> List.item 4)
("music.radio_station", "Music: Radio Station")
"MusicRadioStation not found where expected"
Expect.equal (it |> List.item 5) ("music.song", "Music: Song") "MusicSong not found where expected"
Expect.equal (it |> List.item 6) ("payment.link", "Payment Link") "PaymentLink not found where expected"
Expect.equal (it |> List.item 7) ("profile", "Profile") "Profile not found where expected"
Expect.equal (it |> List.item 8) ("video.episode", "Video: Episode") "VideoEpisode not found where expected"
Expect.equal (it |> List.item 9) ("video.movie", "Video: Movie") "VideoMovie not found where expected"
Expect.equal (it |> List.item 10) ("video.other", "Video: Other") "VideoOther not found where expected"
Expect.equal (it |> List.item 11) ("video.tv_show", "Video: TV Show") "VideoTvShow not found where expected"
Expect.equal (it |> List.item 12) ("website", "Website") "Website not found where expected"
}
testList "ToString" [
test "succeeds for Article" {
Expect.equal (string Article) "article" "Article string incorrect"
}
test "succeeds for Book" {
Expect.equal (string Book) "book" "Book string incorrect"
}
test "succeeds for MusicAlbum" {
Expect.equal (string MusicAlbum) "music.album" "MusicAlbum string incorrect"
}
test "succeeds for MusicPlaylist" {
Expect.equal (string MusicPlaylist) "music.playlist" "MusicPlaylist string incorrect"
}
test "succeeds for MusicRadioStation" {
Expect.equal (string MusicRadioStation) "music.radio_station" "MusicRadioStation string incorrect"
}
test "succeeds for MusicSong" {
Expect.equal (string MusicSong) "music.song" "MusicSong string incorrect"
}
test "succeeds for PaymentLink" {
Expect.equal (string PaymentLink) "payment.link" "PaymentLink string incorrect"
}
test "succeeds for Profile" {
Expect.equal (string Profile) "profile" "Profile string incorrect"
}
test "succeeds for VideoEpisode" {
Expect.equal (string VideoEpisode) "video.episode" "VideoEpisode string incorrect"
}
test "succeeds for VideoMovie" {
Expect.equal (string VideoMovie) "video.movie" "VideoMovie string incorrect"
}
test "succeeds for VideoOther" {
Expect.equal (string VideoOther) "video.other" "VideoOther string incorrect"
}
test "succeeds for VideoTvShow" {
Expect.equal (string VideoTvShow) "video.tv_show" "VideoTvShow string incorrect"
}
test "succeeds for Website" {
Expect.equal (string Website) "website" "Website string incorrect"
}
]
]
/// Unit tests for the OpenGraphProperties type
let openGraphPropertiesTests = testList "OpenGraphProperties" [
testList "Properties" [
test "succeeds with minimal values" {
let props =
{ OpenGraphProperties.Empty with
Image = { OpenGraphImage.Empty with Url = "http://this.aint.nothing" } }
.ToProperties WebLog.Empty.UrlToAbsolute None
|> Array.ofSeq
Expect.hasLength props 2 "There should have been two properties"
Expect.equal props[0] ("og:type", "article") "Type not written correctly"
Expect.equal props[1] ("og:image", "http://this.aint.nothing") "Image URL not written correctly"
}
test "succeeds with all values" {
let props =
{ Type = Book
Image = { OpenGraphImage.Empty with Url = "http://this.image.file" }
Audio = Some { OpenGraphAudio.Empty with Url = "http://this.audio.file" }
Description = Some "This is a unit test"
Determiner = Some "a"
Locale = Some "en_US"
LocaleAlternate = Some [ "en_UK"; "es_MX" ]
Video = Some { OpenGraphVideo.Empty with Url = "http://this.video.file" }
Other = Some [ { Name = "book.publisher"; Value = "Yep" } ] }
.ToProperties WebLog.Empty.UrlToAbsolute None
|> Array.ofSeq
Expect.hasLength props 10 "There should have been ten properties"
Expect.equal props[0] ("og:type", "book") "Type not written correctly"
Expect.equal props[1] ("og:image", "http://this.image.file") "Image URL not written correctly"
Expect.equal props[2] ("og:description", "This is a unit test") "Description not written correctly"
Expect.equal props[3] ("og:determiner", "a") "Determiner not written correctly"
Expect.equal props[4] ("og:locale", "en_US") "Locale not written correctly"
Expect.equal props[5] ("og:locale:alternate", "en_UK") "1st Alternate Locale not written correctly"
Expect.equal props[6] ("og:locale:alternate", "es_MX") "2nd Alternate Locale not written correctly"
Expect.equal props[7] ("og:audio", "http://this.audio.file") "Audio URL not written correctly"
Expect.equal props[8] ("og:video", "http://this.video.file") "Video URL not written correctly"
Expect.equal props[9] ("book.publisher", "Yep") "Other property not written correctly"
}
]
]
/// Unit tests for the PodcastMedium type /// Unit tests for the PodcastMedium type
let podcastMediumTests = testList "PodcastMedium" [ let podcastMediumTests = testList "PodcastMedium" [
testList "Parse" [ testList "Parse" [
@@ -403,10 +830,16 @@ let uploadDestinationTests = testList "UploadDestination" [
let all = testList "SupportTypes" [ let all = testList "SupportTypes" [
nodaTests nodaTests
accessLevelTests accessLevelTests
autoHtmxTypeTests
commentStatusTests commentStatusTests
explicitRatingTests explicitRatingTests
episodeTests episodeTests
markupTextTests markupTextTests
openGraphAudioTests
openGraphImageTests
openGraphVideoTests
openGraphTypeTests
openGraphPropertiesTests
podcastMediumTests podcastMediumTests
postStatusTests postStatusTests
customFeedSourceTests customFeedSourceTests
+251 -47
View File
@@ -206,6 +206,25 @@ let private testFullPage =
Revisions = Revisions =
[ { AsOf = Noda.epoch + Duration.FromHours 1; Text = Markdown "# Howdy!" } [ { AsOf = Noda.epoch + Duration.FromHours 1; Text = Markdown "# Howdy!" }
{ AsOf = Noda.epoch; Text = Html "<h1>howdy</h1>" } ] { AsOf = Noda.epoch; Text = Html "<h1>howdy</h1>" } ]
OpenGraph =
Some { Type = Book
Image =
{ Url = "https://unit.test/it.png"
Type = Some "test/png"
Width = Some 1
Height = Some 2
Alt = Some "huh" }
Audio = Some { Url = "https://unit.test/it.mp3"; Type = Some "test/mpeg-3" }
Description = Some "This is cool"
Determiner = Some "the"
Locale = Some "en-US"
LocaleAlternate = Some [ "es-MX"; "es-ES" ]
Video =
Some { Url = "https://unit.test/it.mp4"
Type = Some "test/mpeg-4"
Width = Some 5
Height = Some 6 }
Other = Some [ { Name = "the-other"; Value = "the-value" } ] }
Metadata = [ { Name = "Test"; Value = "me" }; { Name = "Two"; Value = "2" } ] } Metadata = [ { Name = "Test"; Value = "me" }; { Name = "Two"; Value = "2" } ] }
/// A full post used to test various models /// A full post used to test various models
@@ -221,6 +240,25 @@ let testFullPost =
Text = "<p>A post!</p>" Text = "<p>A post!</p>"
CategoryIds = [ CategoryId "cat-a"; CategoryId "cat-b"; CategoryId "cat-n" ] CategoryIds = [ CategoryId "cat-a"; CategoryId "cat-b"; CategoryId "cat-n" ]
Tags = [ "demo"; "post" ] Tags = [ "demo"; "post" ]
OpenGraph =
Some { Type = MusicAlbum
Image =
{ Url = "https://unit.test/it.jpg"
Type = Some "test/jpg"
Width = Some 100
Height = Some 200
Alt = Some "it is a jpeg" }
Audio = Some { Url = "https://unit.test/that.mp3"; Type = Some "test/mp3" }
Description = Some "Just a post"
Determiner = Some "a"
Locale = Some "es-MX"
LocaleAlternate = Some [ "es-ES"; "en-EN" ]
Video =
Some { Url = "https://unit.test/that.mp4"
Type = Some "test/mp4"
Width = Some 50
Height = Some 60 }
Other = Some [ { Name = "an-other"; Value = "a-value" } ] }
Metadata = [ { Name = "A Meta"; Value = "A Value" } ] Metadata = [ { Name = "A Meta"; Value = "A Value" } ]
Revisions = Revisions =
[ { AsOf = Noda.epoch + Duration.FromDays 365; Text = Html "<p>A post!</p>" } [ { AsOf = Noda.epoch + Duration.FromDays 365; Text = Html "<p>A post!</p>" }
@@ -266,9 +304,28 @@ let editCommonModelTests = testList "EditCommonModel" [
Expect.equal model.Template "" "Template not filled properly" Expect.equal model.Template "" "Template not filled properly"
Expect.equal model.Source "HTML" "Source not filled properly" Expect.equal model.Source "HTML" "Source not filled properly"
Expect.equal model.Text "" "Text not set properly" Expect.equal model.Text "" "Text not set properly"
Expect.equal model.MetaNames.Length 1 "MetaNames should have one entry" Expect.isFalse model.AssignOpenGraph "OpenGraph properties should not have been assigned"
Expect.equal model.OpenGraphType "" "OpenGraph type not filled properly"
Expect.equal model.OpenGraphImageUrl "" "OpenGraph image URL not filled properly"
Expect.equal model.OpenGraphImageType "" "OpenGraph image type not filled properly"
Expect.equal model.OpenGraphImageWidth "" "OpenGraph image width not filled properly"
Expect.equal model.OpenGraphImageHeight "" "OpenGraph image height not filled properly"
Expect.equal model.OpenGraphImageAlt "" "OpenGraph image alt text not filled properly"
Expect.equal model.OpenGraphAudioUrl "" "OpenGraph audio URL not filled properly"
Expect.equal model.OpenGraphAudioType "" "OpenGraph audio type not filled properly"
Expect.equal model.OpenGraphDescription "" "OpenGraph description not filled properly"
Expect.equal model.OpenGraphDeterminer "" "OpenGraph determiner not filled properly"
Expect.equal model.OpenGraphLocale "" "OpenGraph locale not filled properly"
Expect.equal model.OpenGraphAlternateLocales "" "OpenGraph alt locales not filled properly"
Expect.equal model.OpenGraphVideoUrl "" "OpenGraph video URL not filled properly"
Expect.equal model.OpenGraphVideoType "" "OpenGraph video type not filled properly"
Expect.equal model.OpenGraphVideoWidth "" "OpenGraph video width not filled properly"
Expect.equal model.OpenGraphVideoHeight "" "OpenGraph video height not filled properly"
Expect.isEmpty model.OpenGraphExtraNames "OpenGraph extra names not filled properly"
Expect.isEmpty model.OpenGraphExtraValues "OpenGraph extra values not filled properly"
Expect.hasLength model.MetaNames 1 "MetaNames should have one entry"
Expect.equal model.MetaNames[0] "" "Meta name not set properly" Expect.equal model.MetaNames[0] "" "Meta name not set properly"
Expect.equal model.MetaValues.Length 1 "MetaValues should have one entry" Expect.hasLength model.MetaValues 1 "MetaValues should have one entry"
Expect.equal model.MetaValues[0] "" "Meta value not set properly" Expect.equal model.MetaValues[0] "" "Meta value not set properly"
} }
test "succeeds for filled page" { test "succeeds for filled page" {
@@ -280,10 +337,31 @@ let editCommonModelTests = testList "EditCommonModel" [
Expect.equal model.Template "bork" "Template not filled properly" Expect.equal model.Template "bork" "Template not filled properly"
Expect.equal model.Source "Markdown" "Source not filled properly" Expect.equal model.Source "Markdown" "Source not filled properly"
Expect.equal model.Text "# Howdy!" "Text not filled properly" Expect.equal model.Text "# Howdy!" "Text not filled properly"
Expect.equal model.MetaNames.Length 2 "MetaNames should have two entries" Expect.isTrue model.AssignOpenGraph "OpenGraph properties should have been assigned"
Expect.equal model.OpenGraphType "book" "OpenGraph type not filled properly"
Expect.equal model.OpenGraphImageUrl "https://unit.test/it.png" "OpenGraph image URL not filled properly"
Expect.equal model.OpenGraphImageType "test/png" "OpenGraph image type not filled properly"
Expect.equal model.OpenGraphImageWidth "1" "OpenGraph image width not filled properly"
Expect.equal model.OpenGraphImageHeight "2" "OpenGraph image height not filled properly"
Expect.equal model.OpenGraphImageAlt "huh" "OpenGraph image alt text not filled properly"
Expect.equal model.OpenGraphAudioUrl "https://unit.test/it.mp3" "OpenGraph audio URL not filled properly"
Expect.equal model.OpenGraphAudioType "test/mpeg-3" "OpenGraph audio type not filled properly"
Expect.equal model.OpenGraphDescription "This is cool" "OpenGraph description not filled properly"
Expect.equal model.OpenGraphDeterminer "the" "OpenGraph determiner not filled properly"
Expect.equal model.OpenGraphLocale "en-US" "OpenGraph locale not filled properly"
Expect.equal model.OpenGraphAlternateLocales "es-MX, es-ES" "OpenGraph alt locales not filled properly"
Expect.equal model.OpenGraphVideoUrl "https://unit.test/it.mp4" "OpenGraph video URL not filled properly"
Expect.equal model.OpenGraphVideoType "test/mpeg-4" "OpenGraph video type not filled properly"
Expect.equal model.OpenGraphVideoWidth "5" "OpenGraph video width not filled properly"
Expect.equal model.OpenGraphVideoHeight "6" "OpenGraph video height not filled properly"
Expect.hasLength model.OpenGraphExtraNames 1 "OpenGraph extra names should have had 1 entry"
Expect.equal model.OpenGraphExtraNames[0] "the-other" "OpenGraph extra names not filled properly"
Expect.hasLength model.OpenGraphExtraValues 1 "OpenGraph extra values should have had 1 entry"
Expect.equal model.OpenGraphExtraValues[0] "the-value" "OpenGraph extra values not filled properly"
Expect.hasLength model.MetaNames 2 "MetaNames should have two entries"
Expect.equal model.MetaNames[0] "Test" "Meta name 0 not set properly" Expect.equal model.MetaNames[0] "Test" "Meta name 0 not set properly"
Expect.equal model.MetaNames[1] "Two" "Meta name 1 not set properly" Expect.equal model.MetaNames[1] "Two" "Meta name 1 not set properly"
Expect.equal model.MetaValues.Length 2 "MetaValues should have two entries" Expect.hasLength model.MetaValues 2 "MetaValues should have two entries"
Expect.equal model.MetaValues[0] "me" "Meta value 0 not set properly" Expect.equal model.MetaValues[0] "me" "Meta value 0 not set properly"
Expect.equal model.MetaValues[1] "2" "Meta value 1 not set properly" Expect.equal model.MetaValues[1] "2" "Meta value 1 not set properly"
} }
@@ -298,9 +376,28 @@ let editCommonModelTests = testList "EditCommonModel" [
Expect.equal model.Source "HTML" "Source not filled properly" Expect.equal model.Source "HTML" "Source not filled properly"
Expect.equal model.Text "" "Text not filled properly" Expect.equal model.Text "" "Text not filled properly"
Expect.equal model.Template "" "Template not filled properly" Expect.equal model.Template "" "Template not filled properly"
Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" Expect.isFalse model.AssignOpenGraph "OpenGraph properties should not have been assigned"
Expect.equal model.OpenGraphType "" "OpenGraph type not filled properly"
Expect.equal model.OpenGraphImageUrl "" "OpenGraph image URL not filled properly"
Expect.equal model.OpenGraphImageType "" "OpenGraph image type not filled properly"
Expect.equal model.OpenGraphImageWidth "" "OpenGraph image width not filled properly"
Expect.equal model.OpenGraphImageHeight "" "OpenGraph image height not filled properly"
Expect.equal model.OpenGraphImageAlt "" "OpenGraph image alt text not filled properly"
Expect.equal model.OpenGraphAudioUrl "" "OpenGraph audio URL not filled properly"
Expect.equal model.OpenGraphAudioType "" "OpenGraph audio type not filled properly"
Expect.equal model.OpenGraphDescription "" "OpenGraph description not filled properly"
Expect.equal model.OpenGraphDeterminer "" "OpenGraph determiner not filled properly"
Expect.equal model.OpenGraphLocale "" "OpenGraph locale not filled properly"
Expect.equal model.OpenGraphAlternateLocales "" "OpenGraph alt locales not filled properly"
Expect.equal model.OpenGraphVideoUrl "" "OpenGraph video URL not filled properly"
Expect.equal model.OpenGraphVideoType "" "OpenGraph video type not filled properly"
Expect.equal model.OpenGraphVideoWidth "" "OpenGraph video width not filled properly"
Expect.equal model.OpenGraphVideoHeight "" "OpenGraph video height not filled properly"
Expect.isEmpty model.OpenGraphExtraNames "OpenGraph extra names not filled properly"
Expect.isEmpty model.OpenGraphExtraValues "OpenGraph extra values not filled properly"
Expect.hasLength model.MetaNames 1 "MetaNames not filled properly"
Expect.equal model.MetaNames[0] "" "Meta name 0 not filled properly" Expect.equal model.MetaNames[0] "" "Meta name 0 not filled properly"
Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" Expect.hasLength model.MetaValues 1 "MetaValues not filled properly"
Expect.equal model.MetaValues[0] "" "Meta value 0 not filled properly" Expect.equal model.MetaValues[0] "" "Meta value 0 not filled properly"
} }
test "succeeds for full post with external chapters" { test "succeeds for full post with external chapters" {
@@ -312,12 +409,111 @@ let editCommonModelTests = testList "EditCommonModel" [
Expect.equal model.Source "HTML" "Source not filled properly" Expect.equal model.Source "HTML" "Source not filled properly"
Expect.equal model.Text "<p>A post!</p>" "Text not filled properly" Expect.equal model.Text "<p>A post!</p>" "Text not filled properly"
Expect.equal model.Template "demo" "Template not filled properly" Expect.equal model.Template "demo" "Template not filled properly"
Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" Expect.isTrue model.AssignOpenGraph "OpenGraph properties should have been assigned"
Expect.equal model.OpenGraphType "music.album" "OpenGraph type not filled properly"
Expect.equal model.OpenGraphImageUrl "https://unit.test/it.jpg" "OpenGraph image URL not filled properly"
Expect.equal model.OpenGraphImageType "test/jpg" "OpenGraph image type not filled properly"
Expect.equal model.OpenGraphImageWidth "100" "OpenGraph image width not filled properly"
Expect.equal model.OpenGraphImageHeight "200" "OpenGraph image height not filled properly"
Expect.equal model.OpenGraphImageAlt "it is a jpeg" "OpenGraph image alt text not filled properly"
Expect.equal model.OpenGraphAudioUrl "https://unit.test/that.mp3" "OpenGraph audio URL not filled properly"
Expect.equal model.OpenGraphAudioType "test/mp3" "OpenGraph audio type not filled properly"
Expect.equal model.OpenGraphDescription "Just a post" "OpenGraph description not filled properly"
Expect.equal model.OpenGraphDeterminer "a" "OpenGraph determiner not filled properly"
Expect.equal model.OpenGraphLocale "es-MX" "OpenGraph locale not filled properly"
Expect.equal model.OpenGraphAlternateLocales "es-ES, en-EN" "OpenGraph alt locales not filled properly"
Expect.equal model.OpenGraphVideoUrl "https://unit.test/that.mp4" "OpenGraph video URL not filled properly"
Expect.equal model.OpenGraphVideoType "test/mp4" "OpenGraph video type not filled properly"
Expect.equal model.OpenGraphVideoWidth "50" "OpenGraph video width not filled properly"
Expect.equal model.OpenGraphVideoHeight "60" "OpenGraph video height not filled properly"
Expect.hasLength model.OpenGraphExtraNames 1 "OpenGraph extra names should have had 1 entry"
Expect.equal model.OpenGraphExtraNames[0] "an-other" "OpenGraph extra names not filled properly"
Expect.hasLength model.OpenGraphExtraValues 1 "OpenGraph extra values should have had 1 entry"
Expect.equal model.OpenGraphExtraValues[0] "a-value" "OpenGraph extra values not filled properly"
Expect.hasLength model.MetaNames 1 "MetaNames not filled properly"
Expect.equal model.MetaNames[0] "A Meta" "Meta name 0 not filled properly" Expect.equal model.MetaNames[0] "A Meta" "Meta name 0 not filled properly"
Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" Expect.hasLength model.MetaValues 1 "MetaValues not filled properly"
Expect.equal model.MetaValues[0] "A Value" "Meta value 0 not filled properly" Expect.equal model.MetaValues[0] "A Value" "Meta value 0 not filled properly"
} }
] ]
testList "ToOpenGraph" [
test "succeeds when OpenGraph properties are not assigned" {
Expect.isNone (EditCommonModel().ToOpenGraph()) "No OpenGraph properties should have returned None"
}
test "succeeds when minimal OpenGraph properties are assigned" {
let model = EditCommonModel()
model.AssignOpenGraph <- true
model.OpenGraphType <- string Article
model.OpenGraphImageUrl <- "https://unit.test/img.tiff"
let tryOg = model.ToOpenGraph()
Expect.isSome tryOg "There should have been a set of OpenGraph properties returned"
let og = tryOg.Value
Expect.equal og.Type Article "OpenGraph type not filled correctly"
Expect.equal og.Image.Url "https://unit.test/img.tiff" "OpenGraph image URL not filled properly"
Expect.isNone og.Image.Type "OpenGraph image type should have been None"
Expect.isNone og.Image.Width "OpenGraph image width should have been None"
Expect.isNone og.Image.Height "OpenGraph image height should have been None"
Expect.isNone og.Image.Alt "OpenGraph image alt text should have been None"
Expect.isNone og.Audio "OpenGraph audio should have been None"
Expect.isNone og.Description "OpenGraph description should have been None"
Expect.isNone og.Determiner "OpenGraph determiner should have been None"
Expect.isNone og.Locale "OpenGraph locale should have been None"
Expect.isNone og.LocaleAlternate "OpenGraph alt locales should have been None"
Expect.isNone og.Video "OpenGraph video should have been None"
Expect.isNone og.Other "OpenGraph other properties should have been None"
}
test "succeeds when all OpenGraph properties are assigned" {
let model = EditCommonModel()
model.AssignOpenGraph <- true
model.OpenGraphType <- string VideoMovie
model.OpenGraphImageUrl <- "https://unit.test/still.jpg"
model.OpenGraphImageType <- "still/jpg"
model.OpenGraphImageWidth <- "17"
model.OpenGraphImageHeight <- "24"
model.OpenGraphImageAlt <- "a still from the film"
model.OpenGraphAudioUrl <- "https://unit.test/movie.mp3"
model.OpenGraphAudioType <- "audio/mp-three"
model.OpenGraphDescription <- "Powerful. Stunning."
model.OpenGraphDeterminer <- "the"
model.OpenGraphLocale <- "en-EN"
model.OpenGraphAlternateLocales <- "es-ES, pt-PT"
model.OpenGraphVideoUrl <- "https://unit.test/movie.avi"
model.OpenGraphVideoType <- "video/outdated"
model.OpenGraphVideoWidth <- "1024"
model.OpenGraphVideoHeight <- "768"
model.OpenGraphExtraNames <- [| "og:duration"; "og:rating" |]
model.OpenGraphExtraValues <- [| "1:30:27"; "G" |]
let tryOg = model.ToOpenGraph()
Expect.isSome tryOg "There should have been a set of OpenGraph properties returned"
let og = tryOg.Value
Expect.equal og.Type VideoMovie "OpenGraph type not filled correctly"
Expect.equal og.Image.Url "https://unit.test/still.jpg" "OpenGraph image URL not filled properly"
Expect.equal og.Image.Type (Some "still/jpg") "OpenGraph image type not filled properly"
Expect.equal og.Image.Width (Some 17) "OpenGraph image width not filled properly"
Expect.equal og.Image.Height (Some 24) "OpenGraph image height not filled properly"
Expect.equal og.Image.Alt (Some "a still from the film") "OpenGraph image alt text not filled properly"
Expect.isSome og.Audio "OpenGraph audio should have been filled"
Expect.equal og.Audio.Value.Url "https://unit.test/movie.mp3" "OpenGraph audio URL not filled properly"
Expect.equal og.Audio.Value.Type (Some "audio/mp-three") "OpenGraph audio type not filled properly"
Expect.equal og.Description (Some "Powerful. Stunning.") "OpenGraph description not filled properly"
Expect.equal og.Determiner (Some "the") "OpenGraph determiner not filled properly"
Expect.equal og.Locale (Some "en-EN") "OpenGraph locale not filled properly"
Expect.isSome og.LocaleAlternate "OpenGraph alt locales not filled properly"
Expect.hasLength og.LocaleAlternate.Value 2 "There should have been 2 alternate locales"
Expect.equal og.LocaleAlternate.Value [ "es-ES"; "pt-PT" ] "OpenGraph alt locales are incorrect"
Expect.isSome og.Video "OpenGraph video should have been filled"
Expect.equal og.Video.Value.Url "https://unit.test/movie.avi" "OpenGraph video URL not filled properly"
Expect.equal og.Video.Value.Type (Some "video/outdated") "OpenGraph video type not filled properly"
Expect.equal og.Video.Value.Width (Some 1024) "OpenGraph video width not filled properly"
Expect.equal og.Video.Value.Height (Some 768) "OpenGraph video height not filled properly"
Expect.isSome og.Other "OpenGraph other properties should have been filled"
Expect.hasLength og.Other.Value 2 "There should have been 2 extra properties"
Expect.equal
og.Other.Value
[ { Name = "og:duration"; Value = "1:30:27" }; { Name = "og:rating"; Value = "G" } ]
"OpenGraph extra properties not filled properly"
}
]
] ]
/// Unit tests for the EditCustomFeedModel type /// Unit tests for the EditCustomFeedModel type
@@ -514,11 +710,13 @@ let editPageModelTests = testList "EditPageModel" [
let model = EditPageModel.FromPage { Page.Empty with Id = PageId "abc" } let model = EditPageModel.FromPage { Page.Empty with Id = PageId "abc" }
Expect.equal model.Id "abc" "Parent fields not filled properly" Expect.equal model.Id "abc" "Parent fields not filled properly"
Expect.isFalse model.IsShownInPageList "IsShownInPageList should not have been set" Expect.isFalse model.IsShownInPageList "IsShownInPageList should not have been set"
Expect.isFalse model.AssignOpenGraph "OpenGraph properties should not be assigned"
} }
test "succeeds for filled page" { test "succeeds for filled page" {
let model = EditPageModel.FromPage testFullPage let model = EditPageModel.FromPage testFullPage
Expect.equal model.Id "the-page" "Parent fields not filled properly" Expect.equal model.Id "the-page" "Parent fields not filled properly"
Expect.isTrue model.IsShownInPageList "IsShownInPageList should have been set" Expect.isTrue model.IsShownInPageList "IsShownInPageList should have been set"
Expect.isTrue model.AssignOpenGraph "OpenGraph properties should have been assigned"
} }
] ]
testList "UpdatePage" [ testList "UpdatePage" [
@@ -534,13 +732,12 @@ let editPageModelTests = testList "EditPageModel" [
Expect.isFalse page.IsInPageList "IsInPageList should have been unset" Expect.isFalse page.IsInPageList "IsInPageList should have been unset"
Expect.equal page.Template (Some "bork") "Template not filled properly" Expect.equal page.Template (Some "bork") "Template not filled properly"
Expect.equal page.Text "<h1 id=\"howdy\">Howdy!</h1>\n" "Text not filled properly" Expect.equal page.Text "<h1 id=\"howdy\">Howdy!</h1>\n" "Text not filled properly"
Expect.equal page.Metadata.Length 2 "There should be 2 metadata items" Expect.equal page.OpenGraph testFullPage.OpenGraph "OpenGraph properties should be unchanged"
let item1 = List.item 0 page.Metadata Expect.hasLength page.Metadata 2 "There should be 2 metadata items"
Expect.equal item1.Name "Test" "Meta item 0 name not filled properly" Expect.equal
Expect.equal item1.Value "me" "Meta item 0 value not filled properly" page.Metadata
let item2 = List.item 1 page.Metadata [ { Name = "Test"; Value = "me" }; { Name = "Two"; Value = "2" } ]
Expect.equal item2.Name "Two" "Meta item 1 name not filled properly" "Metadata not filled properly"
Expect.equal item2.Value "2" "Meta item 1 value not filled properly"
Expect.equal page.Revisions.Length 2 "There should be 2 revisions" Expect.equal page.Revisions.Length 2 "There should be 2 revisions"
let rev1 = List.item 0 page.Revisions let rev1 = List.item 0 page.Revisions
Expect.equal rev1.AsOf (Noda.epoch + Duration.FromHours 1) "Revision 0 as-of not filled properly" Expect.equal rev1.AsOf (Noda.epoch + Duration.FromHours 1) "Revision 0 as-of not filled properly"
@@ -558,6 +755,7 @@ let editPageModelTests = testList "EditPageModel" [
model.IsShownInPageList <- false model.IsShownInPageList <- false
model.Source <- "HTML" model.Source <- "HTML"
model.Text <- "<h1>Howdy, partners!</h1>" model.Text <- "<h1>Howdy, partners!</h1>"
model.AssignOpenGraph <- false
model.MetaNames <- [| "banana"; "apple"; "grape" |] model.MetaNames <- [| "banana"; "apple"; "grape" |]
model.MetaValues <- [| "monkey"; "zebra"; "ape" |] model.MetaValues <- [| "monkey"; "zebra"; "ape" |]
let now = Noda.epoch + Duration.FromDays 7 let now = Noda.epoch + Duration.FromDays 7
@@ -569,16 +767,14 @@ let editPageModelTests = testList "EditPageModel" [
Expect.isFalse page.IsInPageList "IsInPageList should not have been set" Expect.isFalse page.IsInPageList "IsInPageList should not have been set"
Expect.isNone page.Template "Template not filled properly" Expect.isNone page.Template "Template not filled properly"
Expect.equal page.Text "<h1>Howdy, partners!</h1>" "Text not filled properly" Expect.equal page.Text "<h1>Howdy, partners!</h1>" "Text not filled properly"
Expect.isNone page.OpenGraph "OpenGraph properties not cleared properly"
Expect.equal page.Metadata.Length 3 "There should be 3 metadata items" Expect.equal page.Metadata.Length 3 "There should be 3 metadata items"
let item1 = List.item 0 page.Metadata Expect.equal
Expect.equal item1.Name "apple" "Meta item 0 name not filled properly" page.Metadata
Expect.equal item1.Value "zebra" "Meta item 0 value not filled properly" [ { Name = "apple"; Value = "zebra" }
let item2 = List.item 1 page.Metadata { Name = "banana"; Value = "monkey" }
Expect.equal item2.Name "banana" "Meta item 1 name not filled properly" { Name = "grape"; Value = "ape" } ]
Expect.equal item2.Value "monkey" "Meta item 1 value not filled properly" "Metadata not filled properly"
let item3 = List.item 2 page.Metadata
Expect.equal item3.Name "grape" "Meta item 2 name not filled properly"
Expect.equal item3.Value "ape" "Meta item 2 value not filled properly"
Expect.equal page.Revisions.Length 3 "There should be 3 revisions" Expect.equal page.Revisions.Length 3 "There should be 3 revisions"
Expect.equal page.Revisions.Head.AsOf now "Head revision as-of not filled properly" Expect.equal page.Revisions.Head.AsOf now "Head revision as-of not filled properly"
Expect.equal Expect.equal
@@ -593,6 +789,7 @@ let editPostModelTests = testList "EditPostModel" [
test "succeeds for empty post" { test "succeeds for empty post" {
let model = EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "la-la-la" } let model = EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "la-la-la" }
Expect.equal model.Id "la-la-la" "Parent fields not filled properly" Expect.equal model.Id "la-la-la" "Parent fields not filled properly"
Expect.isFalse model.AssignOpenGraph "OpenGraph properties should not be assigned"
Expect.equal model.Tags "" "Tags not filled properly" Expect.equal model.Tags "" "Tags not filled properly"
Expect.isEmpty model.CategoryIds "CategoryIds not filled properly" Expect.isEmpty model.CategoryIds "CategoryIds not filled properly"
Expect.equal model.Status (string Draft) "Status not filled properly" Expect.equal model.Status (string Draft) "Status not filled properly"
@@ -624,6 +821,7 @@ let editPostModelTests = testList "EditPostModel" [
test "succeeds for full post with external chapters" { test "succeeds for full post with external chapters" {
let model = EditPostModel.FromPost { WebLog.Empty with TimeZone = "Etc/GMT+1" } testFullPost let model = EditPostModel.FromPost { WebLog.Empty with TimeZone = "Etc/GMT+1" } testFullPost
Expect.equal model.Id "a-post" "Parent fields not filled properly" Expect.equal model.Id "a-post" "Parent fields not filled properly"
Expect.isTrue model.AssignOpenGraph "OpenGraph properties should have been assigned"
Expect.equal model.Tags "demo, post" "Tags not filled properly" Expect.equal model.Tags "demo, post" "Tags not filled properly"
Expect.equal model.CategoryIds [| "cat-a"; "cat-b"; "cat-n" |] "CategoryIds not filled properly" Expect.equal model.CategoryIds [| "cat-a"; "cat-b"; "cat-n" |] "CategoryIds not filled properly"
Expect.equal model.Status (string Published) "Status not filled properly" Expect.equal model.Status (string Published) "Status not filled properly"
@@ -679,6 +877,7 @@ let editPostModelTests = testList "EditPostModel" [
model.Tags <- "Zebras, Aardvarks, , Turkeys" model.Tags <- "Zebras, Aardvarks, , Turkeys"
model.Template <- "updated" model.Template <- "updated"
model.CategoryIds <- [| "cat-x"; "cat-y" |] model.CategoryIds <- [| "cat-x"; "cat-y" |]
model.AssignOpenGraph <- false
model.MetaNames <- [| "Zed Meta"; "A Meta" |] model.MetaNames <- [| "Zed Meta"; "A Meta" |]
model.MetaValues <- [| "A Value"; "Zed Value" |] model.MetaValues <- [| "A Value"; "Zed Value" |]
model.Media <- "an-updated-ep.mp3" model.Media <- "an-updated-ep.mp3"
@@ -711,11 +910,12 @@ let editPostModelTests = testList "EditPostModel" [
Expect.equal post.Tags [ "aardvarks"; "turkeys"; "zebras" ] "Tags not filled properly" Expect.equal post.Tags [ "aardvarks"; "turkeys"; "zebras" ] "Tags not filled properly"
Expect.equal post.Template (Some "updated") "Template not filled properly" Expect.equal post.Template (Some "updated") "Template not filled properly"
Expect.equal post.CategoryIds [ CategoryId "cat-x"; CategoryId "cat-y" ] "Categories not filled properly" Expect.equal post.CategoryIds [ CategoryId "cat-x"; CategoryId "cat-y" ] "Categories not filled properly"
Expect.equal post.Metadata.Length 2 "There should have been 2 meta items" Expect.isNone post.OpenGraph "OpenGraph properties should have been cleared"
Expect.equal post.Metadata[0].Name "A Meta" "Meta item 0 name not filled properly" Expect.hasLength post.Metadata 2 "There should have been 2 meta items"
Expect.equal post.Metadata[0].Value "Zed Value" "Meta item 0 value not filled properly" Expect.equal
Expect.equal post.Metadata[1].Name "Zed Meta" "Meta item 1 name not filled properly" post.Metadata
Expect.equal post.Metadata[1].Value "A Value" "Meta item 1 value not filled properly" [ { Name = "A Meta"; Value = "Zed Value" }; { Name = "Zed Meta"; Value = "A Value" } ]
"Metadata not filled properly"
Expect.equal post.Revisions.Length 3 "There should have been 3 revisions" Expect.equal post.Revisions.Length 3 "There should have been 3 revisions"
Expect.equal Expect.equal
post.Revisions[0].AsOf (Noda.epoch + Duration.FromDays 400) "Revision 0 AsOf not filled properly" post.Revisions[0].AsOf (Noda.epoch + Duration.FromDays 400) "Revision 0 AsOf not filled properly"
@@ -1157,13 +1357,14 @@ let settingsModelTests = testList "SettingsModel" [
let model = let model =
SettingsModel.FromWebLog SettingsModel.FromWebLog
{ WebLog.Empty with { WebLog.Empty with
Name = "The Web Log" Name = "The Web Log"
Slug = "the-web-log" Slug = "the-web-log"
DefaultPage = "this-one" DefaultPage = "this-one"
PostsPerPage = 18 PostsPerPage = 18
TimeZone = "America/Denver" TimeZone = "America/Denver"
ThemeId = ThemeId "my-theme" ThemeId = ThemeId "my-theme"
AutoHtmx = true } AutoHtmx = AutoHtmx
AutoOpenGraph = false }
Expect.equal model.Name "The Web Log" "Name not filled properly" Expect.equal model.Name "The Web Log" "Name not filled properly"
Expect.equal model.Slug "the-web-log" "Slug not filled properly" Expect.equal model.Slug "the-web-log" "Slug not filled properly"
Expect.equal model.Subtitle "" "Subtitle not filled properly" Expect.equal model.Subtitle "" "Subtitle not filled properly"
@@ -1171,8 +1372,9 @@ let settingsModelTests = testList "SettingsModel" [
Expect.equal model.PostsPerPage 18 "PostsPerPage not filled properly" Expect.equal model.PostsPerPage 18 "PostsPerPage not filled properly"
Expect.equal model.TimeZone "America/Denver" "TimeZone not filled properly" Expect.equal model.TimeZone "America/Denver" "TimeZone not filled properly"
Expect.equal model.ThemeId "my-theme" "ThemeId not filled properly" Expect.equal model.ThemeId "my-theme" "ThemeId not filled properly"
Expect.isTrue model.AutoHtmx "AutoHtmx should have been set" Expect.equal model.AutoHtmx (string AutoHtmx) "AutoHtmx should have been set"
Expect.equal model.Uploads "Database" "Uploads not filled properly" Expect.equal model.Uploads "Database" "Uploads not filled properly"
Expect.isFalse model.AutoOpenGraph "AutoOpenGraph should have been unset"
} }
test "succeeds with a subtitle" { test "succeeds with a subtitle" {
let model = SettingsModel.FromWebLog { WebLog.Empty with Subtitle = Some "sub here!" } let model = SettingsModel.FromWebLog { WebLog.Empty with Subtitle = Some "sub here!" }
@@ -1182,15 +1384,16 @@ let settingsModelTests = testList "SettingsModel" [
testList "Update" [ testList "Update" [
test "succeeds with no subtitle" { test "succeeds with no subtitle" {
let webLog = let webLog =
{ Name = "Interesting" { Name = "Interesting"
Slug = "some-stuff" Slug = "some-stuff"
Subtitle = "" Subtitle = ""
DefaultPage = "that-one" DefaultPage = "that-one"
PostsPerPage = 8 PostsPerPage = 8
TimeZone = "America/Chicago" TimeZone = "America/Chicago"
ThemeId = "test-theme" ThemeId = "test-theme"
AutoHtmx = true AutoHtmx = (string AutoHtmax)
Uploads = "Disk" }.Update WebLog.Empty Uploads = "Disk"
AutoOpenGraph = false }.Update WebLog.Empty
Expect.equal webLog.Name "Interesting" "Name not filled properly" Expect.equal webLog.Name "Interesting" "Name not filled properly"
Expect.equal webLog.Slug "some-stuff" "Slug not filled properly" Expect.equal webLog.Slug "some-stuff" "Slug not filled properly"
Expect.isNone webLog.Subtitle "Subtitle should not have had a value" Expect.isNone webLog.Subtitle "Subtitle should not have had a value"
@@ -1198,8 +1401,9 @@ let settingsModelTests = testList "SettingsModel" [
Expect.equal webLog.PostsPerPage 8 "PostsPerPage not filled properly" Expect.equal webLog.PostsPerPage 8 "PostsPerPage not filled properly"
Expect.equal webLog.TimeZone "America/Chicago" "TimeZone not filled properly" Expect.equal webLog.TimeZone "America/Chicago" "TimeZone not filled properly"
Expect.equal webLog.ThemeId (ThemeId "test-theme") "ThemeId not filled properly" Expect.equal webLog.ThemeId (ThemeId "test-theme") "ThemeId not filled properly"
Expect.isTrue webLog.AutoHtmx "AutoHtmx should have been set" Expect.equal webLog.AutoHtmx AutoHtmax "AutoHtmx should have been set"
Expect.equal webLog.Uploads Disk "Uploads not filled properly" Expect.equal webLog.Uploads Disk "Uploads not filled properly"
Expect.isFalse webLog.AutoOpenGraph "AutoOpenGraph should have been unset"
} }
test "succeeds with a subtitle" { test "succeeds with a subtitle" {
let webLog = { SettingsModel.FromWebLog WebLog.Empty with Subtitle = "Sub" }.Update WebLog.Empty let webLog = { SettingsModel.FromWebLog WebLog.Empty with Subtitle = "Sub" }.Update WebLog.Empty
+3 -3
View File
@@ -26,9 +26,9 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Expecto" Version="10.2.1" /> <PackageReference Include="Expecto" />
<PackageReference Include="ThrowawayDb.Postgres" Version="1.4.0" /> <PackageReference Include="FSharp.Core" />
<PackageReference Update="FSharp.Core" Version="8.0.300" /> <PackageReference Include="ThrowawayDb.Postgres" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
+11 -12
View File
@@ -10,20 +10,19 @@ let sqliteOnly = (RethinkDbDataTests.env "SQLITE_ONLY" "0") = "1"
let postgresOnly = (RethinkDbDataTests.env "PG_ONLY" "0") = "1" let postgresOnly = (RethinkDbDataTests.env "PG_ONLY" "0") = "1"
/// Whether any of the data tests are being isolated /// Whether any of the data tests are being isolated
let dbOnly = rethinkOnly || sqliteOnly || postgresOnly let allDatabases = not (rethinkOnly || sqliteOnly || postgresOnly)
/// Whether to only run the unit tests (skip database/integration tests)
let unitOnly = (RethinkDbDataTests.env "UNIT_ONLY" "0") = "1"
let allTests = testList "MyWebLog" [ let allTests = testList "MyWebLog" [
if not dbOnly then testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] // Skip unit tests if running an isolated database test
if not unitOnly then if allDatabases then
testList "Data" [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ]
if not dbOnly then ConvertersTests.all testList "Data (Unit)" [ ConvertersTests.all; UtilsTests.all ]
if not dbOnly then UtilsTests.all // Whether to skip integration tests
if not dbOnly || (dbOnly && rethinkOnly) then RethinkDbDataTests.all if RethinkDbDataTests.env "UNIT_ONLY" "0" <> "1" then
if not dbOnly || (dbOnly && sqliteOnly) then SQLiteDataTests.all testList "Data (Integration)" [
if not dbOnly || (dbOnly && postgresOnly) then PostgresDataTests.all if allDatabases || rethinkOnly then RethinkDbDataTests.all
if allDatabases || sqliteOnly then SQLiteDataTests.all
if allDatabases || postgresOnly then PostgresDataTests.all
] ]
] ]
+1 -1
View File
@@ -41,7 +41,7 @@
} }
] ]
}, },
"AutoHtmx": true, "AutoHtmx": "Yes",
"Uploads": "Database", "Uploads": "Database",
"RedirectRules": [] "RedirectRules": []
}, },
-43
View File
@@ -1,43 +0,0 @@
Microsoft Visual Studio Solution File, Format Version 12.00
# Visual Studio Version 17
VisualStudioVersion = 17.1.32210.238
MinimumVisualStudioVersion = 10.0.40219.1
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "MyWebLog.Domain", "MyWebLog.Domain\MyWebLog.Domain.fsproj", "{8CA99122-888A-4524-8C1B-685F0A4B7B4B}"
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "MyWebLog.Data", "MyWebLog.Data\MyWebLog.Data.fsproj", "{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "MyWebLog", "MyWebLog\MyWebLog.fsproj", "{5655B63D-429F-4CCD-A14C-FBD74D987ECB}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "MyWebLog.Tests", "MyWebLog.Tests\MyWebLog.Tests.fsproj", "{D927D39F-26EC-4A54-989A-9D474F232398}"
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution
Debug|Any CPU = Debug|Any CPU
Release|Any CPU = Release|Any CPU
EndGlobalSection
GlobalSection(ProjectConfigurationPlatforms) = postSolution
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Debug|Any CPU.Build.0 = Debug|Any CPU
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Release|Any CPU.ActiveCfg = Release|Any CPU
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Release|Any CPU.Build.0 = Release|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Debug|Any CPU.Build.0 = Debug|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Release|Any CPU.ActiveCfg = Release|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Release|Any CPU.Build.0 = Release|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Debug|Any CPU.Build.0 = Debug|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Release|Any CPU.ActiveCfg = Release|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Release|Any CPU.Build.0 = Release|Any CPU
{D927D39F-26EC-4A54-989A-9D474F232398}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{D927D39F-26EC-4A54-989A-9D474F232398}.Debug|Any CPU.Build.0 = Debug|Any CPU
{D927D39F-26EC-4A54-989A-9D474F232398}.Release|Any CPU.ActiveCfg = Release|Any CPU
{D927D39F-26EC-4A54-989A-9D474F232398}.Release|Any CPU.Build.0 = Release|Any CPU
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
SolutionGuid = {70EEF0F4-8709-44A8-AD9B-24D1EB84CFB4}
EndGlobalSection
EndGlobal
+6
View File
@@ -0,0 +1,6 @@
<Solution>
<Project Path="MyWebLog.Data/MyWebLog.Data.fsproj" />
<Project Path="MyWebLog.Domain/MyWebLog.Domain.fsproj" />
<Project Path="MyWebLog.Tests/MyWebLog.Tests.fsproj" />
<Project Path="MyWebLog/MyWebLog.fsproj" />
</Solution>
+78 -116
View File
@@ -3,7 +3,7 @@
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open MyWebLog.Data open MyWebLog.Data
/// Extension properties on HTTP context for web log /// <summary>Extension properties on HTTP context for web log</summary>
[<AutoOpen>] [<AutoOpen>]
module Extensions = module Extensions =
@@ -17,16 +17,16 @@ module Extensions =
type HttpContext with type HttpContext with
/// The anti-CSRF service /// <summary>The anti-CSRF service</summary>
member this.AntiForgery = this.RequestServices.GetRequiredService<IAntiforgery>() 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 member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this
/// The data implementation /// <summary>The data implementation</summary>
member this.Data = this.RequestServices.GetRequiredService<IData>() member this.Data = this.RequestServices.GetRequiredService<IData>()
/// The generator string /// <summary>The generator string</summary>
member this.Generator = member this.Generator =
match generatorString with match generatorString with
| Some gen -> gen | Some gen -> gen
@@ -38,20 +38,22 @@ module Extensions =
| None -> Some "generator not configured" | None -> Some "generator not configured"
generatorString.Value generatorString.Value
/// The access level for the current user /// <summary>The access level for the current user</summary>
member this.UserAccessLevel = member this.UserAccessLevel =
this.User.Claims this.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.Role) |> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.Role)
|> Option.map (fun claim -> AccessLevel.Parse claim.Value) |> 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 = member this.UserId =
WebLogUserId (this.User.Claims |> Seq.find (fun c -> c.Type = ClaimTypes.NameIdentifier)).Value 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 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 = member this.HasAccessLevel level =
defaultArg (this.UserAccessLevel |> Option.map _.HasAccess(level)) false defaultArg (this.UserAccessLevel |> Option.map _.HasAccess(level)) false
@@ -67,27 +69,30 @@ module WebLogCache =
open System.Text.RegularExpressions 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 = type CachedRedirectRule =
/// A straight text match rule /// <summary>A straight text match rule</summary>
| Text of string * string | Text of string * string
/// A regular expression match rule /// <summary>A regular expression match rule</summary>
| RegEx of Regex * string | RegEx of Regex * string
/// The cache of web log details /// The cache of web log details
let mutable private _cache : WebLog list = [] let mutable private _cache: WebLog list = []
/// Redirect rules with compiled regular expressions /// 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) /// <summary>Try to get the web log for the current request (longest matching URL base wins)</summary>
let tryGet (path : string) = /// <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 _cache
|> List.filter (fun wl -> path.StartsWith wl.UrlBase) |> List.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending _.UrlBase.Length |> List.sortByDescending _.UrlBase.Length
|> List.tryHead |> 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 = let set webLog =
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.Id <> webLog.Id)) _cache <- webLog :: (_cache |> List.filter (fun wl -> wl.Id <> webLog.Id))
_redirectCache[webLog.Id] <- _redirectCache[webLog.Id] <-
@@ -96,170 +101,127 @@ module WebLogCache =
let relUrl = Permalink >> webLog.RelativeUrl let relUrl = Permalink >> webLog.RelativeUrl
let urlTo = if it.To.Contains "://" then it.To else relUrl it.To let urlTo = if it.To.Contains "://" then it.To else relUrl it.To
if it.IsRegex then if it.IsRegex then
let pattern = if it.From.StartsWith "^" then $"^{relUrl it.From[1..]}" else it.From RegEx(Regex(it.From, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo)
RegEx(Regex(pattern, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo)
else else
Text(relUrl it.From, urlTo)) Text(it.From, urlTo))
/// Get all cached web logs /// <summary>Get all cached web logs</summary>
/// <returns>All cached web logs</returns>
let all () = let all () =
_cache _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 fill (data: IData) = backgroundTask {
let! webLogs = data.WebLog.All() let! webLogs = data.WebLog.All()
webLogs |> List.iter set 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 = let redirectRules webLogId =
_redirectCache[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 = let isThemeInUse themeId =
_cache |> List.exists (fun wl -> wl.ThemeId = 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 = module PageListCache =
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// Cache of displayed pages /// 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 = let private fillPages (webLog: WebLog) pages =
_cache[webLog.Id] <- _cache[webLog.Id] <-
pages pages
|> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" }) |> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" })
|> Array.ofList |> 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 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] let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the pages for the current web log /// <summary>Refresh the pages for the given web log</summary>
let update (ctx: HttpContext) = backgroundTask { /// <param name="webLog">The web log for which pages should be refreshed</param>
let! pages = ctx.Data.Page.FindListed ctx.WebLog.Id /// <param name="data">The data implementation from which pages should be retrieved</param>
fillPages ctx.WebLog pages
}
/// Refresh the pages for the given web log
let refresh (webLog: WebLog) (data: IData) = backgroundTask { let refresh (webLog: WebLog) (data: IData) = backgroundTask {
let! pages = data.Page.FindListed webLog.Id let! pages = data.Page.FindListed webLog.Id
fillPages webLog pages 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 = module CategoryCache =
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// The cache itself /// The cache itself
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array> () let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array>()
/// Are there categories cached for this web log? /// <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 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] let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the cache with fresh data /// <summary>Refresh the category cache for the given web log</summary>
let update (ctx: HttpContext) = backgroundTask { /// <param name="webLogId">The ID of the web log for which the cache should be refreshed</param>
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id /// <param name="data">The data implementation from which categories should be retrieved</param>
_cache[ctx.WebLog.Id] <- cats
}
/// Refresh the category cache for the given web log
let refresh webLogId (data: IData) = backgroundTask { let refresh webLogId (data: IData) = backgroundTask {
let! cats = data.Category.FindAllForView webLogId let! cats = data.Category.FindAllForView webLogId
_cache[webLogId] <- cats _cache[webLogId] <- cats
} }
/// <summary>Update the cache with fresh data for the current web log</summary>
/// Cache for parsed templates /// <param name="ctx">The <c>HttpContext</c> for the current request</param>
module TemplateCache = let update (ctx: HttpContext) =
refresh ctx.WebLog.Id ctx.Data
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()
/// A cache of asset names by themes /// <summary>A cache of asset names by themes</summary>
module ThemeAssetCache = module ThemeAssetCache =
/// A list of asset names for each theme /// A list of asset names for each theme
let private _cache = ConcurrentDictionary<ThemeId, string list> () let private _cache = ConcurrentDictionary<ThemeId, string list>()
/// Retrieve the assets for the given theme ID /// <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] 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 refreshTheme themeId (data: IData) = backgroundTask {
let! assets = data.ThemeAsset.FindByTheme themeId let! assets = data.ThemeAsset.FindByTheme themeId
_cache[themeId] <- assets |> List.map (fun a -> match a.Id with ThemeAssetId (_, path) -> path) _cache[themeId] <- assets |> List.map (fun a -> match a.Id with ThemeAssetId (_, path) -> path)
} }
/// Fill the theme asset cache /// <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 fill (data: IData) = backgroundTask {
let! assets = data.ThemeAsset.All() let! assets = data.ThemeAsset.All()
for asset in assets do for asset in assets do
-237
View File
@@ -1,237 +0,0 @@
/// Custom DotLiquid filters and tags
module MyWebLog.DotLiquidBespoke
open System
open System.IO
open System.Web
open DotLiquid
open Giraffe.ViewEngine
open MyWebLog.ViewModels
open MyWebLog.Views
/// Extensions on the DotLiquid Context object
type Context with
/// Get the current web log from the DotLiquid context
member this.WebLog =
this.Environments[0].["web_log"] :?> WebLog
/// Does an asset exist for the current theme?
let assetExists fileName (webLog: WebLog) =
ThemeAssetCache.get webLog.ThemeId |> List.exists (fun it -> it = fileName)
/// Obtain the link from known types
let permalink (item: obj) (linkFunc: Permalink -> string) =
match item with
| :? String as link -> Some link
| :? DisplayPage as page -> Some page.Permalink
| :? PostListItem as post -> Some post.Permalink
| :? DropProxy as proxy -> Option.ofObj proxy["Permalink"] |> Option.map string
| _ -> None
|> function
| Some link -> linkFunc (Permalink link)
| None -> $"alert('unknown item type {item.GetType().Name}')"
/// A filter to generate an absolute link
type AbsoluteLinkFilter() =
static member AbsoluteLink(ctx: Context, item: obj) =
permalink item ctx.WebLog.AbsoluteUrl
/// A filter to generate a link with posts categorized under the given category
type CategoryLinkFilter() =
static member CategoryLink(ctx: Context, catObj: obj) =
match catObj with
| :? DisplayCategory as cat -> Some cat.Slug
| :? DropProxy as proxy -> Option.ofObj proxy["Slug"] |> Option.map string
| _ -> None
|> function
| Some slug -> ctx.WebLog.RelativeUrl(Permalink $"category/{slug}/")
| None -> $"alert('unknown category object type {catObj.GetType().Name}')"
/// A filter to generate a link that will edit a page
type EditPageLinkFilter() =
static member EditPageLink(ctx: Context, pageObj: obj) =
match pageObj with
| :? DisplayPage as page -> Some page.Id
| :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some pageId -> ctx.WebLog.RelativeUrl(Permalink $"admin/page/{pageId}/edit")
| None -> $"alert('unknown page object type {pageObj.GetType().Name}')"
/// A filter to generate a link that will edit a post
type EditPostLinkFilter() =
static member EditPostLink(ctx: Context, postObj: obj) =
match postObj with
| :? PostListItem as post -> Some post.Id
| :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some postId -> ctx.WebLog.RelativeUrl(Permalink $"admin/post/{postId}/edit")
| None -> $"alert('unknown post object type {postObj.GetType().Name}')"
/// A filter to generate nav links, highlighting the active link (exact match)
type NavLinkFilter() =
static member NavLink(ctx: Context, url: string, text: string) =
let extraPath = ctx.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
seq {
"<li class=nav-item><a class=\"nav-link"
if (string ctx.Environments[0].["current_page"]).StartsWith $"{path}{url}" then " active"
"\" href=\""
ctx.WebLog.RelativeUrl(Permalink url)
"\">"
text
"</a>"
}
|> String.concat ""
/// A filter to generate a link for theme asset (image, stylesheet, script, etc.)
type ThemeAssetFilter() =
static member ThemeAsset(ctx: Context, asset: string) =
ctx.WebLog.RelativeUrl(Permalink $"themes/{ctx.WebLog.ThemeId}/{asset}")
/// Create various items in the page header based on the state of the page being generated
type PageHeadTag() =
inherit Tag()
override this.Render(context: Context, result: TextWriter) =
let webLog = context.WebLog
// spacer
let s = " "
let getBool name =
defaultArg (context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean) false
result.WriteLine $"""<meta name=generator content="{context.Environments[0].["generator"]}">"""
// Theme assets
if assetExists "style.css" webLog then
result.WriteLine $"""{s}<link rel=stylesheet href="{ThemeAssetFilter.ThemeAsset(context, "style.css")}">"""
if assetExists "favicon.ico" webLog then
result.WriteLine $"""{s}<link rel=icon href="{ThemeAssetFilter.ThemeAsset(context, "favicon.ico")}">"""
// RSS feeds and canonical URLs
let feedLink title url =
let escTitle = HttpUtility.HtmlAttributeEncode title
let relUrl = webLog.RelativeUrl(Permalink url)
$"""{s}<link rel=alternate type="application/rss+xml" title="{escTitle}" href="{relUrl}">"""
if webLog.Rss.IsFeedEnabled && getBool "is_home" then
result.WriteLine(feedLink webLog.Name webLog.Rss.FeedName)
result.WriteLine $"""{s}<link rel=canonical href="{webLog.AbsoluteUrl Permalink.Empty}">"""
if webLog.Rss.IsCategoryEnabled && getBool "is_category_home" then
let slug = context.Environments[0].["slug"] :?> string
result.WriteLine(feedLink webLog.Name $"category/{slug}/{webLog.Rss.FeedName}")
if webLog.Rss.IsTagEnabled && getBool "is_tag_home" then
let slug = context.Environments[0].["slug"] :?> string
result.WriteLine(feedLink webLog.Name $"tag/{slug}/{webLog.Rss.FeedName}")
if getBool "is_post" then
let post = context.Environments[0].["model"] :?> PostDisplay
let url = webLog.AbsoluteUrl (Permalink post.Posts[0].Permalink)
result.WriteLine $"""{s}<link rel=canonical href="{url}">"""
if getBool "is_page" then
let page = context.Environments[0].["page"] :?> DisplayPage
let url = webLog.AbsoluteUrl (Permalink page.Permalink)
result.WriteLine $"""{s}<link rel=canonical href="{url}">"""
/// Create various items in the page header based on the state of the page being generated
type PageFootTag() =
inherit Tag()
override this.Render(context: Context, result: TextWriter) =
let webLog = context.WebLog
// spacer
let s = " "
if webLog.AutoHtmx then
result.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}"
if assetExists "script.js" webLog then
result.WriteLine $"""{s}<script src="{ThemeAssetFilter.ThemeAsset(context, "script.js")}"></script>"""
/// A filter to generate a relative link
type RelativeLinkFilter() =
static member RelativeLink(ctx: Context, item: obj) =
permalink item ctx.WebLog.RelativeUrl
/// A filter to generate a link with posts tagged with the given tag
type TagLinkFilter() =
static member TagLink(ctx: Context, tag: string) =
ctx.Environments[0].["tag_mappings"] :?> TagMap list
|> List.tryFind (fun it -> it.Tag = tag)
|> function
| Some tagMap -> tagMap.UrlValue
| None -> tag.Replace(" ", "+")
|> function tagUrl -> ctx.WebLog.RelativeUrl(Permalink $"tag/{tagUrl}/")
/// Create links for a user to log on or off, and a dashboard link if they are logged off
type UserLinksTag() =
inherit Tag()
override this.Render(context: Context, result: TextWriter) =
let link it = context.WebLog.RelativeUrl(Permalink it)
seq {
"""<ul class="navbar-nav flex-grow-1 justify-content-end">"""
match Convert.ToBoolean context.Environments[0].["is_logged_on"] 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 result.WriteLine
/// A filter to retrieve the value of a meta item from a list
// (shorter than `{% assign item = list | where: "Name", [name] | first %}{{ item.value }}`)
type ValueFilter() =
static member Value(_: Context, items: MetaItem list, name: string) =
match items |> List.tryFind (fun it -> it.Name = name) with
| Some item -> item.Value
| None -> $"-- {name} not found --"
open System.Collections.Generic
open Microsoft.AspNetCore.Antiforgery
/// Register custom filters/tags and safe types
let register () =
[ typeof<AbsoluteLinkFilter>; typeof<CategoryLinkFilter>; typeof<EditPageLinkFilter>; typeof<EditPostLinkFilter>
typeof<NavLinkFilter>; typeof<RelativeLinkFilter>; typeof<TagLinkFilter>; typeof<ThemeAssetFilter>
typeof<ValueFilter>
]
|> List.iter Template.RegisterFilter
Template.RegisterTag<PageHeadTag> "page_head"
Template.RegisterTag<PageFootTag> "page_foot"
Template.RegisterTag<UserLinksTag> "user_links"
[ // 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 (fun it -> Template.RegisterSafeType (it, [| "*" |]))
+370 -302
View File
@@ -12,30 +12,34 @@ open NodaTime
module Dashboard = module Dashboard =
// GET /admin/dashboard // GET /admin/dashboard
let user : HttpHandler = requireAccess Author >=> fun next ctx -> task { let user : HttpHandler =
let getCount (f: WebLogId -> Task<int>) = f ctx.WebLog.Id requireAccess Author
let data = ctx.Data >=> fun next ctx -> task {
let! posts = getCount (data.Post.CountByStatus Published) let getCount (f: WebLogId -> Task<int>) = f ctx.WebLog.Id
let! drafts = getCount (data.Post.CountByStatus Draft) let data = ctx.Data
let! pages = getCount data.Page.CountAll let! posts = getCount (data.Post.CountByStatus Published)
let! listed = getCount data.Page.CountListed let! drafts = getCount (data.Post.CountByStatus Draft)
let! cats = getCount data.Category.CountAll let! pages = getCount data.Page.CountAll
let! topCats = getCount data.Category.CountTopLevel let! listed = getCount data.Page.CountListed
let model = let! cats = getCount data.Category.CountAll
{ Posts = posts let! topCats = getCount data.Category.CountTopLevel
Drafts = drafts let model =
Pages = pages { Posts = posts
ListedPages = listed Drafts = drafts
Categories = cats Pages = pages
TopLevelCategories = topCats } ListedPages = listed
return! adminPage "Dashboard" false next ctx (Views.WebLog.dashboard model) Categories = cats
} TopLevelCategories = topCats }
return! adminPage "Dashboard" next ctx (Views.WebLog.dashboard model)
}
// GET /admin/administration // GET /admin/administration
let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let admin : HttpHandler =
let! themes = ctx.Data.Theme.All() requireAccess Administrator
return! adminPage "myWebLog Administration" true next ctx (Views.Admin.dashboard themes) >=> fun next ctx -> task {
} let! themes = ctx.Data.Theme.All()
return! adminPage "myWebLog Administration" next ctx (Views.Admin.dashboard themes)
}
/// Redirect the user to the admin dashboard /// Redirect the user to the admin dashboard
let toAdminDashboard : HttpHandler = redirectToGet "admin/administration" let toAdminDashboard : HttpHandler = redirectToGet "admin/administration"
@@ -45,49 +49,56 @@ let toAdminDashboard : HttpHandler = redirectToGet "admin/administration"
module Cache = module Cache =
// POST /admin/cache/web-log/{id}/refresh // POST /admin/cache/web-log/{id}/refresh
let refreshWebLog webLogId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let refreshWebLog webLogId : HttpHandler =
let data = ctx.Data requireAccess Administrator
if webLogId = "all" then >=> validateCsrf
do! WebLogCache.fill data >=> fun next ctx -> task {
for webLog in WebLogCache.all () do let data = ctx.Data
do! PageListCache.refresh webLog data if webLogId = "all" then
do! CategoryCache.refresh webLog.Id data do! WebLogCache.fill data
do! addMessage ctx for webLog in WebLogCache.all () do
{ UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" } do! PageListCache.refresh webLog data
else do! CategoryCache.refresh webLog.Id data
match! data.WebLog.FindById(WebLogId webLogId) with
| Some webLog ->
WebLogCache.set webLog
do! PageListCache.refresh webLog data
do! CategoryCache.refresh webLog.Id data
do! addMessage ctx do! addMessage ctx
{ UserMessage.Success with Message = $"Successfully refreshed web log cache for {webLog.Name}" } { UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" }
| None -> else
do! addMessage ctx { UserMessage.Error with Message = $"No web log exists with ID {webLogId}" } match! data.WebLog.FindById(WebLogId webLogId) with
return! toAdminDashboard next ctx | Some webLog ->
} WebLogCache.set webLog
do! PageListCache.refresh webLog data
do! CategoryCache.refresh webLog.Id data
do! addMessage ctx
{ UserMessage.Success with
Message = $"Successfully refreshed web log cache for {webLog.Name}" }
| None ->
do! addMessage ctx { UserMessage.Error with Message = $"No web log exists with ID {webLogId}" }
return! toAdminDashboard next ctx
}
// POST /admin/cache/theme/{id}/refresh // POST /admin/cache/theme/{id}/refresh
let refreshTheme themeId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let refreshTheme themeId : HttpHandler =
let data = ctx.Data requireAccess Administrator
if themeId = "all" then >=> validateCsrf
TemplateCache.empty () >=> fun next ctx -> task {
do! ThemeAssetCache.fill data let data = ctx.Data
do! addMessage ctx if themeId = "all" then
{ UserMessage.Success with Template.Cache.empty ()
Message = "Successfully cleared template cache and refreshed theme asset cache" } do! ThemeAssetCache.fill data
else
match! data.Theme.FindById(ThemeId themeId) with
| Some theme ->
TemplateCache.invalidateTheme theme.Id
do! ThemeAssetCache.refreshTheme theme.Id data
do! addMessage ctx do! addMessage ctx
{ UserMessage.Success with { UserMessage.Success with
Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}" } Message = "Successfully cleared template cache and refreshed theme asset cache" }
| None -> else
do! addMessage ctx { UserMessage.Error with Message = $"No theme exists with ID {themeId}" } match! data.Theme.FindById(ThemeId themeId) with
return! toAdminDashboard next ctx | Some theme ->
} Template.Cache.invalidateTheme theme.Id
do! ThemeAssetCache.refreshTheme theme.Id data
do! addMessage ctx
{ UserMessage.Success with
Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}" }
| None ->
do! addMessage ctx { UserMessage.Error with Message = $"No theme exists with ID {themeId}" }
return! toAdminDashboard next ctx
}
/// ~~~ CATEGORIES ~~~ /// ~~~ CATEGORIES ~~~
@@ -96,68 +107,78 @@ module Category =
open MyWebLog.Data open MyWebLog.Data
// GET /admin/categories // GET /admin/categories
let all : HttpHandler = fun next ctx -> let all : HttpHandler =
let response = fun next ctx -> requireAccess WebLogAdmin
adminPage "Categories" true next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new")) >=> fun next ctx ->
(withHxPushUrl (ctx.WebLog.RelativeUrl (Permalink "admin/categories")) >=> response) next ctx let response = fun next ctx ->
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 // GET /admin/category/{id}/edit
let edit catId : HttpHandler = fun next ctx -> task { let edit catId : HttpHandler =
let! result = task { requireAccess WebLogAdmin
match catId with >=> fun next ctx -> task {
| "new" -> return Some ("Add a New Category", { Category.Empty with Id = CategoryId "new" }) let! result = task {
| _ -> match catId with
match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with | "new" -> return Some ("Add a New Category", { Category.Empty with Id = CategoryId "new" })
| Some cat -> return Some ("Edit Category", cat) | _ ->
| None -> return None match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with
| Some cat -> return Some ("Edit Category", cat)
| None -> return None
}
match result with
| Some (title, cat) ->
return!
Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat)
|> adminBarePage title next ctx
| None -> return! Error.notFound next ctx
} }
match result with
| Some (title, cat) ->
return!
Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat)
|> adminBarePage title true next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/save // POST /admin/category/save
let save : HttpHandler = fun next ctx -> task { let save : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
let! model = ctx.BindFormAsync<EditCategoryModel>() >=> validateCsrf
let category = >=> fun next ctx -> task {
if model.IsNew then someTask { Category.Empty with Id = CategoryId.Create(); WebLogId = ctx.WebLog.Id } let data = ctx.Data
else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id let! model = ctx.BindFormAsync<EditCategoryModel>()
match! category with let category =
| Some cat -> if model.IsNew then someTask { Category.Empty with Id = CategoryId.Create(); WebLogId = ctx.WebLog.Id }
let updatedCat = else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id
{ cat with match! category with
Name = model.Name | Some cat ->
Slug = model.Slug let updatedCat =
Description = if model.Description = "" then None else Some model.Description { cat with
ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId) } Name = model.Name
do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat Slug = model.Slug
do! CategoryCache.update ctx Description = if model.Description = "" then None else Some model.Description
do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" } ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId) }
return! all next ctx do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat
| None -> return! Error.notFound next ctx do! CategoryCache.update ctx
} do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" }
return! all next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/category/{id} // DELETE /admin/category/{id}
let delete catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let delete catId : HttpHandler =
let! result = ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id requireAccess WebLogAdmin
match result with >=> fun next ctx -> task {
| CategoryDeleted let! result = ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id
| ReassignedChildCategories -> match result with
do! CategoryCache.update ctx | CategoryDeleted
let detail = | ReassignedChildCategories ->
match result with do! CategoryCache.update ctx
| ReassignedChildCategories -> let detail =
Some "<em>(Its child categories were reassigned to its parent category)</em>" match result with
| _ -> None | ReassignedChildCategories ->
do! addMessage ctx { UserMessage.Success with Message = "Category deleted successfully"; Detail = detail } Some "<em>(Its child categories were reassigned to its parent category)</em>"
| CategoryNotFound -> | _ -> None
do! addMessage ctx { UserMessage.Error with Message = "Category not found; cannot delete" } do! addMessage
return! all next ctx ctx { UserMessage.Success with Message = "Category deleted successfully"; Detail = detail }
} | CategoryNotFound ->
do! addMessage ctx { UserMessage.Error with Message = "Category not found; cannot delete" }
return! all next ctx
}
/// ~~~ REDIRECT RULES ~~~ /// ~~~ REDIRECT RULES ~~~
@@ -166,24 +187,28 @@ module RedirectRules =
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
// GET /admin/settings/redirect-rules // GET /admin/settings/redirect-rules
let all : HttpHandler = fun next ctx -> let all : HttpHandler =
adminPage "Redirect Rules" true next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules) requireAccess WebLogAdmin
>=> fun next ctx ->
adminPage "Redirect Rules" next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules)
// GET /admin/settings/redirect-rules/[index] // GET /admin/settings/redirect-rules/[index]
let edit idx : HttpHandler = fun next ctx -> let edit idx : HttpHandler =
let titleAndView = requireAccess WebLogAdmin
if idx = -1 then >=> fun next ctx ->
Some ("Add", Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty)) let titleAndView =
else if idx = -1 then
let rules = ctx.WebLog.RedirectRules Some ("Add", Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty))
if rules.Length < idx || idx < 0 then
None
else else
Some let rules = ctx.WebLog.RedirectRules
("Edit", (Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules)))) if rules.Length < idx || idx < 0 then
match titleAndView with None
| Some (title, view) -> adminBarePage $"{title} Redirect Rule" true next ctx view else
| None -> Error.notFound next ctx Some ("Edit",
Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules)))
match titleAndView with
| 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 /// Update the web log's redirect rules in the database, the request web log, and the web log cache
let private updateRedirectRules (ctx: HttpContext) webLog = backgroundTask { let private updateRedirectRules (ctx: HttpContext) webLog = backgroundTask {
@@ -193,99 +218,119 @@ module RedirectRules =
} }
// POST /admin/settings/redirect-rules/[index] // POST /admin/settings/redirect-rules/[index]
let save idx : HttpHandler = fun next ctx -> task { let save idx : HttpHandler =
let! model = ctx.BindFormAsync<EditRedirectRuleModel>() requireAccess WebLogAdmin
let rule = model.ToRule() >=> validateCsrf
let rules = >=> fun next ctx -> task {
ctx.WebLog.RedirectRules let! model = ctx.BindFormAsync<EditRedirectRuleModel>()
|> match idx with let rule = model.ToRule()
| -1 when model.InsertAtTop -> List.insertAt 0 rule let rules =
| -1 -> List.insertAt ctx.WebLog.RedirectRules.Length rule ctx.WebLog.RedirectRules
| _ -> List.removeAt idx >> List.insertAt idx rule |> match idx with
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules } | -1 when model.InsertAtTop -> List.insertAt 0 rule
do! addMessage ctx { UserMessage.Success with Message = "Redirect rule saved successfully" } | -1 -> List.insertAt ctx.WebLog.RedirectRules.Length rule
return! all next ctx | _ -> List.removeAt idx >> List.insertAt idx rule
} do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules }
do! addMessage ctx { UserMessage.Success with Message = "Redirect rule saved successfully" }
return! all next ctx
}
// POST /admin/settings/redirect-rules/[index]/up // POST /admin/settings/redirect-rules/[index]/up
let moveUp idx : HttpHandler = fun next ctx -> task { let moveUp idx : HttpHandler =
if idx < 1 || idx >= ctx.WebLog.RedirectRules.Length then requireAccess WebLogAdmin
return! Error.notFound next ctx >=> validateCsrf
else >=> fun next ctx -> task {
let toMove = List.item idx ctx.WebLog.RedirectRules if idx < 1 || idx >= ctx.WebLog.RedirectRules.Length then
let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx - 1) toMove return! Error.notFound next ctx
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } else
return! all next ctx let toMove = List.item idx ctx.WebLog.RedirectRules
} let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx - 1) toMove
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules }
return! all next ctx
}
// POST /admin/settings/redirect-rules/[index]/down // POST /admin/settings/redirect-rules/[index]/down
let moveDown idx : HttpHandler = fun next ctx -> task { let moveDown idx : HttpHandler =
if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length - 1 then requireAccess WebLogAdmin
return! Error.notFound next ctx >=> validateCsrf
else >=> fun next ctx -> task {
let toMove = List.item idx ctx.WebLog.RedirectRules if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length - 1 then
let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx + 1) toMove return! Error.notFound next ctx
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } else
return! all next ctx let toMove = List.item idx ctx.WebLog.RedirectRules
} let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx + 1) toMove
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules }
return! all next ctx
}
// DELETE /admin/settings/redirect-rules/[index] // DELETE /admin/settings/redirect-rules/[index]
let delete idx : HttpHandler = fun next ctx -> task { let delete idx : HttpHandler =
if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length then requireAccess WebLogAdmin
return! Error.notFound next ctx >=> fun next ctx -> task {
else if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length then
let rules = ctx.WebLog.RedirectRules |> List.removeAt idx return! Error.notFound next ctx
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules } else
do! addMessage ctx { UserMessage.Success with Message = "Redirect rule deleted successfully" } let rules = ctx.WebLog.RedirectRules |> List.removeAt idx
return! all next ctx do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules }
} do! addMessage ctx { UserMessage.Success with Message = "Redirect rule deleted successfully" }
return! all next ctx
}
/// ~~~ TAG MAPPINGS ~~~ /// ~~~ TAG MAPPINGS ~~~
module TagMapping = module TagMapping =
// GET /admin/settings/tag-mappings // GET /admin/settings/tag-mappings
let all : HttpHandler = fun next ctx -> task { let all : HttpHandler =
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id requireAccess WebLogAdmin
return! adminBarePage "Tag Mapping List" true next ctx (Views.WebLog.tagMapList mappings) >=> fun next ctx -> task {
} let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return! adminBarePage "Tag Mapping List" next ctx (Views.WebLog.tagMapList mappings)
}
// GET /admin/settings/tag-mapping/{id}/edit // GET /admin/settings/tag-mapping/{id}/edit
let edit tagMapId : HttpHandler = fun next ctx -> task { let edit tagMapId : HttpHandler =
let isNew = tagMapId = "new" requireAccess WebLogAdmin
let tagMap = >=> fun next ctx -> task {
if isNew then someTask { TagMap.Empty with Id = TagMapId "new" } let isNew = tagMapId = "new"
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id let tagMap =
match! tagMap with if isNew then someTask { TagMap.Empty with Id = TagMapId "new" }
| Some tm -> else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id
return! match! tagMap with
Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm) | Some tm ->
|> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") true next ctx return!
| None -> return! Error.notFound next ctx Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm)
} |> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/tag-mapping/save // POST /admin/settings/tag-mapping/save
let save : HttpHandler = fun next ctx -> task { let save : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
let! model = ctx.BindFormAsync<EditTagMapModel>() >=> validateCsrf
let tagMap = >=> fun next ctx -> task {
if model.IsNew then someTask { TagMap.Empty with Id = TagMapId.Create(); WebLogId = ctx.WebLog.Id } let data = ctx.Data
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id let! model = ctx.BindFormAsync<EditTagMapModel>()
match! tagMap with let tagMap =
| Some tm -> if model.IsNew then someTask { TagMap.Empty with Id = TagMapId.Create(); WebLogId = ctx.WebLog.Id }
do! data.TagMap.Save { tm with Tag = model.Tag.ToLower(); UrlValue = model.UrlValue.ToLower() } else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id
do! addMessage ctx { UserMessage.Success with Message = "Tag mapping saved successfully" } match! tagMap with
return! all next ctx | Some tm ->
| None -> return! Error.notFound next ctx do! data.TagMap.Save { tm with Tag = model.Tag.ToLower(); UrlValue = model.UrlValue.ToLower() }
} do! addMessage ctx { UserMessage.Success with Message = "Tag mapping saved successfully" }
return! all next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/settings/tag-mapping/{id} // DELETE /admin/settings/tag-mapping/{id}
let delete tagMapId : HttpHandler = fun next ctx -> task { let delete tagMapId : HttpHandler =
match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.Id with requireAccess WebLogAdmin
| true -> do! addMessage ctx { UserMessage.Success with Message = "Tag mapping deleted successfully" } >=> fun next ctx -> task {
| false -> do! addMessage ctx { UserMessage.Error with Message = "Tag mapping not found; nothing deleted" } match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.Id with
return! all next ctx | true -> do! addMessage ctx { UserMessage.Success with Message = "Tag mapping deleted successfully" }
} | false -> do! addMessage ctx { UserMessage.Error with Message = "Tag mapping not found; nothing deleted" }
return! all next ctx
}
/// ~~~ THEMES ~~~ /// ~~~ THEMES ~~~
@@ -298,16 +343,19 @@ module Theme =
open MyWebLog.Data open MyWebLog.Data
// GET /admin/theme/list // GET /admin/theme/list
let all : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let all : HttpHandler =
let! themes = ctx.Data.Theme.All () requireAccess Administrator
return! >=> fun next ctx -> task {
Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes) let! themes = ctx.Data.Theme.All ()
|> adminBarePage "Themes" true next ctx return!
} Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes)
|> adminBarePage "Themes" next ctx
}
// GET /admin/theme/new // GET /admin/theme/new
let add : HttpHandler = requireAccess Administrator >=> fun next ctx -> let add : HttpHandler =
adminBarePage "Upload a Theme File" true next ctx Views.Admin.themeUpload requireAccess Administrator
>=> fun next ctx -> 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 /// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask { let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask {
@@ -383,67 +431,73 @@ module Theme =
} }
// POST /admin/theme/new // POST /admin/theme/new
let save : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let save : HttpHandler =
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then requireAccess Administrator
let themeFile = Seq.head ctx.Request.Form.Files >=> validateCsrf
match deriveIdFromFileName themeFile.FileName with >=> fun next ctx -> task {
| Ok themeId when themeId <> ThemeId "admin" -> if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
let data = ctx.Data let themeFile = Seq.head ctx.Request.Form.Files
let! exists = data.Theme.Exists themeId match deriveIdFromFileName themeFile.FileName with
let isNew = not exists | Ok themeId when themeId <> ThemeId "admin" ->
let! model = ctx.BindFormAsync<UploadThemeModel>() let data = ctx.Data
if isNew || model.DoOverwrite then let! exists = data.Theme.Exists themeId
// Load the theme to the database let isNew = not exists
use stream = new MemoryStream() let! model = ctx.BindFormAsync<UploadThemeModel>()
do! themeFile.CopyToAsync stream if isNew || model.DoOverwrite then
let! _ = loadFromZip themeId stream data // Load the theme to the database
do! ThemeAssetCache.refreshTheme themeId data use stream = new MemoryStream()
TemplateCache.invalidateTheme themeId do! themeFile.CopyToAsync stream
// Ensure the themes directory exists let! _ = loadFromZip themeId stream data
let themeDir = Path.Combine(".", "themes") do! ThemeAssetCache.refreshTheme themeId data
if not (Directory.Exists themeDir) then Directory.CreateDirectory themeDir |> ignore Template.Cache.invalidateTheme themeId
// Save the .zip file // Ensure the themes directory exists
use file = new FileStream(Path.Combine(".", "themes", $"{themeId}-theme.zip"), FileMode.Create) let themeDir = Path.Combine(".", "themes")
do! themeFile.CopyToAsync file if not (Directory.Exists themeDir) then Directory.CreateDirectory themeDir |> ignore
do! addMessage ctx // Save the .zip file
{ UserMessage.Success with use file = new FileStream(Path.Combine(".", "themes", $"{themeId}-theme.zip"), FileMode.Create)
Message = $"""Theme {if isNew then "add" else "updat"}ed successfully""" } do! themeFile.CopyToAsync file
do! addMessage ctx
{ UserMessage.Success with
Message = $"""Theme {if isNew then "add" else "updat"}ed successfully""" }
return! toAdminDashboard next ctx
else
do! addMessage ctx
{ UserMessage.Error with
Message = "Theme exists and overwriting was not requested; nothing saved" }
return! toAdminDashboard next ctx
| Ok _ ->
do! addMessage ctx { UserMessage.Error with Message = "You may not replace the admin theme" }
return! toAdminDashboard next ctx return! toAdminDashboard next ctx
else | Error message ->
do! addMessage ctx do! addMessage ctx { UserMessage.Error with Message = message }
{ UserMessage.Error with
Message = "Theme exists and overwriting was not requested; nothing saved" }
return! toAdminDashboard next ctx return! toAdminDashboard next ctx
| Ok _ -> else return! RequestErrors.BAD_REQUEST "Bad request" next ctx
do! addMessage ctx { UserMessage.Error with Message = "You may not replace the admin theme" } }
return! toAdminDashboard next ctx
| Error message ->
do! addMessage ctx { UserMessage.Error with Message = message }
return! toAdminDashboard next ctx
else return! RequestErrors.BAD_REQUEST "Bad request" next ctx
}
// POST /admin/theme/{id}/delete // POST /admin/theme/{id}/delete
let delete themeId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let delete themeId : HttpHandler =
let data = ctx.Data requireAccess Administrator
match themeId with >=> validateCsrf
| "admin" | "default" -> >=> fun next ctx -> task {
do! addMessage ctx { UserMessage.Error with Message = $"You may not delete the {themeId} theme" } let data = ctx.Data
return! all next ctx match themeId with
| it when WebLogCache.isThemeInUse (ThemeId it) -> | "admin" | "default" ->
do! addMessage ctx do! addMessage ctx { UserMessage.Error with Message = $"You may not delete the {themeId} theme" }
{ UserMessage.Error with
Message = $"You may not delete the {themeId} theme, as it is currently in use" }
return! all next ctx
| _ ->
match! data.Theme.Delete (ThemeId themeId) with
| true ->
let zippedTheme = Path.Combine(".", "themes", $"{themeId}-theme.zip")
if File.Exists zippedTheme then File.Delete zippedTheme
do! addMessage ctx { UserMessage.Success with Message = $"Theme ID {themeId} deleted successfully" }
return! all next ctx return! all next ctx
| false -> return! Error.notFound next ctx | it when WebLogCache.isThemeInUse (ThemeId it) ->
} do! addMessage ctx
{ UserMessage.Error with
Message = $"You may not delete the {themeId} theme, as it is currently in use" }
return! all next ctx
| _ ->
match! data.Theme.Delete (ThemeId themeId) with
| true ->
let zippedTheme = Path.Combine(".", "themes", $"{themeId}-theme.zip")
if File.Exists zippedTheme then File.Delete zippedTheme
do! addMessage ctx { UserMessage.Success with Message = $"Theme ID {themeId} deleted successfully" }
return! all next ctx
| false -> return! Error.notFound next ctx
}
/// ~~~ WEB LOG SETTINGS ~~~ /// ~~~ WEB LOG SETTINGS ~~~
@@ -452,41 +506,55 @@ module WebLog =
open System.IO open System.IO
// GET /admin/settings // GET /admin/settings
let settings : HttpHandler = fun next ctx -> task { let settings : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
let! allPages = data.Page.All ctx.WebLog.Id >=> fun next ctx -> task {
let pages = let data = ctx.Data
allPages let! allPages = data.Page.All ctx.WebLog.Id
|> List.sortBy _.Title.ToLower() let pages =
|> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ] allPages
let! themes = data.Theme.All() |> List.sortBy _.Title.ToLower()
let uploads = [ Database; Disk ] |> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ]
return! let! themes = data.Theme.All()
Views.WebLog.webLogSettings let htmxOpts =
(SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss) [ string NoAutoHtmx, "None"
|> adminPage "Web Log Settings" true next ctx string AutoHtmx, "htmx Library"
} string AutoHtmax, "htmax Bundle" ]
let uploads = [ Database; Disk ]
return!
Views.WebLog.webLogSettings
(SettingsModel.FromWebLog ctx.WebLog)
themes
pages
htmxOpts
uploads
(EditRssModel.FromRssOptions ctx.WebLog.Rss)
|> adminPage "Web Log Settings" next ctx
}
// POST /admin/settings // POST /admin/settings
let saveSettings : HttpHandler = fun next ctx -> task { let saveSettings : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
let! model = ctx.BindFormAsync<SettingsModel>() >=> validateCsrf
match! data.WebLog.FindById ctx.WebLog.Id with >=> fun next ctx -> task {
| Some webLog -> let data = ctx.Data
let oldSlug = webLog.Slug let! model = ctx.BindFormAsync<SettingsModel>()
let webLog = model.Update webLog match! data.WebLog.FindById ctx.WebLog.Id with
do! data.WebLog.UpdateSettings webLog | Some webLog ->
let oldSlug = webLog.Slug
let webLog = model.Update webLog
do! data.WebLog.UpdateSettings webLog
// Update cache // Update cache
WebLogCache.set webLog WebLogCache.set webLog
if oldSlug <> webLog.Slug then if oldSlug <> webLog.Slug then
// Rename disk directory if it exists // Rename disk directory if it exists
let uploadRoot = Path.Combine("wwwroot", "upload") let uploadRoot = Path.Combine("wwwroot", "upload")
let oldDir = Path.Combine(uploadRoot, oldSlug) let oldDir = Path.Combine(uploadRoot, oldSlug)
if Directory.Exists oldDir then Directory.Move(oldDir, Path.Combine(uploadRoot, webLog.Slug)) if Directory.Exists oldDir then Directory.Move(oldDir, Path.Combine(uploadRoot, webLog.Slug))
do! addMessage ctx { UserMessage.Success with Message = "Web log settings saved successfully" } do! addMessage ctx { UserMessage.Success with Message = "Web log settings saved successfully" }
return! redirectToGet "admin/settings" next ctx return! redirectToGet "admin/settings" next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
+87 -77
View File
@@ -416,87 +416,97 @@ let generate (feedType: FeedType) postCount : HttpHandler = fun next ctx -> back
// ~~ FEED ADMINISTRATION ~~ // ~~ FEED ADMINISTRATION ~~
// POST /admin/settings/rss // POST /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let saveSettings : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
let! model = ctx.BindFormAsync<EditRssModel>() >=> validateCsrf
match! data.WebLog.FindById ctx.WebLog.Id with >=> fun next ctx -> task {
| Some webLog -> let data = ctx.Data
let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss } let! model = ctx.BindFormAsync<EditRssModel>()
do! data.WebLog.UpdateRssOptions webLog match! data.WebLog.FindById ctx.WebLog.Id with
WebLogCache.set webLog | Some webLog ->
do! addMessage ctx { UserMessage.Success with Message = "RSS settings updated successfully" } let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss }
return! redirectToGet "admin/settings#rss-settings" next ctx do! data.WebLog.UpdateRssOptions webLog
| None -> return! Error.notFound next ctx WebLogCache.set webLog
} do! addMessage ctx { UserMessage.Success with Message = "RSS settings updated successfully" }
return! redirectToGet "admin/settings#rss-settings" next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/settings/rss/{id}/edit // GET /admin/settings/rss/{id}/edit
let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> let editCustomFeed feedId : HttpHandler =
let customFeed = requireAccess WebLogAdmin
match feedId with >=> fun next ctx ->
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId "new" } let customFeed =
| _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId) match feedId with
match customFeed with | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId "new" }
| Some f -> | _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId)
let ratings = [ match customFeed with
{ Name = string Yes; Value = "Yes" } | Some f ->
{ Name = string No; Value = "No" } let ratings = [
{ Name = string Clean; Value = "Clean" } { Name = string Yes; Value = "Yes" }
] { Name = string No; Value = "No" }
let mediums = [ { Name = string Clean; Value = "Clean" }
{ Name = ""; Value = "&ndash; Unspecified &ndash;" } ]
{ Name = string Podcast; Value = "Podcast" } let mediums = [
{ Name = string Music; Value = "Music" } { Name = ""; Value = "&ndash; Unspecified &ndash;" }
{ Name = string Video; Value = "Video" } { Name = string Podcast; Value = "Podcast" }
{ Name = string Film; Value = "Film" } { Name = string Music; Value = "Music" }
{ Name = string Audiobook; Value = "Audiobook" } { Name = string Video; Value = "Video" }
{ Name = string Newsletter; Value = "Newsletter" } { Name = string Film; Value = "Film" }
{ Name = string Blog; Value = "Blog" } { Name = string Audiobook; Value = "Audiobook" }
] { Name = string Newsletter; Value = "Newsletter" }
Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums { Name = string Blog; Value = "Blog" }
|> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" true next ctx ]
| None -> Error.notFound next ctx Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums
|> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" next ctx
| None -> Error.notFound next ctx
// POST /admin/settings/rss/save // POST /admin/settings/rss/save
let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let saveCustomFeed : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
match! data.WebLog.FindById ctx.WebLog.Id with >=> validateCsrf
| Some webLog -> >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditCustomFeedModel>() let data = ctx.Data
let theFeed = match! data.WebLog.FindById ctx.WebLog.Id with
match model.Id with | Some webLog ->
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() } let! model = ctx.BindFormAsync<EditCustomFeedModel>()
| _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> string it.Id = model.Id) let theFeed =
match theFeed with match model.Id with
| Some feed -> | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() }
let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun it -> it.Id <> feed.Id)) | _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> string it.Id = model.Id)
let webLog = { webLog with Rss.CustomFeeds = feeds } match theFeed with
do! data.WebLog.UpdateRssOptions webLog | Some feed ->
WebLogCache.set webLog let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> feed.Id))
do! addMessage ctx let webLog = { webLog with Rss.CustomFeeds = feeds }
{ UserMessage.Success with do! data.WebLog.UpdateRssOptions webLog
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" } WebLogCache.set webLog
return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx do! addMessage ctx
{ UserMessage.Success with
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" }
return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx
| None -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx }
}
// DELETE /admin/settings/rss/{id} // DELETE /admin/settings/rss/{id}
let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let deleteCustomFeed feedId : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
match! data.WebLog.FindById ctx.WebLog.Id with >=> fun next ctx -> task {
| Some webLog -> let data = ctx.Data
let customId = CustomFeedId feedId match! data.WebLog.FindById ctx.WebLog.Id with
if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then | Some webLog ->
let webLog = let customId = CustomFeedId feedId
{ webLog with if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then
Rss = let webLog =
{ webLog.Rss with { webLog with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } } Rss =
do! data.WebLog.UpdateRssOptions webLog { webLog.Rss with
WebLogCache.set webLog CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } }
do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" } do! data.WebLog.UpdateRssOptions webLog
else WebLogCache.set webLog
do! addMessage ctx { UserMessage.Warning with Message = "Custom feed not found; no action taken" } do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" }
return! redirectToGet "admin/settings#rss-settings" next ctx else
| None -> return! Error.notFound next ctx do! addMessage ctx { UserMessage.Warning with Message = "Custom feed not found; no action taken" }
} return! redirectToGet "admin/settings#rss-settings" next ctx
| None -> return! Error.notFound next ctx
}
+69 -204
View File
@@ -19,113 +19,9 @@ type ISession with
| item -> Some (JsonSerializer.Deserialize<'T> item) | item -> Some (JsonSerializer.Deserialize<'T> item)
/// Keys used in the myWebLog-standard DotLiquid hash /// Messages to be displayed to the user
module ViewContext = [<Literal>]
let MESSAGES = "messages"
/// 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"
/// The HTTP item key for loading the session /// The HTTP item key for loading the session
let private sessionLoadedKey = "session-loaded" let private sessionLoadedKey = "session-loaded"
@@ -147,45 +43,31 @@ open MyWebLog.ViewModels
/// Add a message to the user's session /// Add a message to the user's session
let addMessage (ctx: HttpContext) message = task { let addMessage (ctx: HttpContext) message = task {
do! loadSession ctx do! loadSession ctx
let msg = match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with Some it -> it | None -> [] let msg = match ctx.Session.TryGet<UserMessage list> MESSAGES with Some it -> it | None -> []
ctx.Session.Set(ViewContext.Messages, message :: msg) ctx.Session.Set(MESSAGES, message :: msg)
} }
/// Get any messages from the user's session, removing them in the process /// Get any messages from the user's session, removing them in the process
let messages (ctx: HttpContext) = task { let messages (ctx: HttpContext) = task {
do! loadSession ctx do! loadSession ctx
match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with match ctx.Session.TryGet<UserMessage list> MESSAGES with
| Some msg -> | Some msg ->
ctx.Session.Remove ViewContext.Messages ctx.Session.Remove MESSAGES
return msg |> (List.rev >> Array.ofList) return msg |> (List.rev >> Array.ofList)
| None -> return [||] | None -> return [||]
} }
open MyWebLog open MyWebLog
open DotLiquid
/// Shorthand for creating a DotLiquid hash from an anonymous object /// Create a view context with the page title filled
let makeHash (values: obj) = let viewCtxForPage title =
Hash.FromAnonymousObject values { AppViewContext.Empty with PageTitle = title }
/// 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
open System.Security.Claims open System.Security.Claims
open Giraffe open Giraffe
open Giraffe.Htmx open Giraffe.Htmx
open Giraffe.ViewEngine open Giraffe.ViewEngine
/// htmx script tag
let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified
/// Get the current user messages, and commit the session so that they are preserved /// Get the current user messages, and commit the session so that they are preserved
let private getCurrentMessages ctx = task { let private getCurrentMessages ctx = task {
let! messages = messages ctx let! messages = messages ctx
@@ -194,54 +76,30 @@ let private getCurrentMessages ctx = task {
} }
/// Generate the view context for a response /// Generate the view context for a response
let private generateViewContext pageTitle messages includeCsrf (ctx: HttpContext) = let private generateViewContext messages viewCtx (ctx: HttpContext) =
{ WebLog = ctx.WebLog { viewCtx with
UserId = ctx.User.Claims WebLog = ctx.WebLog
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier) UserId = ctx.User.Claims
|> Option.map (fun claim -> WebLogUserId claim.Value) |> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
PageTitle = pageTitle |> Option.map (fun claim -> WebLogUserId claim.Value)
Csrf = if includeCsrf then Some ctx.CsrfTokenSet else None Csrf = Some ctx.CsrfTokenSet
PageList = PageListCache.get ctx PageList = PageListCache.get ctx
Categories = CategoryCache.get ctx Categories = CategoryCache.get ctx
CurrentPage = ctx.Request.Path.Value[1..] CurrentPage = ctx.Request.Path.Value[1..]
Messages = messages Messages = messages
Generator = ctx.Generator Generator = ctx.Generator
HtmxScript = htmxScript IsAuthor = ctx.HasAccessLevel Author
IsAuthor = ctx.HasAccessLevel Author IsEditor = ctx.HasAccessLevel Editor
IsEditor = ctx.HasAccessLevel Editor IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin
IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin IsAdministrator = ctx.HasAccessLevel Administrator }
IsAdministrator = ctx.HasAccessLevel Administrator }
/// Update the view context with standard information (if it has not been done yet) or updated messages
/// Populate the DotLiquid hash with standard information let updateViewContext ctx viewCtx = task {
let addViewContext ctx (hash: Hash) = task {
let! messages = getCurrentMessages ctx let! messages = getCurrentMessages ctx
if hash.ContainsKey ViewContext.AppViewContext then if viewCtx.Generator = "" then
let oldApp = hash[ViewContext.AppViewContext] :?> AppViewContext return generateViewContext messages viewCtx ctx
let newApp = { oldApp with Messages = Array.concat [ oldApp.Messages; messages ] }
return
hash
|> addToHash ViewContext.AppViewContext newApp
|> addToHash ViewContext.Messages newApp.Messages
else else
let app = return { viewCtx with Messages = Array.concat [ viewCtx.Messages; messages ] }
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
} }
/// Is the request from htmx? /// Is the request from htmx?
@@ -269,6 +127,7 @@ let redirectToGet url : HttpHandler = fun _ ctx -> task {
} }
/// The MIME type for podcast episode JSON chapters /// The MIME type for podcast episode JSON chapters
[<Literal>]
let JSON_CHAPTERS = "application/json+chapters" let JSON_CHAPTERS = "application/json+chapters"
@@ -280,7 +139,13 @@ module Error =
/// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response /// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response
let notAuthorized : HttpHandler = fun next ctx -> let notAuthorized : HttpHandler = fun next ctx ->
if ctx.Request.Method = "GET" then if ctx.Request.Method = "GET" then
let redirectUrl = $"user/log-on?returnUrl={WebUtility.UrlEncode ctx.Request.Path}" let fullPath =
String.concat ""
(seq {
if ctx.Request.PathBase.HasValue then yield ctx.Request.PathBase.Value
yield ctx.Request.Path.Value
})
let redirectUrl = $"user/log-on?returnUrl={WebUtility.UrlEncode fullPath}"
(next, ctx) (next, ctx)
||> if isHtmx ctx then withHxRedirect redirectUrl >=> withHxRetarget "body" >=> redirectToGet redirectUrl ||> if isHtmx ctx then withHxRedirect redirectUrl >=> withHxRetarget "body" >=> redirectToGet redirectUrl
else redirectToGet redirectUrl else redirectToGet redirectUrl
@@ -311,67 +176,67 @@ module Error =
else ServerErrors.INTERNAL_ERROR message earlyReturn ctx) else ServerErrors.INTERNAL_ERROR message earlyReturn ctx)
/// Render a view for the specified theme, using the specified template, layout, and hash /// Render a view for the specified theme, using the specified template, layout, and context
let viewForTheme themeId template next ctx (hash: Hash) = task { let viewForTheme themeId template next ctx (viewCtx: AppViewContext) = task {
let! hash = addViewContext ctx hash let! updated = updateViewContext ctx viewCtx
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render; // NOTE: Although Fluid's view engine support implements layouts and sections, it also relies on the filesystem.
// the net effect is a "layout" capability similar to Razor or Pug // 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... // Render view content...
match! TemplateCache.get themeId template ctx.Data with match! Template.Cache.get themeId template ctx.Data with
| Ok contentTemplate -> | 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 // ...then render that content with its layout
match! TemplateCache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with match! Template.Cache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with
| Ok layoutTemplate -> return! htmlString (layoutTemplate.Render hash) next ctx | 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
| 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 /// Render a bare view for the specified theme, using the specified template and context
let bareForTheme themeId template next ctx (hash: Hash) = task { let bareForTheme themeId template next ctx viewCtx = task {
let! hash = addViewContext ctx hash let! updated = updateViewContext ctx viewCtx
let withContent = task { let withContent = task {
if hash.ContainsKey ViewContext.Content then return Ok hash if updated.Content = "" then
else match! Template.Cache.get themeId template ctx.Data with
match! TemplateCache.get themeId template ctx.Data with | Ok contentTemplate -> return Ok { updated with Content = Template.render contentTemplate updated ctx.Data }
| Ok contentTemplate -> return Ok(addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Error message -> return Error message | Error message -> return Error message
else
return Ok viewCtx
} }
match! withContent with match! withContent with
| Ok completeHash -> | Ok completeCtx ->
// Bare templates are rendered with layout-bare // 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 -> | Ok layoutTemplate ->
return! return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array) (messagesToHeaders completeCtx.Messages
>=> htmlString (layoutTemplate.Render completeHash)) >=> htmlString (Template.render layoutTemplate completeCtx ctx.Data)) next ctx
next ctx
| Error message -> return! Error.server message next ctx | Error message -> return! Error.server message 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 /// Return a view for the web log's default theme
let themedView template next ctx hash = task { let themedView template next (ctx: HttpContext) viewCtx = task {
let! hash = addViewContext ctx hash return! viewForTheme ctx.WebLog.ThemeId template next ctx viewCtx
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
} }
/// Display a page for an admin endpoint /// 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! 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 let layout = if isHtmx ctx then Layout.partial else Layout.full
return! htmlString (layout content appCtx |> RenderView.AsString.htmlDocument) next ctx return! (layout content appCtx |> RenderView.AsString.htmlDocument |> htmlString) next ctx
} }
/// Display a bare page for an admin endpoint /// 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! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx let appCtx = generateViewContext messages (viewCtxForPage pageTitle) ctx
return! return!
( messagesToHeaders appCtx.Messages (messagesToHeaders appCtx.Messages
>=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx >=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx
} }
+158 -133
View File
@@ -7,98 +7,113 @@ open MyWebLog.ViewModels
// GET /admin/pages // GET /admin/pages
// GET /admin/pages/page/{pageNbr} // GET /admin/pages/page/{pageNbr}
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { let all pageNbr : HttpHandler =
let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr requireAccess Author
let displayPages = >=> fun next ctx -> task {
pages let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr
|> Seq.ofList let displayPages =
|> Seq.truncate 25 pages
|> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog) |> Seq.ofList
|> List.ofSeq |> Seq.truncate 25
return! |> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog)
Views.Page.pageList displayPages pageNbr (pages.Length > 25) |> List.ofSeq
|> adminPage "Pages" true next ctx return!
} Views.Page.pageList displayPages pageNbr (pages.Length > 25)
|> adminPage "Pages" next ctx
}
// GET /admin/page/{id}/edit // GET /admin/page/{id}/edit
let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let edit pgId : HttpHandler =
let! result = task { requireAccess Author
match pgId with >=> fun next ctx -> task {
| "new" -> return Some ("Add a New Page", { Page.Empty with Id = PageId "new"; AuthorId = ctx.UserId }) let! result = task {
| _ -> match pgId with
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with | "new" -> return Some ("Add a New Page", { Page.Empty with Id = PageId "new"; AuthorId = ctx.UserId })
| Some page -> return Some ("Edit Page", page) | _ ->
| None -> return None match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some page -> return Some ("Edit Page", page)
| None -> return None
}
match result with
| Some (title, page) when canEdit page.AuthorId ctx ->
let model = EditPageModel.FromPage page
let! templates = templatesForTheme ctx "page"
return! adminPage title next ctx (Views.Page.pageEdit model templates)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
} }
match result with
| 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)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/page/{id} // DELETE /admin/page/{id}
let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let delete pgId : HttpHandler =
match! ctx.Data.Page.Delete (PageId pgId) ctx.WebLog.Id with requireAccess WebLogAdmin
| true -> >=> fun next ctx -> task {
do! PageListCache.update ctx match! ctx.Data.Page.Delete (PageId pgId) ctx.WebLog.Id with
do! addMessage ctx { UserMessage.Success with Message = "Page deleted successfully" } | true ->
| false -> do! addMessage ctx { UserMessage.Error with Message = "Page not found; nothing deleted" } do! PageListCache.update ctx
return! all 1 next ctx do! addMessage ctx { UserMessage.Success with Message = "Page deleted successfully" }
} | false -> do! addMessage ctx { UserMessage.Error with Message = "Page not found; nothing deleted" }
return! all 1 next ctx
}
// GET /admin/page/{id}/permalinks // GET /admin/page/{id}/permalinks
let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editPermalinks pgId : HttpHandler =
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with requireAccess Author
| Some pg when canEdit pg.AuthorId ctx -> >=> fun next ctx -> task {
return! match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
ManagePermalinksModel.FromPage pg | Some pg when canEdit pg.AuthorId ctx ->
|> Views.Helpers.managePermalinks return!
|> adminPage "Manage Prior Permalinks" true next ctx ManagePermalinksModel.FromPage pg
| Some _ -> return! Error.notAuthorized next ctx |> Views.Helpers.managePermalinks
| None -> return! Error.notFound next ctx |> adminPage "Manage Prior Permalinks" next ctx
} | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/page/permalinks // POST /admin/page/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task { let savePermalinks : HttpHandler =
let! model = ctx.BindFormAsync<ManagePermalinksModel>() requireAccess Author
let pageId = PageId model.Id >=> validateCsrf
match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with >=> fun next ctx -> task {
| Some pg when canEdit pg.AuthorId ctx -> let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let links = model.Prior |> Array.map Permalink |> List.ofArray let pageId = PageId model.Id
match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.Id links with match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with
| true -> | Some pg when canEdit pg.AuthorId ctx ->
do! addMessage ctx { UserMessage.Success with Message = "Page permalinks saved successfully" } let links = model.Prior |> Array.map Permalink |> List.ofArray
return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.Id links with
| false -> return! Error.notFound next ctx | true ->
| Some _ -> return! Error.notAuthorized next ctx do! addMessage ctx { UserMessage.Success with Message = "Page permalinks saved successfully" }
| None -> return! Error.notFound next ctx return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx
} | false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/page/{id}/revisions // GET /admin/page/{id}/revisions
let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editRevisions pgId : HttpHandler =
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with requireAccess Author
| Some pg when canEdit pg.AuthorId ctx -> >=> fun next ctx -> task {
return! match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
ManageRevisionsModel.FromPage pg | Some pg when canEdit pg.AuthorId ctx ->
|> Views.Helpers.manageRevisions return!
|> adminPage "Manage Page Revisions" true next ctx ManageRevisionsModel.FromPage pg
| Some _ -> return! Error.notAuthorized next ctx |> Views.Helpers.manageRevisions
| None -> return! Error.notFound next ctx |> adminPage "Manage Page Revisions" next ctx
} | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/page/{id}/revisions // DELETE /admin/page/{id}/revisions
let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let purgeRevisions pgId : HttpHandler =
let data = ctx.Data requireAccess Author
match! data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with >=> fun next ctx -> task {
| Some pg -> let data = ctx.Data
do! data.Page.Update { pg with Revisions = [ List.head pg.Revisions ] } match! data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } | Some pg ->
return! editRevisions pgId next ctx do! data.Page.Update { pg with Revisions = [ List.head pg.Revisions ] }
| None -> return! Error.notFound next ctx do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" }
} return! editRevisions pgId next ctx
| None -> return! Error.notFound next ctx
}
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
@@ -112,63 +127,73 @@ let private findPageRevision pgId revDate (ctx: HttpContext) = task {
} }
// GET /admin/page/{id}/revision/{revision-date}/preview // GET /admin/page/{id}/revision/{revision-date}/preview
let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let previewRevision (pgId, revDate) : HttpHandler =
match! findPageRevision pgId revDate ctx with requireAccess Author
| Some pg, Some rev when canEdit pg.AuthorId ctx -> >=> fun next ctx -> task {
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev) match! findPageRevision pgId revDate ctx with
| Some _, Some _ -> return! Error.notAuthorized next ctx | Some pg, Some rev when canEdit pg.AuthorId ctx ->
| None, _ | _, None -> return! Error.notFound next ctx return! adminBarePage "" next ctx (Views.Helpers.commonPreview rev)
} | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/revision/{revision-date}/restore // POST /admin/page/{id}/revision/{revision-date}/restore
let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let restoreRevision (pgId, revDate) : HttpHandler =
match! findPageRevision pgId revDate ctx with requireAccess Author
| Some pg, Some rev when canEdit pg.AuthorId ctx -> >=> validateCsrf
do! ctx.Data.Page.Update >=> fun next ctx -> task {
{ pg with match! findPageRevision pgId revDate ctx with
Revisions = { rev with AsOf = Noda.now () } | Some pg, Some rev when canEdit pg.AuthorId ctx ->
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } do! ctx.Data.Page.Update
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" } { pg with
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx Revisions = { rev with AsOf = Noda.now () }
| Some _, Some _ -> return! Error.notAuthorized next ctx :: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
| None, _ do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
| _, None -> return! Error.notFound next ctx return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
} | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// DELETE /admin/page/{id}/revision/{revision-date} // DELETE /admin/page/{id}/revision/{revision-date}
let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let deleteRevision (pgId, revDate) : HttpHandler =
match! findPageRevision pgId revDate ctx with requireAccess Author
| Some pg, Some rev when canEdit pg.AuthorId ctx -> >=> fun next ctx -> task {
do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } match! findPageRevision pgId revDate ctx with
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } | Some pg, Some rev when canEdit pg.AuthorId ctx ->
return! adminBarePage "" false next ctx (fun _ -> []) do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
| Some _, Some _ -> return! Error.notAuthorized next ctx do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
| None, _ return! adminBarePage "" next ctx (fun _ -> [])
| _, None -> return! Error.notFound next ctx | Some _, Some _ -> return! Error.notAuthorized next ctx
} | None, _
| _, None -> return! Error.notFound next ctx
}
// POST /admin/page/save // POST /admin/page/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let save : HttpHandler =
let! model = ctx.BindFormAsync<EditPageModel>() requireAccess Author
let data = ctx.Data >=> validateCsrf
let now = Noda.now () >=> fun next ctx -> task {
let tryPage = let! model = ctx.BindFormAsync<EditPageModel>()
if model.IsNew then let data = ctx.Data
{ Page.Empty with let now = Noda.now ()
Id = PageId.Create() let tryPage =
WebLogId = ctx.WebLog.Id if model.IsNew then
AuthorId = ctx.UserId { Page.Empty with
PublishedOn = now Id = PageId.Create()
} |> someTask WebLogId = ctx.WebLog.Id
else data.Page.FindFullById (PageId model.Id) ctx.WebLog.Id AuthorId = ctx.UserId
match! tryPage with PublishedOn = now
| Some page when canEdit page.AuthorId ctx -> } |> someTask
let updateList = page.IsInPageList <> model.IsShownInPageList else data.Page.FindFullById (PageId model.Id) ctx.WebLog.Id
let updatedPage = model.UpdatePage page now match! tryPage with
do! (if model.IsNew then data.Page.Add else data.Page.Update) updatedPage | Some page when canEdit page.AuthorId ctx ->
if updateList then do! PageListCache.update ctx let updateList = page.IsInPageList <> model.IsShownInPageList
do! addMessage ctx { UserMessage.Success with Message = "Page saved successfully" } let updatedPage = model.UpdatePage page now
return! redirectToGet $"admin/page/{page.Id}/edit" next ctx do! (if model.IsNew then data.Page.Add else data.Page.Update) updatedPage
| Some _ -> return! Error.notAuthorized next ctx if updateList then do! PageListCache.update ctx
| None -> return! Error.notFound next ctx do! addMessage ctx { UserMessage.Success with Message = "Page saved successfully" }
} return! redirectToGet $"admin/page/{page.Id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
+303 -267
View File
@@ -4,6 +4,7 @@ module MyWebLog.Handlers.Post
open System open System
open System.Collections.Generic open System.Collections.Generic
open MyWebLog open MyWebLog
open MyWebLog.Views
/// Parse a slug and page number from an "everything else" URL /// Parse a slug and page number from an "everything else" URL
let private parseSlugAndPage webLog (slugAndPage: string seq) = let private parseSlugAndPage webLog (slugAndPage: string seq) =
@@ -87,37 +88,36 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I
OlderName = olderPost |> Option.map _.Title OlderName = olderPost |> Option.map _.Title
} }
return return
makeHash {||} { AppViewContext.Empty with
|> addToHash ViewContext.Model model Payload = model
|> addToHash "tag_mappings" tagMappings TagMappings = Array.ofList tagMappings
|> addToHash ViewContext.IsPost (match listType with SinglePost -> true | _ -> false) IsPost = (match listType with SinglePost -> true | _ -> false) }
} }
open Giraffe open Giraffe
// GET /page/{pageNbr} // GET /page/{pageNbr}[/]
// (also served with pageNbr = 1 when default page is recent posts)
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let count = ctx.WebLog.PostsPerPage if pageNbr <> 1 && ctx.Request.Path.Value.EndsWith "/" then
let data = ctx.Data return! redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count else
let! hash = preparePostList ctx.WebLog posts PostList "" pageNbr count data let count = ctx.WebLog.PostsPerPage
let title = let data = ctx.Data
match pageNbr, ctx.WebLog.DefaultPage with let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count
| 1, "posts" -> None let! viewCtx = preparePostList ctx.WebLog posts PostList "" pageNbr count data
| _, "posts" -> Some $"Page {pageNbr}" let title =
| _, _ -> Some $"Page {pageNbr} &laquo; Posts" match pageNbr, ctx.WebLog.DefaultPage with
return! | 1, "posts" -> None
match title with Some ttl -> addToHash ViewContext.PageTitle ttl hash | None -> hash | _, "posts" -> Some $"Page {pageNbr}"
|> function | _, _ -> Some $"Page {pageNbr} &laquo; Posts"
| hash -> return!
if pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" then addToHash ViewContext.IsHome true hash else hash { viewCtx with
|> themedView "index" next ctx PageTitle = defaultArg title viewCtx.PageTitle
IsHome = pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" }
|> themedView "index" next ctx
} }
// GET /page/{pageNbr}/
let redirectToPageOfPosts (pageNbr: int) : HttpHandler = fun next ctx ->
redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx
// GET /category/{slug}/ // GET /category/{slug}/
// GET /category/{slug}/page/{pageNbr} // GET /category/{slug}/page/{pageNbr}
let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task { let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
@@ -134,14 +134,15 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
match! data.Post.FindPageOfCategorizedPosts webLog.Id (getCategoryIds slug ctx) pageNbr webLog.PostsPerPage match! data.Post.FindPageOfCategorizedPosts webLog.Id (getCategoryIds slug ctx) pageNbr webLog.PostsPerPage
with with
| posts when List.length posts > 0 -> | posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage 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>""" let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
return! return!
addToHash ViewContext.PageTitle $"{cat.Name}: Category Archive{pgTitle}" hash { viewCtx with
|> addToHash "subtitle" (defaultArg cat.Description "") PageTitle = $"{cat.Name}: Category Archive{pgTitle}"
|> addToHash ViewContext.IsCategory true Subtitle = defaultArg cat.Description ""
|> addToHash ViewContext.IsCategoryHome (pageNbr = 1) IsCategory = true
|> addToHash ViewContext.Slug slug IsCategoryHome = (pageNbr = 1)
Slug = Some slug }
|> themedView "index" next ctx |> themedView "index" next ctx
| _ -> return! Error.notFound next ctx | _ -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
@@ -169,13 +170,14 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
else else
match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with
| posts when List.length posts > 0 -> | posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage data 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>""" let pgTitle = if pageNbr = 1 then "" else $" <small class=\"archive-pg-nbr\">(Page {pageNbr})</small>"
return! return!
addToHash ViewContext.PageTitle $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}" hash { viewCtx with
|> addToHash ViewContext.IsTag true PageTitle = $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}"
|> addToHash ViewContext.IsTagHome (pageNbr = 1) IsTag = true
|> addToHash ViewContext.Slug rawTag IsTagHome = (pageNbr = 1)
Slug = Some rawTag }
|> themedView "index" next ctx |> themedView "index" next ctx
// Other systems use hyphens for spaces; redirect if this is an old tag link // Other systems use hyphens for spaces; redirect if this is an old tag link
| _ -> | _ ->
@@ -200,9 +202,9 @@ let home : HttpHandler = fun next ctx -> task {
match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with
| Some page -> | Some page ->
return! return!
hashForPage page.Title { viewCtxForPage page.Title with
|> addToHash "page" (DisplayPage.FromPage webLog page) Payload = DisplayPage.FromPage webLog page
|> addToHash ViewContext.IsHome true IsHome = true }
|> themedView (defaultArg page.Template "single-page") next ctx |> themedView (defaultArg page.Template "single-page") next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@@ -250,99 +252,114 @@ let chapters (post: Post) : HttpHandler = fun next ctx ->
// GET /admin/posts // GET /admin/posts
// GET /admin/posts/page/{pageNbr} // GET /admin/posts/page/{pageNbr}
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { let all pageNbr : HttpHandler =
let data = ctx.Data requireAccess Author
let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25 >=> fun next ctx -> task {
let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data let data = ctx.Data
return! adminPage "Posts" true next ctx (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay)) 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 // GET /admin/post/{id}/edit
let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let edit postId : HttpHandler =
let data = ctx.Data requireAccess Author
let! result = task { >=> fun next ctx -> task {
match postId with let data = ctx.Data
| "new" -> return Some ("Write a New Post", { Post.Empty with Id = PostId "new" }) let! result = task {
| _ -> match postId with
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with | "new" -> return Some ("Write a New Post", { Post.Empty with Id = PostId "new" })
| Some post -> return Some ("Edit Post", post) | _ ->
| None -> return None match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post -> return Some ("Edit Post", post)
| None -> return None
}
match result with
| Some (title, post) when canEdit post.AuthorId ctx ->
let! templates = templatesForTheme ctx "post"
let model = EditPostModel.FromPost ctx.WebLog post
let ratings = [
{ Name = ""; Value = "&ndash; Default &ndash;" }
{ Name = string Yes; Value = "Yes" }
{ Name = string No; Value = "No" }
{ Name = string Clean; Value = "Clean" }
]
return! adminPage title next ctx (Post.postEdit model templates ratings)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
} }
match result with
| Some (title, post) when canEdit post.AuthorId ctx ->
let! templates = templatesForTheme ctx "post"
let model = EditPostModel.FromPost ctx.WebLog post
let ratings = [
{ Name = ""; Value = "&ndash; Default &ndash;" }
{ Name = string Yes; Value = "Yes" }
{ Name = string No; Value = "No" }
{ Name = string Clean; Value = "Clean" }
]
return! adminPage title true next ctx (Views.Post.postEdit model templates ratings)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/post/{id} // DELETE /admin/post/{id}
let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let delete postId : HttpHandler =
match! ctx.Data.Post.Delete (PostId postId) ctx.WebLog.Id with requireAccess WebLogAdmin
| true -> do! addMessage ctx { UserMessage.Success with Message = "Post deleted successfully" } >=> fun next ctx -> task {
| false -> do! addMessage ctx { UserMessage.Error with Message = "Post not found; nothing deleted" } match! ctx.Data.Post.Delete (PostId postId) ctx.WebLog.Id with
//return! redirectToGet "admin/posts" next ctx | true -> do! addMessage ctx { UserMessage.Success with Message = "Post deleted successfully" }
return! all 1 next ctx | false -> do! addMessage ctx { UserMessage.Error with Message = "Post not found; nothing deleted" }
} //return! redirectToGet "admin/posts" next ctx
return! all 1 next ctx
}
// GET /admin/post/{id}/permalinks // GET /admin/post/{id}/permalinks
let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editPermalinks postId : HttpHandler =
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with requireAccess Author
| Some post when canEdit post.AuthorId ctx -> >=> fun next ctx -> task {
return! match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
ManagePermalinksModel.FromPost post | Some post when canEdit post.AuthorId ctx ->
|> Views.Helpers.managePermalinks return!
|> adminPage "Manage Prior Permalinks" true next ctx ManagePermalinksModel.FromPost post
| Some _ -> return! Error.notAuthorized next ctx |> managePermalinks
| None -> return! Error.notFound next ctx |> adminPage "Manage Prior Permalinks" next ctx
} | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/post/permalinks // POST /admin/post/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task { let savePermalinks : HttpHandler =
let! model = ctx.BindFormAsync<ManagePermalinksModel>() requireAccess Author
let postId = PostId model.Id >=> validateCsrf
match! ctx.Data.Post.FindById postId ctx.WebLog.Id with >=> fun next ctx -> task {
| Some post when canEdit post.AuthorId ctx -> let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let links = model.Prior |> Array.map Permalink |> List.ofArray let postId = PostId model.Id
match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.Id links with match! ctx.Data.Post.FindById postId ctx.WebLog.Id with
| true -> | Some post when canEdit post.AuthorId ctx ->
do! addMessage ctx { UserMessage.Success with Message = "Post permalinks saved successfully" } let links = model.Prior |> Array.map Permalink |> List.ofArray
return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.Id links with
| false -> return! Error.notFound next ctx | true ->
| Some _ -> return! Error.notAuthorized next ctx do! addMessage ctx { UserMessage.Success with Message = "Post permalinks saved successfully" }
| None -> return! Error.notFound next ctx return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx
} | false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/revisions // GET /admin/post/{id}/revisions
let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editRevisions postId : HttpHandler =
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with requireAccess Author
| Some post when canEdit post.AuthorId ctx -> >=> fun next ctx -> task {
return! match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
ManageRevisionsModel.FromPost post | Some post when canEdit post.AuthorId ctx ->
|> Views.Helpers.manageRevisions return!
|> adminPage "Manage Post Revisions" true next ctx ManageRevisionsModel.FromPost post
| Some _ -> return! Error.notAuthorized next ctx |> manageRevisions
| None -> return! Error.notFound next ctx |> adminPage "Manage Post Revisions" next ctx
} | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/post/{id}/revisions // DELETE /admin/post/{id}/revisions
let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let purgeRevisions postId : HttpHandler =
let data = ctx.Data requireAccess Author
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with >=> fun next ctx -> task {
| Some post when canEdit post.AuthorId ctx -> let data = ctx.Data
do! data.Post.Update { post with Revisions = [ List.head post.Revisions ] } match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } | Some post when canEdit post.AuthorId ctx ->
return! editRevisions postId next ctx do! data.Post.Update { post with Revisions = [ List.head post.Revisions ] }
| Some _ -> return! Error.notAuthorized next ctx do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" }
| None -> return! Error.notFound next ctx return! editRevisions postId next ctx
} | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
@@ -356,165 +373,184 @@ let private findPostRevision postId revDate (ctx: HttpContext) = task {
} }
// GET /admin/post/{id}/revision/{revision-date}/preview // GET /admin/post/{id}/revision/{revision-date}/preview
let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let previewRevision (postId, revDate) : HttpHandler =
match! findPostRevision postId revDate ctx with requireAccess Author
| Some post, Some rev when canEdit post.AuthorId ctx -> >=> fun next ctx -> task {
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev) match! findPostRevision postId revDate ctx with
| Some _, Some _ -> return! Error.notAuthorized next ctx | Some post, Some rev when canEdit post.AuthorId ctx ->
| None, _ | _, None -> return! Error.notFound next ctx return! adminBarePage "" next ctx (commonPreview rev)
} | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/revision/{revision-date}/restore // POST /admin/post/{id}/revision/{revision-date}/restore
let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let restoreRevision (postId, revDate) : HttpHandler =
match! findPostRevision postId revDate ctx with requireAccess Author
| Some post, Some rev when canEdit post.AuthorId ctx -> >=> validateCsrf
do! ctx.Data.Post.Update >=> fun next ctx -> task {
{ post with match! findPostRevision postId revDate ctx with
Revisions = { rev with AsOf = Noda.now () } | Some post, Some rev when canEdit post.AuthorId ctx ->
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } do! ctx.Data.Post.Update
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" } { post with
return! redirectToGet $"admin/post/{postId}/revisions" next ctx Revisions = { rev with AsOf = Noda.now () }
| Some _, Some _ -> return! Error.notAuthorized next ctx :: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
| None, _ do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
| _, None -> return! Error.notFound next ctx return! redirectToGet $"admin/post/{postId}/revisions" next ctx
} | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// DELETE /admin/post/{id}/revision/{revision-date} // DELETE /admin/post/{id}/revision/{revision-date}
let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let deleteRevision (postId, revDate) : HttpHandler =
match! findPostRevision postId revDate ctx with requireAccess Author
| Some post, Some rev when canEdit post.AuthorId ctx -> >=> fun next ctx -> task {
do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } match! findPostRevision postId revDate ctx with
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } | Some post, Some rev when canEdit post.AuthorId ctx ->
return! adminBarePage "" false next ctx (fun _ -> []) do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
| Some _, Some _ -> return! Error.notAuthorized next ctx do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
| None, _ return! adminBarePage "" next ctx (fun _ -> [])
| _, None -> return! Error.notFound next ctx | Some _, Some _ -> return! Error.notAuthorized next ctx
} | None, _
| _, None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/chapters // GET /admin/post/{id}/chapters
let manageChapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let manageChapters postId : HttpHandler =
match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with requireAccess Author
| Some post >=> fun next ctx -> task {
when Option.isSome post.Episode match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with
&& Option.isSome post.Episode.Value.Chapters | Some post
&& canEdit post.AuthorId ctx -> when Option.isSome post.Episode
return! && Option.isSome post.Episode.Value.Chapters
Views.Post.chapters false (ManageChaptersModel.Create post) && canEdit post.AuthorId ctx ->
|> adminPage "Manage Chapters" true next ctx return!
| Some _ | None -> return! Error.notFound next ctx Post.chapters false (ManageChaptersModel.Create post)
} |> adminPage "Manage Chapters" next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/chapter/{idx} // GET /admin/post/{id}/chapter/{idx}
let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editChapter (postId, index) : HttpHandler =
match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with requireAccess Author
| Some post >=> fun next ctx -> task {
when Option.isSome post.Episode match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with
&& Option.isSome post.Episode.Value.Chapters | Some post
&& canEdit post.AuthorId ctx -> when Option.isSome post.Episode
let chapter = && Option.isSome post.Episode.Value.Chapters
if index = -1 then Some Chapter.Empty && canEdit post.AuthorId ctx ->
else let chapter =
let chapters = post.Episode.Value.Chapters.Value if index = -1 then Some Chapter.Empty
if index < List.length chapters then Some chapters[index] else None else
match chapter with let chapters = post.Episode.Value.Chapters.Value
| Some chap -> if index < List.length chapters then Some chapters[index] else None
return! match chapter with
Views.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap) | Some chap ->
|> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") true next ctx return!
| None -> return! Error.notFound next ctx Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)
| Some _ | None -> return! Error.notFound next ctx |> 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
}
// POST /admin/post/{id}/chapter/{idx} // POST /admin/post/{id}/chapter/{idx}
let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let saveChapter (postId, index) : HttpHandler =
let data = ctx.Data requireAccess Author
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with >=> validateCsrf
| Some post >=> fun next ctx -> task {
when Option.isSome post.Episode let data = ctx.Data
&& Option.isSome post.Episode.Value.Chapters match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
&& canEdit post.AuthorId ctx -> | Some post
let! form = ctx.BindFormAsync<EditChapterModel>() when Option.isSome post.Episode
let chapters = post.Episode.Value.Chapters.Value && Option.isSome post.Episode.Value.Chapters
if index >= -1 && index < List.length chapters then && canEdit post.AuthorId ctx ->
try let! form = ctx.BindFormAsync<EditChapterModel>()
let chapter = form.ToChapter() let chapters = post.Episode.Value.Chapters.Value
let existing = if index = -1 then chapters else List.removeAt index chapters if index >= -1 && index < List.length chapters then
let updatedPost = try
{ post with let chapter = form.ToChapter()
Episode = Some let existing = if index = -1 then chapters else List.removeAt index chapters
{ post.Episode.Value with let updatedPost =
Chapters = Some (chapter :: existing |> List.sortBy _.StartTime) } } { post with
do! data.Post.Update updatedPost Episode = Some
do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } { post.Episode.Value with
return! Chapters = Some (chapter :: existing |> List.sortBy _.StartTime) } }
Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost) do! data.Post.Update updatedPost
|> adminBarePage "Manage Chapters" true next ctx do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" }
with return!
| ex -> return! Error.server ex.Message next ctx Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)
else return! Error.notFound next ctx |> adminBarePage "Manage Chapters" next ctx
| Some _ | None -> return! Error.notFound next ctx with
} | ex -> return! Error.server ex.Message next ctx
else return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// DELETE /admin/post/{id}/chapter/{idx} // DELETE /admin/post/{id}/chapter/{idx}
let deleteChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let deleteChapter (postId, index) : HttpHandler =
let data = ctx.Data requireAccess Author
match! data.Post.FindById (PostId postId) ctx.WebLog.Id with >=> fun next ctx -> task {
| Some post let data = ctx.Data
when Option.isSome post.Episode match! data.Post.FindById (PostId postId) ctx.WebLog.Id with
&& Option.isSome post.Episode.Value.Chapters | Some post
&& canEdit post.AuthorId ctx -> when Option.isSome post.Episode
let chapters = post.Episode.Value.Chapters.Value && Option.isSome post.Episode.Value.Chapters
if index >= 0 && index < List.length chapters then && canEdit post.AuthorId ctx ->
let updatedPost = let chapters = post.Episode.Value.Chapters.Value
{ post with if index >= 0 && index < List.length chapters then
Episode = Some { post.Episode.Value with Chapters = Some (List.removeAt index chapters) } } let updatedPost =
do! data.Post.Update updatedPost { post with
do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" } Episode = Some { post.Episode.Value with Chapters = Some (List.removeAt index chapters) } }
return! do! data.Post.Update updatedPost
Views.Post.chapterList false (ManageChaptersModel.Create updatedPost) do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" }
|> adminPage "Manage Chapters" true next ctx return!
else return! Error.notFound next ctx Post.chapterList false (ManageChaptersModel.Create updatedPost)
| Some _ | None -> return! Error.notFound next ctx |> adminPage "Manage Chapters" next ctx
} else return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// POST /admin/post/save // POST /admin/post/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let save : HttpHandler =
let! model = ctx.BindFormAsync<EditPostModel>() requireAccess Author
let data = ctx.Data >=> validateCsrf
let tryPost = >=> fun next ctx -> task {
if model.IsNew then let! model = ctx.BindFormAsync<EditPostModel>()
{ Post.Empty with let data = ctx.Data
Id = PostId.Create() let tryPost =
WebLogId = ctx.WebLog.Id if model.IsNew then
AuthorId = ctx.UserId } { Post.Empty with
|> someTask Id = PostId.Create()
else data.Post.FindFullById (PostId model.Id) ctx.WebLog.Id WebLogId = ctx.WebLog.Id
match! tryPost with AuthorId = ctx.UserId }
| Some post when canEdit post.AuthorId ctx -> |> someTask
let priorCats = post.CategoryIds else data.Post.FindFullById (PostId model.Id) ctx.WebLog.Id
let updatedPost = match! tryPost with
model.UpdatePost post (Noda.now ()) | Some post when canEdit post.AuthorId ctx ->
|> function let priorCats = post.CategoryIds
| post -> let updatedPost =
if model.SetPublished then model.UpdatePost post (Noda.now ())
let dt = parseToUtc (model.PubOverride.Value.ToString "o") |> function
if model.SetUpdated then | post ->
{ post with if model.SetPublished then
PublishedOn = Some dt let dt = parseToUtc (model.PubOverride.Value.ToString "o")
UpdatedOn = dt if model.SetUpdated then
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ] } { post with
else { post with PublishedOn = Some dt } PublishedOn = Some dt
else post UpdatedOn = dt
do! (if model.IsNew then data.Post.Add else data.Post.Update) updatedPost Revisions = [ { (List.head post.Revisions) with AsOf = dt } ] }
// If the post was published or its categories changed, refresh the category cache else { post with PublishedOn = Some dt }
if model.DoPublish else post
|| not (priorCats do! (if model.IsNew then data.Post.Add else data.Post.Update) updatedPost
|> List.append updatedPost.CategoryIds // If the post was published or its categories changed, refresh the category cache
|> List.distinct if model.DoPublish
|> List.length = List.length priorCats) then || not (priorCats
do! CategoryCache.update ctx |> List.append updatedPost.CategoryIds
do! addMessage ctx { UserMessage.Success with Message = "Post saved successfully" } |> List.distinct
return! redirectToGet $"admin/post/{post.Id}/edit" next ctx |> List.length = List.length priorCats) then
| Some _ -> return! Error.notAuthorized next ctx do! CategoryCache.update ctx
| None -> return! Error.notFound next ctx do! addMessage ctx { UserMessage.Success with Message = "Post saved successfully" }
} return! redirectToGet $"admin/post/{post.Id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
+137 -144
View File
@@ -8,6 +8,7 @@ open MyWebLog
/// Module to resolve routes that do not match any other known route (web blog content) /// Module to resolve routes that do not match any other known route (web blog content)
module CatchAll = module CatchAll =
open System.IO
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// Sequence where the first returned value is the proper handler for the link /// Sequence where the first returned value is the proper handler for the link
@@ -15,13 +16,24 @@ module CatchAll =
let webLog = ctx.WebLog let webLog = ctx.WebLog
let data = ctx.Data let data = ctx.Data
let debug = debug "Routes.CatchAll" ctx let debug = debug "Routes.CatchAll" ctx
let textLink = let textLink = string ctx.Request.Path
let extra = webLog.ExtraPath
let url = string ctx.Request.Path
(if extra = "" then url else url[extra.Length..]).ToLowerInvariant()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it let await it = (Async.AwaitTask >> Async.RunSynchronously) it
seq { seq {
// Static file
// TODO: static file middleware may take care of this now that we're setting the path base
debug (fun () -> $"Considering URL {textLink}") debug (fun () -> $"Considering URL {textLink}")
let staticFileName =
[ ctx.GetWebHostEnvironment().ContentRootPath
"wwwroot"
if textLink.Length > 1 then textLink[1..] else textLink ]
|> String.concat (string Path.DirectorySeparatorChar)
if File.Exists staticFileName then
debug (fun () -> $"File {textLink} is a static file")
yield
File.GetLastWriteTimeUtc staticFileName
|> System.DateTimeOffset
|> Some
|> streamFile true staticFileName None
// Home page directory without the directory slash // Home page directory without the directory slash
if textLink = "" then yield redirectTo true (webLog.RelativeUrl Permalink.Empty) if textLink = "" then yield redirectTo true (webLog.RelativeUrl Permalink.Empty)
let permalink = Permalink textLink[1..] let permalink = Permalink textLink[1..]
@@ -34,9 +46,8 @@ module CatchAll =
yield Post.chapters post yield Post.chapters post
else else
yield fun next ctx -> yield fun next ctx ->
Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data { await (Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data) with
|> await PageTitle = post.Title }
|> addToHash ViewContext.PageTitle post.Title
|> themedView (defaultArg post.Template "single-post") next ctx |> themedView (defaultArg post.Template "single-post") next ctx
| None -> () | None -> ()
// Current page // Current page
@@ -44,9 +55,9 @@ module CatchAll =
| Some page -> | Some page ->
debug (fun () -> "Found page by permalink") debug (fun () -> "Found page by permalink")
yield fun next ctx -> yield fun next ctx ->
hashForPage page.Title { viewCtxForPage page.Title with
|> addToHash "page" (DisplayPage.FromPage webLog page) Payload = DisplayPage.FromPage webLog page
|> addToHash ViewContext.IsPage true IsPage = true }
|> themedView (defaultArg page.Template "single-page") next ctx |> themedView (defaultArg page.Template "single-page") next ctx
| None -> () | None -> ()
// RSS feed // RSS feed
@@ -88,7 +99,6 @@ module CatchAll =
let route : HttpHandler = fun next ctx -> let route : HttpHandler = fun next ctx ->
match deriveAction ctx |> Seq.tryHead with Some handler -> handler next ctx | None -> Error.notFound next ctx match deriveAction ctx |> Seq.tryHead with Some handler -> handler next ctx | None -> Error.notFound next ctx
/// Serve theme assets /// Serve theme assets
module Asset = module Asset =
@@ -104,159 +114,142 @@ module Asset =
} }
/// The primary myWebLog router /// Router to deal with regex routes and routes served by pages, posts, and feeds
let router : HttpHandler = choose [ let regexRouter: HttpHandler = choose [
DELETE >=> routexp "/admin/upload/disk/(.*)" Upload.deleteFromDisk
GET_HEAD >=> choose [ GET_HEAD >=> choose [
route "/" >=> Post.home routexp "/category/(.*)" Post.pageOfCategorizedPosts
routexp "/tag/(.*)" Post.pageOfTaggedPosts
routexp "/themes/(.*)" Asset.serve
routexp "/upload/(.*)" Upload.serve
CatchAll.route
] ]
subRoute "/admin" (requireUser >=> choose [ ]
GET_HEAD >=> choose [
route "/administration" >=> Admin.Dashboard.admin open Giraffe.EndpointRouting
subRoute "/categor" (requireAccess WebLogAdmin >=> choose [
route "ies" >=> Admin.Category.all /// The primary myWebLog routes / endpoints
routef "y/%s/edit" Admin.Category.edit let endpoints = [
]) GET_HEAD [ route "/" Post.home ]
route "/dashboard" >=> Admin.Dashboard.user subRoute "/admin" [
route "/my-info" >=> User.myInfo GET_HEAD [
subRoute "/page" (choose [ route "/administration" Admin.Dashboard.admin
route "s" >=> Page.all 1 subRoute "/categor" [
routef "s/page/%i" Page.all route "ies" Admin.Category.all
routef "/%s/edit" Page.edit routef "y/%s/edit" Admin.Category.edit
routef "/%s/permalinks" Page.editPermalinks ]
routef "/%s/revision/%s/preview" Page.previewRevision route "/dashboard" Admin.Dashboard.user
routef "/%s/revisions" Page.editRevisions route "/my-info" User.myInfo
]) subRoute "/page" [
subRoute "/post" (choose [ route "s" (Page.all 1)
route "s" >=> Post.all 1 routef "s/page/%i" Page.all
routef "s/page/%i" Post.all routef "/%s/edit" Page.edit
routef "/%s/edit" Post.edit routef "/%s/permalinks" Page.editPermalinks
routef "/%s/permalinks" Post.editPermalinks routef "/%s/revision/%s/preview" Page.previewRevision
routef "/%s/revision/%s/preview" Post.previewRevision routef "/%s/revisions" Page.editRevisions
routef "/%s/revisions" Post.editRevisions ]
routef "/%s/chapter/%i" Post.editChapter subRoute "/post" [
routef "/%s/chapters" Post.manageChapters route "s" (Post.all 1)
]) routef "s/page/%i" Post.all
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ routef "/%s/edit" Post.edit
route "" >=> Admin.WebLog.settings routef "/%s/permalinks" Post.editPermalinks
routef "/rss/%s/edit" Feed.editCustomFeed routef "/%s/revision/%s/preview" Post.previewRevision
subRoute "/redirect-rules" (choose [ routef "/%s/revisions" Post.editRevisions
route "" >=> Admin.RedirectRules.all routef "/%s/chapter/%i" Post.editChapter
routef "/%i" Admin.RedirectRules.edit routef "/%s/chapters" Post.manageChapters
]) ]
subRoute "/tag-mapping" (choose [ subRoute "/settings" [
route "s" >=> Admin.TagMapping.all route "" Admin.WebLog.settings
routef "/%s/edit" Admin.TagMapping.edit routef "/rss/%s/edit" Feed.editCustomFeed
]) subRoute "/redirect-rules" [
subRoute "/user" (choose [ route "" Admin.RedirectRules.all
route "s" >=> User.all routef "/%i" Admin.RedirectRules.edit
routef "/%s/edit" User.edit ]
]) subRoute "/tag-mapping" [
]) route "s" Admin.TagMapping.all
subRoute "/theme" (choose [ routef "/%s/edit" Admin.TagMapping.edit
route "/list" >=> Admin.Theme.all ]
route "/new" >=> Admin.Theme.add subRoute "/user" [
]) route "s" User.all
subRoute "/upload" (choose [ routef "/%s/edit" User.edit
route "s" >=> Upload.list ]
route "/new" >=> Upload.showNew ]
]) subRoute "/theme" [
route "/list" Admin.Theme.all
route "/new" Admin.Theme.add
]
subRoute "/upload" [
route "s" Upload.list
route "/new" Upload.showNew
]
] ]
POST >=> validateCsrf >=> choose [ POST [
subRoute "/cache" (choose [ subRoute "/cache" [
routef "/theme/%s/refresh" Admin.Cache.refreshTheme routef "/theme/%s/refresh" Admin.Cache.refreshTheme
routef "/web-log/%s/refresh" Admin.Cache.refreshWebLog routef "/web-log/%s/refresh" Admin.Cache.refreshWebLog
]) ]
subRoute "/category" (requireAccess WebLogAdmin >=> choose [ route "/category/save" Admin.Category.save
route "/save" >=> Admin.Category.save route "/my-info" User.saveMyInfo
routef "/%s/delete" Admin.Category.delete subRoute "/page" [
]) route "/save" Page.save
route "/my-info" >=> User.saveMyInfo route "/permalinks" Page.savePermalinks
subRoute "/page" (choose [ routef "/%s/revision/%s/restore" Page.restoreRevision
route "/save" >=> Page.save ]
route "/permalinks" >=> Page.savePermalinks subRoute "/post" [
routef "/%s/revision/%s/restore" Page.restoreRevision route "/save" Post.save
]) route "/permalinks" Post.savePermalinks
subRoute "/post" (choose [ routef "/%s/chapter/%i" Post.saveChapter
route "/save" >=> Post.save routef "/%s/revision/%s/restore" Post.restoreRevision
route "/permalinks" >=> Post.savePermalinks ]
routef "/%s/chapter/%i" Post.saveChapter subRoute "/settings" [
routef "/%s/revision/%s/restore" Post.restoreRevision route "" Admin.WebLog.saveSettings
]) subRoute "/rss" [
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ route "" Feed.saveSettings
route "" >=> Admin.WebLog.saveSettings route "/save" Feed.saveCustomFeed
subRoute "/rss" (choose [ ]
route "" >=> Feed.saveSettings subRoute "/redirect-rules" [
route "/save" >=> Feed.saveCustomFeed
])
subRoute "/redirect-rules" (choose [
routef "/%i" Admin.RedirectRules.save routef "/%i" Admin.RedirectRules.save
routef "/%i/up" Admin.RedirectRules.moveUp routef "/%i/up" Admin.RedirectRules.moveUp
routef "/%i/down" Admin.RedirectRules.moveDown routef "/%i/down" Admin.RedirectRules.moveDown
]) ]
route "/tag-mapping/save" >=> Admin.TagMapping.save route "/tag-mapping/save" Admin.TagMapping.save
route "/user/save" >=> User.save route "/user/save" User.save
]) ]
subRoute "/theme" (choose [ subRoute "/theme" [
route "/new" >=> Admin.Theme.save route "/new" Admin.Theme.save
routef "/%s/delete" Admin.Theme.delete routef "/%s/delete" Admin.Theme.delete
]) ]
route "/upload/save" >=> Upload.save route "/upload/save" Upload.save
] ]
DELETE >=> validateCsrf >=> choose [ DELETE [
routef "/category/%s" Admin.Category.delete routef "/category/%s" Admin.Category.delete
subRoute "/page" (choose [ subRoute "/page" [
routef "/%s" Page.delete routef "/%s" Page.delete
routef "/%s/revision/%s" Page.deleteRevision routef "/%s/revision/%s" Page.deleteRevision
routef "/%s/revisions" Page.purgeRevisions routef "/%s/revisions" Page.purgeRevisions
]) ]
subRoute "/post" (choose [ subRoute "/post" [
routef "/%s" Post.delete routef "/%s" Post.delete
routef "/%s/chapter/%i" Post.deleteChapter routef "/%s/chapter/%i" Post.deleteChapter
routef "/%s/revision/%s" Post.deleteRevision routef "/%s/revision/%s" Post.deleteRevision
routef "/%s/revisions" Post.purgeRevisions routef "/%s/revisions" Post.purgeRevisions
]) ]
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ subRoute "/settings" [
routef "/redirect-rules/%i" Admin.RedirectRules.delete routef "/redirect-rules/%i" Admin.RedirectRules.delete
routef "/rss/%s" Feed.deleteCustomFeed routef "/rss/%s" Feed.deleteCustomFeed
routef "/tag-mapping/%s" Admin.TagMapping.delete routef "/tag-mapping/%s" Admin.TagMapping.delete
routef "/user/%s" User.delete routef "/user/%s" User.delete
]) ]
subRoute "/upload" (requireAccess WebLogAdmin >=> choose [ routef "/upload/%s" Upload.deleteFromDb
routexp "/disk/(.*)" Upload.deleteFromDisk
routef "/%s" Upload.deleteFromDb
])
] ]
]) ]
GET_HEAD >=> routexp "/category/(.*)" Post.pageOfCategorizedPosts subRoute "/user" [
GET_HEAD >=> routef "/page/%i" Post.pageOfPosts GET_HEAD [ route "/log-on" (User.logOn None) ]
GET_HEAD >=> routef "/page/%i/" Post.redirectToPageOfPosts POST [
GET_HEAD >=> routexp "/tag/(.*)" Post.pageOfTaggedPosts route "/log-off" User.logOff
GET_HEAD >=> routexp "/themes/(.*)" Asset.serve route "/log-on" User.doLogOn
GET_HEAD >=> routexp "/upload/(.*)" Upload.serve
subRoute "/user" (choose [
GET_HEAD >=> choose [
route "/log-on" >=> User.logOn None
route "/log-off" >=> User.logOff
] ]
POST >=> validateCsrf >=> choose [ ]
route "/log-on" >=> User.doLogOn GET_HEAD [ routef "/page/%i" Post.pageOfPosts ]
] route "{**url}" regexRouter
])
GET_HEAD >=> CatchAll.route
Error.notFound
] ]
/// Wrap a router in a sub-route
let routerWithPath extraPath : HttpHandler =
subRoute extraPath router
/// Handler to apply Giraffe routing with a possible sub-route
let handleRoute : HttpHandler = fun next ctx ->
let extraPath = ctx.WebLog.ExtraPath
(if extraPath = "" then router else routerWithPath extraPath) next ctx
open Giraffe.EndpointRouting
/// Endpoint-routed handler to deal with sub-routes
let endpoint = [ route "{**url}" handleRoute ]
+93 -82
View File
@@ -90,86 +90,95 @@ open MyWebLog.ViewModels
let makeSlug it = (Regex """\s+""").Replace((Regex "[^A-z0-9 -]").Replace(it, ""), "-").ToLowerInvariant() let makeSlug it = (Regex """\s+""").Replace((Regex "[^A-z0-9 -]").Replace(it, ""), "-").ToLowerInvariant()
// GET /admin/uploads // GET /admin/uploads
let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { let list : HttpHandler =
let webLog = ctx.WebLog requireAccess Author
let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id >=> fun next ctx -> task {
let diskUploads = let webLog = ctx.WebLog
let path = Path.Combine(uploadDir, webLog.Slug) let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id
try let diskUploads =
Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories) let path = Path.Combine(uploadDir, webLog.Slug)
|> Seq.map (fun file -> try
let name = Path.GetFileName file Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories)
let create = |> Seq.map (fun file ->
match File.GetCreationTime(Path.Combine(path, file)) with let name = Path.GetFileName file
| dt when dt > DateTime.UnixEpoch -> Some dt let create =
| _ -> None match File.GetCreationTime(Path.Combine(path, file)) with
{ DisplayUpload.Id = "" | dt when dt > DateTime.UnixEpoch -> Some dt
Name = name | _ -> None
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/') { DisplayUpload.Id = ""
UpdatedOn = create Name = name
Source = string Disk }) Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/')
with UpdatedOn = create
| :? DirectoryNotFoundException -> [] // This is fine Source = string Disk })
| ex -> with
warn "Upload" ctx $"Encountered {ex.GetType().Name} listing uploads for {path}:\n{ex.Message}" | :? DirectoryNotFoundException -> [] // This is fine
[] | ex ->
return! warn "Upload" ctx $"Encountered {ex.GetType().Name} listing uploads for {path}:\n{ex.Message}"
dbUploads []
|> Seq.ofList return!
|> Seq.map (DisplayUpload.FromUpload webLog Database) dbUploads
|> Seq.append diskUploads |> Seq.ofList
|> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path) |> Seq.map (DisplayUpload.FromUpload webLog Database)
|> Views.WebLog.uploadList |> Seq.append diskUploads
|> adminPage "Uploaded Files" true next ctx |> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path)
} |> Views.WebLog.uploadList
|> adminPage "Uploaded Files" next ctx
}
// GET /admin/upload/new // GET /admin/upload/new
let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> let showNew : HttpHandler =
adminPage "Upload a File" true next ctx Views.WebLog.uploadNew requireAccess Author
>=> fun next ctx -> adminPage "Upload a File" next ctx Views.WebLog.uploadNew
// POST /admin/upload/save // POST /admin/upload/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let save : HttpHandler =
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then requireAccess Author
let upload = Seq.head ctx.Request.Form.Files >=> validateCsrf
let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName), >=> fun next ctx -> task {
Path.GetExtension(upload.FileName).ToLowerInvariant()) if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
let now = Noda.now () let upload = Seq.head ctx.Request.Form.Files
let localNow = ctx.WebLog.LocalTime now let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName),
let year = localNow.ToString "yyyy" Path.GetExtension(upload.FileName).ToLowerInvariant())
let month = localNow.ToString "MM" let now = Noda.now ()
let! form = ctx.BindFormAsync<UploadFileModel>() let localNow = ctx.WebLog.LocalTime now
let year = localNow.ToString "yyyy"
let month = localNow.ToString "MM"
let! form = ctx.BindFormAsync<UploadFileModel>()
match UploadDestination.Parse form.Destination with match UploadDestination.Parse form.Destination with
| Database -> | Database ->
use stream = new MemoryStream() use stream = new MemoryStream()
do! upload.CopyToAsync stream do! upload.CopyToAsync stream
let file = let file =
{ Id = UploadId.Create() { Id = UploadId.Create()
WebLogId = ctx.WebLog.Id WebLogId = ctx.WebLog.Id
Path = Permalink $"{year}/{month}/{fileName}" Path = Permalink $"{year}/{month}/{fileName}"
UpdatedOn = now UpdatedOn = now
Data = stream.ToArray() } Data = stream.ToArray() }
do! ctx.Data.Upload.Add file do! ctx.Data.Upload.Add file
| Disk -> | Disk ->
let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month) let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month)
let _ = Directory.CreateDirectory fullPath let _ = Directory.CreateDirectory fullPath
use stream = new FileStream(Path.Combine(fullPath, fileName), FileMode.Create) use stream = new FileStream(Path.Combine(fullPath, fileName), FileMode.Create)
do! upload.CopyToAsync stream do! upload.CopyToAsync stream
do! addMessage ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" } do! addMessage
return! redirectToGet "admin/uploads" next ctx ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" }
else return! redirectToGet "admin/uploads" next ctx
return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx else
} return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx
}
// DELETE /admin/upload/{id} // DELETE /admin/upload/{id}
let deleteFromDb upId : HttpHandler = fun next ctx -> task { let deleteFromDb upId : HttpHandler =
match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.Id with requireAccess WebLogAdmin
| Ok fileName -> >=> fun next ctx -> task {
do! addMessage ctx { UserMessage.Success with Message = $"{fileName} deleted successfully" } match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.Id with
return! list next ctx | Ok fileName ->
| Error _ -> return! Error.notFound next ctx do! addMessage ctx { UserMessage.Success with Message = $"{fileName} deleted successfully" }
} return! list next ctx
| Error _ -> return! Error.notFound next ctx
}
/// Remove a directory tree if it is empty /// Remove a directory tree if it is empty
let removeEmptyDirectories (webLog: WebLog) (filePath: string) = let removeEmptyDirectories (webLog: WebLog) (filePath: string) =
@@ -183,13 +192,15 @@ let removeEmptyDirectories (webLog: WebLog) (filePath: string) =
else finished <- true else finished <- true
// DELETE /admin/upload/disk/{**path} // DELETE /admin/upload/disk/{**path}
let deleteFromDisk urlParts : HttpHandler = fun next ctx -> task { let deleteFromDisk urlParts : HttpHandler =
let filePath = urlParts |> Seq.skip 1 |> Seq.head requireAccess WebLogAdmin
let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath) >=> fun next ctx -> task {
if File.Exists path then let filePath = urlParts |> Seq.skip 1 |> Seq.head
File.Delete path let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath)
removeEmptyDirectories ctx.WebLog filePath if File.Exists path then
do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" } File.Delete path
return! list next ctx removeEmptyDirectories ctx.WebLog filePath
else return! Error.notFound next ctx do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" }
} return! list next ctx
else return! Error.notFound next ctx
}
+145 -130
View File
@@ -35,7 +35,7 @@ let logOn returnUrl : HttpHandler = fun next ctx ->
match returnUrl with match returnUrl with
| Some _ -> returnUrl | Some _ -> returnUrl
| None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None | 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 open System.Security.Claims
@@ -43,38 +43,40 @@ open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
// POST /user/log-on // POST /user/log-on
let doLogOn : HttpHandler = fun next ctx -> task { let doLogOn : HttpHandler =
let! model = ctx.BindFormAsync<LogOnModel>() validateCsrf
let data = ctx.Data >=> fun next ctx -> task {
let! tryUser = data.WebLogUser.FindByEmail (model.EmailAddress.ToLowerInvariant()) ctx.WebLog.Id let! model = ctx.BindFormAsync<LogOnModel>()
match! verifyPassword tryUser model.Password ctx with let data = ctx.Data
| Ok _ -> let! tryUser = data.WebLogUser.FindByEmail (model.EmailAddress.ToLowerInvariant()) ctx.WebLog.Id
let user = tryUser.Value match! verifyPassword tryUser model.Password ctx with
let claims = seq { | Ok _ ->
Claim(ClaimTypes.NameIdentifier, string user.Id) let user = tryUser.Value
Claim(ClaimTypes.Name, $"{user.FirstName} {user.LastName}") let claims = seq {
Claim(ClaimTypes.GivenName, user.PreferredName) Claim(ClaimTypes.NameIdentifier, string user.Id)
Claim(ClaimTypes.Role, string user.AccessLevel) Claim(ClaimTypes.Name, $"{user.FirstName} {user.LastName}")
} Claim(ClaimTypes.GivenName, user.PreferredName)
let identity = ClaimsIdentity(claims, CookieAuthenticationDefaults.AuthenticationScheme) Claim(ClaimTypes.Role, string user.AccessLevel)
}
let identity = ClaimsIdentity(claims, CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync(identity.AuthenticationType, ClaimsPrincipal identity, do! ctx.SignInAsync(identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties(IssuedUtc = DateTimeOffset.UtcNow)) AuthenticationProperties(IssuedUtc = DateTimeOffset.UtcNow))
do! data.WebLogUser.SetLastSeen user.Id user.WebLogId do! data.WebLogUser.SetLastSeen user.Id user.WebLogId
do! addMessage ctx do! addMessage ctx
{ UserMessage.Success with { UserMessage.Success with
Message = "Log on successful" Message = "Log on successful"
Detail = Some $"Welcome to {ctx.WebLog.Name}!" } Detail = Some $"Welcome to {ctx.WebLog.Name}!" }
return! return!
match model.ReturnTo with match model.ReturnTo with
| Some url -> redirectTo false url next ctx // TODO: change to redirectToGet? | Some url -> redirectTo false url next ctx // TODO: change to redirectToGet?
| None -> redirectToGet "admin/dashboard" next ctx | None -> redirectToGet "admin/dashboard" next ctx
| Error msg -> | Error msg ->
do! addMessage ctx { UserMessage.Error with Message = msg } do! addMessage ctx { UserMessage.Error with Message = msg }
return! logOn model.ReturnTo next ctx return! logOn model.ReturnTo next ctx
} }
// GET /user/log-off // POST /user/log-off
let logOff : HttpHandler = fun next ctx -> task { let logOff : HttpHandler = fun next ctx -> task {
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
do! addMessage ctx { UserMessage.Info with Message = "Log off successful" } do! addMessage ctx { UserMessage.Info with Message = "Log off successful" }
@@ -89,118 +91,131 @@ open Giraffe.Htmx
let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?"
// GET /admin/settings/users // GET /admin/settings/users
let all : HttpHandler = fun next ctx -> task { let all : HttpHandler =
let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id requireAccess WebLogAdmin
return! adminBarePage "User Administration" true next ctx (Views.User.userList users) >=> fun next ctx -> task {
} let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id
return! adminBarePage "User Administration" next ctx (Views.User.userList users)
}
/// Show the edit user page /// Show the edit user page
let private showEdit (model: EditUserModel) : HttpHandler = fun next ctx -> 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 // GET /admin/settings/user/{id}/edit
let edit usrId : HttpHandler = fun next ctx -> task { let edit usrId : HttpHandler =
let isNew = usrId = "new" requireAccess WebLogAdmin
let userId = WebLogUserId usrId >=> fun next ctx -> task {
let tryUser = let isNew = usrId = "new"
if isNew then someTask { WebLogUser.Empty with Id = userId } let userId = WebLogUserId usrId
else ctx.Data.WebLogUser.FindById userId ctx.WebLog.Id let tryUser =
match! tryUser with if isNew then someTask { WebLogUser.Empty with Id = userId }
| Some user -> return! showEdit (EditUserModel.FromUser user) next ctx else ctx.Data.WebLogUser.FindById userId ctx.WebLog.Id
| None -> return! Error.notFound next ctx match! tryUser with
} | Some user -> return! showEdit (EditUserModel.FromUser user) next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/settings/user/{id} // DELETE /admin/settings/user/{id}
let delete userId : HttpHandler = fun next ctx -> task { let delete userId : HttpHandler =
let data = ctx.Data requireAccess WebLogAdmin
match! data.WebLogUser.FindById (WebLogUserId userId) ctx.WebLog.Id with >=> fun next ctx -> task {
| Some user -> let data = ctx.Data
if user.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then match! data.WebLogUser.FindById (WebLogUserId userId) ctx.WebLog.Id with
return! goAway next ctx | Some user ->
else if user.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then
match! data.WebLogUser.Delete user.Id user.WebLogId with return! goAway next ctx
| Ok _ -> else
do! addMessage ctx match! data.WebLogUser.Delete user.Id user.WebLogId with
{ UserMessage.Success with | Ok _ ->
Message = $"User {user.DisplayName} deleted successfully" } do! addMessage ctx
return! all next ctx { UserMessage.Success with Message = $"User {user.DisplayName} deleted successfully" }
| Error msg -> return! all next ctx
do! addMessage ctx | Error msg ->
{ UserMessage.Error with do! addMessage ctx
Message = $"User {user.DisplayName} was not deleted" { UserMessage.Error with
Detail = Some msg } Message = $"User {user.DisplayName} was not deleted"
return! all next ctx Detail = Some msg }
| None -> return! Error.notFound next ctx return! all next ctx
} | None -> return! Error.notFound next ctx
}
// GET /admin/my-info // GET /admin/my-info
let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { let myInfo : HttpHandler =
match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with requireAccess Author
| Some user -> >=> fun next ctx -> task {
return! match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
Views.User.myInfo (EditMyInfoModel.FromUser user) user | Some user ->
|> adminPage "Edit Your Information" true next ctx return!
| None -> return! Error.notFound next ctx Views.User.myInfo (EditMyInfoModel.FromUser user) user
} |> adminPage "Edit Your Information" next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/my-info // POST /admin/my-info
let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { let saveMyInfo : HttpHandler =
let! model = ctx.BindFormAsync<EditMyInfoModel>() requireAccess Author
let data = ctx.Data >=> validateCsrf
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with >=> fun next ctx -> task {
| Some user when model.NewPassword = model.NewPasswordConfirm -> let! model = ctx.BindFormAsync<EditMyInfoModel>()
let pw = if model.NewPassword = "" then user.PasswordHash else createPasswordHash user model.NewPassword let data = ctx.Data
let user = match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
{ user with | Some user when model.NewPassword = model.NewPasswordConfirm ->
FirstName = model.FirstName let pw = if model.NewPassword = "" then user.PasswordHash else createPasswordHash user model.NewPassword
LastName = model.LastName let user =
PreferredName = model.PreferredName { user with
PasswordHash = pw } FirstName = model.FirstName
do! data.WebLogUser.Update user LastName = model.LastName
let pwMsg = if model.NewPassword = "" then "" else " and updated your password" PreferredName = model.PreferredName
do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" } PasswordHash = pw }
return! redirectToGet "admin/my-info" next ctx do! data.WebLogUser.Update user
| Some user -> let pwMsg = if model.NewPassword = "" then "" else " and updated your password"
do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" } do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" }
return! return! redirectToGet "admin/my-info" next ctx
Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user | Some user ->
|> adminPage "Edit Your Information" true next ctx do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" }
| None -> return! Error.notFound next ctx return!
} Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user
|> adminPage "Edit Your Information" next ctx
| None -> return! Error.notFound next ctx
}
// User save is not statically compilable; not sure why, but we'll revisit it at some point // User save is not statically compilable; not sure why, but we'll revisit it at some point
#nowarn "3511" #nowarn "3511"
// POST /admin/settings/user/save // POST /admin/settings/user/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let save : HttpHandler =
let! model = ctx.BindFormAsync<EditUserModel>() requireAccess WebLogAdmin
let data = ctx.Data >=> validateCsrf
let tryUser = >=> fun next ctx -> task {
if model.IsNew then let! model = ctx.BindFormAsync<EditUserModel>()
{ WebLogUser.Empty with let data = ctx.Data
Id = WebLogUserId.Create() let tryUser =
WebLogId = ctx.WebLog.Id if model.IsNew then
CreatedOn = Noda.now () } { WebLogUser.Empty with
|> someTask Id = WebLogUserId.Create()
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id WebLogId = ctx.WebLog.Id
match! tryUser with CreatedOn = Noda.now () }
| Some user when model.Password = model.PasswordConfirm -> |> someTask
let updatedUser = model.UpdateUser user else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then match! tryUser with
return! goAway next ctx | Some user when model.Password = model.PasswordConfirm ->
else let updatedUser = model.UpdateUser user
let toUpdate = if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then
if model.Password = "" then updatedUser return! goAway next ctx
else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password } else
do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate let toUpdate =
do! addMessage ctx if model.Password = "" then updatedUser
{ UserMessage.Success with else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password }
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully""" } do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate
return! all next ctx do! addMessage ctx
| Some _ -> { UserMessage.Success with
do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" } Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully""" }
return! return! all next ctx
(withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" }) | Some _ ->
next ctx do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" }
| None -> return! Error.notFound next ctx return!
} (withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" })
next ctx
| None -> return! Error.notFound next ctx
}
+13 -12
View File
@@ -1,4 +1,4 @@
<Project Sdk="Microsoft.NET.Sdk"> <Project Sdk="Microsoft.NET.Sdk.Web">
<PropertyGroup> <PropertyGroup>
<OutputType>Exe</OutputType> <OutputType>Exe</OutputType>
@@ -7,8 +7,9 @@
</PropertyGroup> </PropertyGroup>
<ItemGroup> <ItemGroup>
<Content Include="appsettings*.json" CopyToOutputDirectory="Always" />
<Compile Include="Caches.fs" /> <Compile Include="Caches.fs" />
<Compile Include="ViewContext.fs" />
<Compile Include="Template.fs" />
<Compile Include="Views\Helpers.fs" /> <Compile Include="Views\Helpers.fs" />
<Compile Include="Views\Admin.fs" /> <Compile Include="Views\Admin.fs" />
<Compile Include="Views\Page.fs" /> <Compile Include="Views\Page.fs" />
@@ -23,21 +24,21 @@
<Compile Include="Handlers\User.fs" /> <Compile Include="Handlers\User.fs" />
<Compile Include="Handlers\Upload.fs" /> <Compile Include="Handlers\Upload.fs" />
<Compile Include="Handlers\Routes.fs" /> <Compile Include="Handlers\Routes.fs" />
<Compile Include="DotLiquidBespoke.fs" />
<Compile Include="Maintenance.fs" /> <Compile Include="Maintenance.fs" />
<Compile Include="ProgramSupport.fs" />
<Compile Include="Program.fs" /> <Compile Include="Program.fs" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.0.0" /> <PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" />
<PackageReference Include="DotLiquid" Version="2.2.692" /> <PackageReference Include="Fluid.Core" />
<PackageReference Include="Giraffe" Version="6.4.0" /> <PackageReference Include="FSharp.Core" />
<PackageReference Include="Giraffe.Htmx" Version="2.0.0" /> <PackageReference Include="Giraffe" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="2.0.0" /> <PackageReference Include="Giraffe.Htmx" />
<PackageReference Include="NeoSmart.Caching.Sqlite.AspNetCore" Version="8.0.0" /> <PackageReference Include="Giraffe.ViewEngine.Htmx" />
<PackageReference Include="RethinkDB.DistributedCache" Version="1.0.0-rc1" /> <PackageReference Include="NeoSmart.Caching.Sqlite.AspNetCore" />
<PackageReference Include="System.ServiceModel.Syndication" Version="8.0.0" /> <PackageReference Include="RethinkDB.DistributedCache" />
<PackageReference Update="FSharp.Core" Version="8.0.300" /> <PackageReference Include="System.ServiceModel.Syndication" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
+74 -164
View File
@@ -1,111 +1,4 @@
open Microsoft.AspNetCore.Http /// Show a list of valid command-line interface commands
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Configuration
open Microsoft.Extensions.Logging
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}"
match WebLogCache.tryGet path with
| Some webLog ->
if isDebug then log.LogDebug $"Resolved web log {webLog.Id} for {path}"
ctx.Items["webLog"] <- webLog
if PageListCache.exists ctx then () else do! PageListCache.update ctx
if CategoryCache.exists ctx then () else do! CategoryCache.update ctx
return! next.Invoke ctx
| None ->
if isDebug then log.LogDebug $"No resolved web log for {path}"
ctx.Response.StatusCode <- 404
}
/// Middleware to check redirects for the current web log
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 =
WebLogCache.redirectRules ctx.WebLog.Id
|> List.tryPick (fun rule ->
match rule with
| WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) ->
if ciEquals path urlFrom then Some urlTo else None
| WebLogCache.CachedRedirectRule.RegEx (regExFrom, patternTo) ->
if regExFrom.IsMatch path then Some (regExFrom.Replace(path, patternTo)) else None)
match matched with
| Some url -> ctx.Response.Redirect(url, permanent = true)
| None -> return! next.Invoke ctx
}
open System
open System.IO
open BitBadger.Documents
open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data
open Newtonsoft.Json
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")
let _ = builder.UseNodaTime()
// let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore))
(builder.Build >> Postgres.Configuration.useDataSource) ()
/// Get the configured data implementation
let get (sp: IServiceProvider) : IData =
let config = sp.GetRequiredService<IConfiguration>()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
let connStr name = config.GetConnectionString name
let hasConnStr name = (connStr >> isNull >> not) name
let createSQLite connStr : IData =
Sqlite.Configuration.useConnectionString connStr
let log = sp.GetRequiredService<ILogger<SQLiteData>>()
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 rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log)
RethinkDbData(conn, rethinkCfg, log)
elif hasConnStr "PostgreSQL" then
createNpgsqlDataSource config
use conn = Postgres.Configuration.dataSource().CreateConnection()
let log = sp.GetRequiredService<ILogger<PostgresData>>()
log.LogInformation $"Using PostgreSQL database {conn.Database}"
PostgresData(log, Json.configure (JsonSerializer.CreateDefault()))
else
if not (Directory.Exists "./data") then Directory.CreateDirectory "./data" |> ignore
createSQLite "Data Source=./data/myweblog.db;Cache=Shared"
open System.Threading.Tasks
/// Show a list of valid command-line interface commands
let showHelp () = let showHelp () =
printfn " " printfn " "
printfn "COMMAND WHAT IT DOES" printfn "COMMAND WHAT IT DOES"
@@ -121,39 +14,57 @@ let showHelp () =
printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator" printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator"
printfn " " printfn " "
printfn "For more information on a particular command, run it with no options." printfn "For more information on a particular command, run it with no options."
Task.FromResult() System.Threading.Tasks.Task.FromResult()
open BitBadger.AspNetCore.CanonicalDomains open System
open Giraffe open System.IO
open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.Hosting
open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.HttpOverrides open Microsoft.AspNetCore.HttpOverrides
open Microsoft.Extensions.Caching.Distributed open Microsoft.Extensions.Caching.Distributed
open NeoSmart.Caching.Sqlite.AspNetCore open Microsoft.Extensions.Configuration
open Microsoft.Extensions.DependencyInjection
open Microsoft.Data.Sqlite
open BitBadger.AspNetCore.CanonicalDomains
open BitBadger.Documents
open Giraffe
open Giraffe.EndpointRouting
open NeoSmart.Caching.Sqlite
open Newtonsoft.Json
open Npgsql
open RethinkDB.DistributedCache open RethinkDB.DistributedCache
open MyWebLog
open MyWebLog.Data
[<EntryPoint>] [<EntryPoint>]
let main args = let main args =
let builder = WebApplication.CreateBuilder(args) let builder = WebApplication.CreateBuilder(
let _ = builder.Services.Configure<ForwardedHeadersOptions>(fun (opts : ForwardedHeadersOptions) -> WebApplicationOptions(
opts.ForwardedHeaders <- ForwardedHeaders.XForwardedFor ||| ForwardedHeaders.XForwardedProto) ContentRootPath = Directory.GetCurrentDirectory(),
let _ = WebRootPath = Path.Combine(Directory.GetCurrentDirectory(), "wwwroot"),
builder.Services Args = args))
.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme) let _ = builder.WebHost.UseStaticWebAssets()
.AddCookie(fun opts -> builder.Services
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 60. .Configure<ForwardedHeadersOptions>(
opts.SlidingExpiration <- true fun (opts: ForwardedHeadersOptions) ->
opts.AccessDeniedPath <- "/forbidden") opts.ForwardedHeaders <- ForwardedHeaders.XForwardedFor ||| ForwardedHeaders.XForwardedProto)
let _ = builder.Services.AddLogging() .AddLogging()
let _ = builder.Services.AddAuthorization() .AddAuthorization()
let _ = builder.Services.AddAntiforgery() .AddAntiforgery()
.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie(fun opts ->
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 60.
opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/forbidden")
|> ignore
let sp = builder.Services.BuildServiceProvider() let sp = builder.Services.BuildServiceProvider()
let data = DataImplementation.get sp let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task { task {
do! data.StartUp() do! data.StartUp()
@@ -165,39 +76,37 @@ let main args =
match data with match data with
| :? RethinkDbData as rethink -> | :? RethinkDbData as rethink ->
// A RethinkDB connection is designed to work as a singleton // A RethinkDB connection is designed to work as a singleton
let _ = builder.Services.AddSingleton<IData> data builder.Services
let _ = .AddSingleton<IData>(data)
builder.Services.AddDistributedRethinkDBCache(fun opts -> .AddDistributedRethinkDBCache(fun opts ->
opts.TableName <- "Session" opts.TableName <- "Session"
opts.Connection <- rethink.Conn) opts.Connection <- rethink.Conn)
() |> ignore
| :? SQLiteData -> | :? SQLiteData ->
// ADO.NET connections are designed to work as per-request instantiation // ADO.NET connections are designed to work as per-request instantiation; use SQLite for caching as well
let cfg = sp.GetRequiredService<IConfiguration>() let cfg = sp.GetRequiredService<IConfiguration>()
let _ = builder.Services.AddScoped<SqliteConnection>(fun sp -> Sqlite.Configuration.dbConn ())
let _ = builder.Services.AddScoped<IData, SQLiteData>()
// Use SQLite for caching as well
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./data/session.db" let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./data/session.db"
let _ = builder.Services.AddSqliteCache(fun o -> o.CachePath <- cachePath) builder.Services
() .AddScoped<SqliteConnection>(fun sp -> Sqlite.Configuration.dbConn ())
.AddScoped<IData, SQLiteData>()
.AddSqliteCache(fun o -> o.CachePath <- cachePath)
|> ignore
| :? PostgresData as postgres -> | :? PostgresData as postgres ->
// ADO.NET Data Sources are designed to work as singletons // ADO.NET Data Sources are designed to work as singletons
let _ = builder.Services.AddSingleton<NpgsqlDataSource>(Postgres.Configuration.dataSource ()) builder.Services
let _ = builder.Services.AddSingleton<IData> postgres .AddSingleton<NpgsqlDataSource>(Postgres.Configuration.dataSource ())
let _ = .AddSingleton<IData>(postgres)
builder.Services.AddSingleton<IDistributedCache>(fun _ -> .AddSingleton<IDistributedCache>(fun _ -> Postgres.DistributedCache() :> IDistributedCache)
Postgres.DistributedCache() :> IDistributedCache) |> ignore
()
| _ -> () | _ -> ()
let _ = builder.Services.AddSession(fun opts -> builder.Services
opts.IdleTimeout <- TimeSpan.FromMinutes 60 .AddSession(fun opts ->
opts.Cookie.HttpOnly <- true opts.IdleTimeout <- TimeSpan.FromMinutes 60.
opts.Cookie.IsEssential <- true) opts.Cookie.HttpOnly <- true
let _ = builder.Services.AddGiraffe() opts.Cookie.IsEssential <- true)
.AddGiraffe()
// Set up DotLiquid |> ignore
DotLiquidBespoke.register ()
let app = builder.Build() let app = builder.Build()
@@ -225,20 +134,21 @@ let main args =
let _ = app.UseForwardedHeaders() let _ = app.UseForwardedHeaders()
(app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value match (app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value with
|> (isNull >> not) | null -> ()
|> function true -> app.UseCanonicalDomains() |> ignore | false -> () | _ -> app.UseCanonicalDomains() |> ignore
let _ = app.UseCookiePolicy(CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) app .UseCookiePolicy(CookiePolicyOptions(MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware>() .UseMiddleware<WebLogMiddleware>()
let _ = app.UseMiddleware<RedirectRuleMiddleware>() .UseMiddleware<RedirectRuleMiddleware>()
let _ = app.UseAuthentication() .UseAuthentication()
let _ = app.UseStaticFiles() .UseStaticFiles()
let _ = app.UseRouting() .UseRouting()
let _ = app.UseSession() .UseSession()
let _ = app.UseGiraffe Handlers.Routes.endpoint .UseGiraffe Handlers.Routes.endpoints
|> ignore
app.Run() do! app.RunAsync()
} }
|> Async.AwaitTask |> Async.RunSynchronously |> Async.AwaitTask |> Async.RunSynchronously
+109
View File
@@ -0,0 +1,109 @@
namespace MyWebLog
open Microsoft.AspNetCore.Http
open Microsoft.Extensions.Logging
/// 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}"
match WebLogCache.tryGet path with
| Some webLog ->
if isDebug then log.LogDebug $"Resolved web log {webLog.Id} for {path}"
ctx.Items["webLog"] <- webLog
if PageListCache.exists ctx then () else do! PageListCache.update ctx
if CategoryCache.exists ctx then () else do! CategoryCache.update ctx
if webLog.ExtraPath <> "" then
ctx.Request.PathBase <- PathString(webLog.ExtraPath)
ctx.Request.Path <- PathString(ctx.Request.Path.Value[webLog.ExtraPath.Length ..])
return! next.Invoke ctx
| None ->
log.LogWarning $"No resolved web log for {path}"
ctx.Response.StatusCode <- 404
}
open System
open Giraffe.Htmx
/// Middleware to check redirects for the current web log
type RedirectRuleMiddleware(next: RequestDelegate, _log: ILogger<RedirectRuleMiddleware>) =
/// Shorthand for case-insensitive string equality
let ciEquals str1 str2 =
String.Equals(str1, str2, StringComparison.InvariantCultureIgnoreCase)
member _.InvokeAsync(ctx: HttpContext) = task {
let path = ctx.Request.Path.Value.ToLower()[1..]
let matched =
WebLogCache.redirectRules ctx.WebLog.Id
|> List.tryPick (fun rule ->
match rule with
| WebLogCache.CachedRedirectRule.Text(urlFrom, urlTo) ->
if ciEquals path urlFrom then Some urlTo else None
| WebLogCache.CachedRedirectRule.RegEx(regExFrom, patternTo) ->
if regExFrom.IsMatch path then regExFrom.Replace(path, patternTo) |> Some else None)
match matched with
| Some url when url.StartsWith "http" && ctx.Request.IsHtmx ->
do! ctx.Response.WriteAsync $"""<script>window.location.href = "{url}"</script>"""
| Some url -> ctx.Response.Redirect(url, permanent = true)
| None -> return! next.Invoke ctx
}
/// Logic to obtain a data connection and implementation based on configured values
module DataImplementation =
open System.IO
open Microsoft.Extensions.Configuration
open Microsoft.Extensions.DependencyInjection
open BitBadger.Documents
open Newtonsoft.Json
open Npgsql
open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net
open MyWebLog.Data
open MyWebLog.Converters
/// Create an NpgsqlDataSource from the connection string, configuring appropriately
let createNpgsqlDataSource (cfg: IConfiguration) =
let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL")
let _ = builder.UseNodaTime()
// let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore))
(builder.Build >> Postgres.Configuration.useDataSource) ()
/// Get the configured data implementation
let get (sp: IServiceProvider) : IData =
let config = sp.GetRequiredService<IConfiguration>()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
let connStr name = config.GetConnectionString name
let hasConnStr name = (connStr >> isNull >> not) name
let createSQLite connStr : IData =
Sqlite.Configuration.useConnectionString connStr
let log = sp.GetRequiredService<ILogger<SQLiteData>>()
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 rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log)
RethinkDbData(conn, rethinkCfg, log)
elif hasConnStr "PostgreSQL" then
createNpgsqlDataSource config
use conn = Postgres.Configuration.dataSource().CreateConnection()
let log = sp.GetRequiredService<ILogger<PostgresData>>()
log.LogInformation $"Using PostgreSQL database {conn.Database}"
PostgresData(log, Json.configure (JsonSerializer.CreateDefault()))
else
if not (Directory.Exists "./data") then Directory.CreateDirectory "./data" |> ignore
createSQLite "Data Source=./data/myweblog.db;Cache=Shared"
+402
View File
@@ -0,0 +1,402 @@
/// <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 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
match input with
| :? NilValue -> $"-- {name} not found --"
| it ->
(it :?> ArrayValue).Values
|> Seq.tryPick picker
|> Option.defaultValue $"-- {name} not found --"
|> sValue)
// A filter to search through a collection of objects for a matching property
it.Filters.AddFilter("where",
fun input args ctx ->
let name = args.At(0).ToStringValue()
let value = args.At(1).ToStringValue()
input.Enumerate(ctx)
|> Seq.filter (fun it ->
let theItem = it.ToObjectValue()
match theItem.GetType().GetProperties() |> Array.tryFind (fun x -> x.Name = name) with
| Some pi -> pi.GetValue(theItem) = value
| None -> false)
|> Seq.toArray
|> ArrayValue :> FluidValue
|> VTask)
it
open Giraffe.Htmx.Common
open Fluid.Ast
/// <summary>Fluid parser customized with myWebLog filters and tags</summary>
let parser =
// spacer
let s = " "
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 attrEnc = System.Web.HttpUtility.HtmlAttributeEncode
// OpenGraph tags
let doOpenGraph =
(app.WebLog.AutoOpenGraph && (app.IsPage || app.IsPost))
|| (app.IsPage && Option.isSome app.Page.OpenGraph)
|| (app.IsPost && Option.isSome app.Posts.Posts[0].OpenGraph)
if doOpenGraph then
let writeOgProp (name, value) =
writer.WriteLine $"""{s}<meta property=%s{name} content="{attrEnc value}">"""
writeOgProp ("og:title", if app.IsPage then app.Page.Title else app.Posts.Posts[0].Title)
writeOgProp ("og:site_name", app.WebLog.Name)
if app.IsPage then app.Page.Permalink else app.Posts.Posts[0].Permalink
|> Permalink
|> app.WebLog.AbsoluteUrl
|> function url -> writeOgProp ("og:url", url)
let fallback =
if assetExists "favicon.ico" app.WebLog then Some $"theme/{app.WebLog.ThemeId}/favicon.ico"
else None
match if app.IsPage then app.Page.OpenGraph else app.Posts.Posts[0].OpenGraph with
| Some props -> props.ToProperties app.WebLog.UrlToAbsolute fallback |> Seq.iter writeOgProp
| None -> ()
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.Model.ToObjectValue() :?> AppViewContext).Slug
writer.WriteLine(feedLink app.WebLog.Name $"category/{slug}/{app.WebLog.Rss.FeedName}")
if app.WebLog.Rss.IsTagEnabled && app.IsTagHome then
let slug = (context.Model.ToObjectValue() :?> AppViewContext).Slug
writer.WriteLine(feedLink app.WebLog.Name $"tag/{slug}/{app.WebLog.Rss.FeedName}")
if app.IsPost then
let url = app.WebLog.AbsoluteUrl(Permalink app.Posts.Posts[0].Permalink)
writer.WriteLine $"""{s}<link rel=canonical href="{url}">"""
if app.IsPage then
let url = app.WebLog.AbsoluteUrl(Permalink app.Page.Permalink)
writer.WriteLine $"""{s}<link rel=canonical href="{url}">"""
VTask(Completion.Normal))
// 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
match webLog.AutoHtmx with
| NoAutoHtmx -> None
| AutoHtmx -> (Permalink >> Some) StaticAssetUrl.htmx[1..]
| AutoHtmax -> (Permalink >> Some) StaticAssetUrl.htmax[1..]
|> function
| Some url ->
context.App.WebLog.RelativeUrl url
|> sprintf "%s<script src=\"%s\"></script>" s
|> writer.WriteLine
| None -> ()
if assetExists "script.js" webLog then
themeAsset (StringValue "script.js") context
|> sprintf "%s<script src=\"%s\"></script>" s
|> writer.WriteLine
VTask(Completion.Normal))
// 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>"""
let logOffLink = link "user/log-off"
"<li class=nav-item>"
$"<form id=mwl-log-off method=post action={logOffLink}>"
$"<a class=nav-link href={logOffLink} onclick=\"document.getElementById('mwl-log-off').submit(); return false\">Log Off</a></form>"
| false ->
$"""<li class=nav-item><a class=nav-link href="{link "user/log-on"}">Log On</a>"""
"</ul>"
}
|> Seq.iter writer.WriteLine
VTask(Completion.Normal))
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
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
/// <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>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>The model for this view (prior versions used <c>model</c> for the v3 <c>payload</c>)</summary>
member this.Model =
this.Payload
/// <summary>An empty view context</summary>
static member Empty =
{ WebLog = WebLog.Empty
UserId = None
PageTitle = ""
Subtitle = ""
Csrf = None
PageList = [||]
Categories = [||]
TagMappings = [||]
CurrentPage = ""
Messages = [||]
Generator = ""
Payload = obj ()
Content = ""
IsAuthor = false
IsEditor = false
IsWebLogAdmin = false
IsAdministrator = false
IsHome = false
IsCategory = false
IsCategoryHome = false
IsTag = false
IsTagHome = false
IsPost = false
IsPage = false
Slug = None }
+15 -10
View File
@@ -6,9 +6,12 @@ open Giraffe.ViewEngine.Htmx
open MyWebLog open MyWebLog
open MyWebLog.ViewModels 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 dashboard (themes: Theme list) app = [
let templates = TemplateCache.allNames () let templates = Template.Cache.allNames ()
let cacheBaseUrl = relUrl app "admin/cache/" let cacheBaseUrl = relUrl app "admin/cache/"
let webLogCacheUrl = $"{cacheBaseUrl}web-log/" let webLogCacheUrl = $"{cacheBaseUrl}web-log/"
let themeCacheUrl = $"{cacheBaseUrl}theme/" let themeCacheUrl = $"{cacheBaseUrl}theme/"
@@ -42,7 +45,8 @@ let dashboard (themes: Theme list) app = [
article [] [ article [] [
fieldset [ _class "container mb-3 pb-0" ] [ fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Themes" ] legend [] [ raw "Themes" ]
span [ _hxGet (relUrl app "admin/theme/list"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] [] span [ _hxGet (relUrl app "admin/theme/list"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml
_hxTarget "this" ] []
] ]
fieldset [ _class "container mb-3 pb-0" ] [ fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Caches" ] legend [] [ raw "Caches" ]
@@ -62,8 +66,8 @@ let dashboard (themes: Theme list) app = [
raw "These caches include the page list and categories for each web log" raw "These caches include the page list and categories for each web log"
] ]
let webLogUrl = $"{cacheBaseUrl}web-log/" let webLogUrl = $"{cacheBaseUrl}web-log/"
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body" form [ _method "post"; _class "container g-0"; hxInherited (_hxTarget "body")
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [ hxInherited (_hxSwap $"{HxSwap.InnerHtml} show:top showTarget:body") ] [
antiCsrf app antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2" button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{webLogUrl}all/refresh" ] [ _hxPost $"{webLogUrl}all/refresh" ] [
@@ -83,8 +87,8 @@ let dashboard (themes: Theme list) app = [
raw "The theme template cache is filled on demand as pages are displayed; " raw "The theme template cache is filled on demand as pages are displayed; "
raw "refreshing a theme with no cached templates will still refresh its asset cache" raw "refreshing a theme with no cached templates will still refresh its asset cache"
] ]
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body" form [ _method "post"; _class "container g-0"
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [ hxInherited (_hxSwap $"{HxSwap.InnerHtml} show:top showTarget:body") ] [
antiCsrf app antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2" button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{themeCacheUrl}all/refresh" ] [ _hxPost $"{themeCacheUrl}all/refresh" ] [
@@ -108,8 +112,9 @@ let themeList (model: DisplayTheme list) app =
let themeCol = "col-12 col-md-6" let themeCol = "col-12 col-md-6"
let slugCol = "d-none d-md-block col-md-3" let slugCol = "d-none d-md-block col-md-3"
let tmplCol = "d-none d-md-block col-md-3" let tmplCol = "d-none d-md-block col-md-3"
let newUrl = relUrl app "admin/theme/new"
div [ _id "theme_panel" ] [ div [ _id "theme_panel" ] [
a [ _href (relUrl app "admin/theme/new"); _class "btn btn-primary btn-sm mb-3"; _hxTarget "#theme_new" ] [ a [ _href newUrl; _hxGet newUrl; _class "btn btn-primary btn-sm mb-3"; _hxTarget "#theme_new" ] [
raw "Upload a New Theme" raw "Upload a New Theme"
] ]
div [ _class "container g-0" ] [ div [ _class "container g-0" ] [
@@ -121,7 +126,7 @@ let themeList (model: DisplayTheme list) app =
] ]
div [ _class "row mwl-table-detail"; _id "theme_new" ] [] div [ _class "row mwl-table-detail"; _id "theme_new" ] []
form [ _method "post"; _id "themeList"; _class "container g-0"; _hxTarget "#theme_panel" form [ _method "post"; _id "themeList"; _class "container g-0"; _hxTarget "#theme_panel"
_hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ _hxSwap $"{HxSwap.OuterHtml} show:top showTarget:body" ] [
antiCsrf app antiCsrf app
for theme in model do for theme in model do
let url = relUrl app $"admin/theme/{theme.Id}" let url = relUrl app $"admin/theme/{theme.Id}"
@@ -158,7 +163,7 @@ let themeUpload app =
div [ _class "col" ] [ div [ _class "col" ] [
h5 [ _class "mt-2" ] [ raw app.PageTitle ] h5 [ _class "mt-2" ] [ raw app.PageTitle ]
form [ _action (relUrl app "admin/theme/new"); _method "post"; _class "container" form [ _action (relUrl app "admin/theme/new"); _method "post"; _class "container"
_enctype "multipart/form-data"; _hxNoBoost ] [ _enctype "multipart/form-data" ] [
antiCsrf app antiCsrf app
div [ _class "row " ] [ div [ _class "row " ] [
div [ _class "col-12 col-sm-6 pb-3" ] [ div [ _class "col-12 col-sm-6 pb-3" ] [
+314 -99
View File
@@ -1,7 +1,8 @@
/// <summary>Helpers available for all myWebLog views</summary>
[<AutoOpen>] [<AutoOpen>]
module MyWebLog.Views.Helpers module MyWebLog.Views.Helpers
open Microsoft.AspNetCore.Antiforgery open Giraffe.Htmx
open Giraffe.ViewEngine open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility open Giraffe.ViewEngine.Accessibility
open Giraffe.ViewEngine.Htmx open Giraffe.ViewEngine.Htmx
@@ -10,78 +11,35 @@ open MyWebLog.ViewModels
open NodaTime open NodaTime
open NodaTime.Text open NodaTime.Text
/// The rendering context for this application /// <summary>Create a relative URL for the current web log</summary>
[<NoComparison; NoEquality>] /// <param name="app">The app view context for the current view</param>
type AppViewContext = { /// <returns>A function that, given a string, will construct a relative URL</returns>
/// 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
let relUrl app = let relUrl app =
Permalink >> app.WebLog.RelativeUrl 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 = let antiCsrf app =
input [ _type "hidden"; _name app.Csrf.Value.FormFieldName; _value app.Csrf.Value.RequestToken ] 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 let txt = encodedText
/// Shorthand for raw text in a template /// <summary>Shorthand for raw text in a template</summary>
let raw = rawText 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" let _relNoOpener = _rel "noopener"
/// The pattern for a long date /// <summary>The pattern for a long date</summary>
let longDatePattern = let longDatePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("MMMM d, yyyy", DateTimeZoneProviders.Tzdb) 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) = let longDate app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone] DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj |> Option.ofObj
@@ -89,11 +47,14 @@ let longDate app (instant: Instant) =
|> Option.defaultValue "--" |> Option.defaultValue "--"
|> txt |> txt
/// The pattern for a short time /// <summary>The pattern for a short time</summary>
let shortTimePattern = let shortTimePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("h:mmtt", DateTimeZoneProviders.Tzdb) 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) = let shortTime app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone] DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj |> Option.ofObj
@@ -101,11 +62,19 @@ let shortTime app (instant: Instant) =
|> Option.defaultValue "--" |> Option.defaultValue "--"
|> txt |> 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 = let yesOrNo value =
raw (if value then "Yes" else "No") 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 extractAttrValue name attrs =
let valueAttr = attrs |> List.tryFind (fun x -> match x with KeyValue (key, _) when key = name -> true | _ -> false) let valueAttr = attrs |> List.tryFind (fun x -> match x with KeyValue (key, _) when key = name -> true | _ -> false)
match valueAttr with match valueAttr with
@@ -114,7 +83,14 @@ let extractAttrValue name attrs =
attrs |> List.filter (fun x -> match x with KeyValue (key, _) when key = name -> false | _ -> true) attrs |> List.filter (fun x -> match x with KeyValue (key, _) when key = name -> false | _ -> true)
| Some _ | None -> None, attrs | 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 inputField fieldType attrs name labelText value extra =
let fieldId, attrs = extractAttrValue "id" attrs let fieldId, attrs = extractAttrValue "id" attrs
let cssClass, attrs = extractAttrValue "class" attrs let cssClass, attrs = extractAttrValue "class" attrs
@@ -127,23 +103,58 @@ let inputField fieldType attrs name labelText value extra =
yield! 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 = let textField attrs name labelText value extra =
inputField "text" 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 = let numberField attrs name labelText value extra =
inputField "number" 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 = let emailField attrs name labelText value extra =
inputField "email" 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 = let passwordField attrs name labelText value extra =
inputField "password" 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> let selectField<'T, 'a>
attrs name labelText value (values: 'T seq) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra = attrs name labelText value (values: 'T seq) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra =
let cssClass, attrs = extractAttrValue "class" attrs let cssClass, attrs = extractAttrValue "class" attrs
@@ -157,7 +168,13 @@ let selectField<'T, 'a>
yield! extra 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 checkboxSwitch attrs name labelText (value: bool) extra =
let cssClass, attrs = extractAttrValue "class" attrs let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-check form-switch {defaultArg cssClass ""}""" ] [ div [ _class $"""form-check form-switch {defaultArg cssClass ""}""" ] [
@@ -168,15 +185,15 @@ let checkboxSwitch attrs name labelText (value: bool) extra =
yield! extra yield! extra
] ]
/// A standard save button /// <summary>A standard save button</summary>
let saveButton = let saveButton =
button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ] 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 = let actionSpacer =
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
/// Functions for generating content in varying layouts /// <summary>Functions for generating content in varying layouts</summary>
module Layout = module Layout =
/// Generate the title tag for a page /// Generate the title tag for a page
@@ -186,18 +203,18 @@ module Layout =
/// Create a navigation link /// Create a navigation link
let private navLink app name url = let private navLink app name url =
let extraPath = app.WebLog.ExtraPath let extraPath = app.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/" let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
let active = if app.CurrentPage.StartsWith $"{path}{url}" then " active" else "" let active = if app.CurrentPage.StartsWith $"{path}{url}" then " active" else ""
li [ _class "nav-item" ] [ let linkUrl = relUrl app url
a [ _class $"nav-link{active}"; _href (relUrl app url) ] [ txt name ] li [ _class "nav-item" ] [ a [ _class $"nav-link{active}"; _href linkUrl; _hxBoost ] [ txt name ] ]
]
/// Create a page view for the given content /// Create a page view for the given content
let private pageView (content: AppViewContext -> XmlNode list) app = [ let private pageView (content: AppViewContext -> XmlNode list) app = [
header [] [ header [] [
nav [ _class "navbar navbar-dark bg-dark navbar-expand-md justify-content-start px-2 position-fixed top-0 w-100" ] [ nav [ _class "navbar navbar-dark bg-dark navbar-expand-md justify-content-start px-2 position-fixed top-0 w-100"
hxInherited (_hxTarget "body") ] [
div [ _class "container-fluid" ] [ div [ _class "container-fluid" ] [
a [ _class "navbar-brand"; _href (relUrl app ""); _hxNoBoost ] [ txt app.WebLog.Name ] a [ _class "navbar-brand"; _href (relUrl app "") ] [ txt app.WebLog.Name ]
button [ _type "button"; _class "navbar-toggler"; _data "bs-toggle" "collapse" button [ _type "button"; _class "navbar-toggler"; _data "bs-toggle" "collapse"
_data "bs-target" "#navbarText"; _ariaControls "navbarText"; _ariaExpanded "false" _data "bs-target" "#navbarText"; _ariaControls "navbarText"; _ariaExpanded "false"
_ariaLabel "Toggle navigation" ] [ _ariaLabel "Toggle navigation" ] [
@@ -227,8 +244,11 @@ module Layout =
] ]
if app.IsLoggedOn then if app.IsLoggedOn then
li [ _class "nav-item" ] [ li [ _class "nav-item" ] [
a [ _class "nav-link"; _href (relUrl app "user/log-off"); _hxNoBoost ] [ form [ _id "mwl-log-off"; _method "post"; _action (relUrl app "user/log-off") ] [
raw "Log Off" a [ _class "nav-link"; _href (relUrl app "user/log-off")
_onclick "document.getElementById('mwl-log-off').submit(); return false" ] [
raw "Log Off"
]
] ]
] ]
else else
@@ -273,14 +293,20 @@ 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 = let partial content app =
html [ _lang "en" ] [ html [ _lang "en" ] [
titleTag app titleTag app
yield! pageView content 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 = let full content app =
html [ _lang "en" ] [ html [ _lang "en" ] [
meta [ _name "viewport"; _content "width=device-width, initial-scale=1" ] meta [ _name "viewport"; _content "width=device-width, initial-scale=1" ]
@@ -290,17 +316,20 @@ module Layout =
_integrity "sha384-1BmE4kWBq78iYhFldvKuhfTAU6auU8tT94WrHftjDbrCEXSU1oBoqyl2QvZ6jIW3" _integrity "sha384-1BmE4kWBq78iYhFldvKuhfTAU6auU8tT94WrHftjDbrCEXSU1oBoqyl2QvZ6jIW3"
_crossorigin "anonymous" ] _crossorigin "anonymous" ]
link [ _rel "stylesheet"; _href (relUrl app "themes/admin/admin.css") ] link [ _rel "stylesheet"; _href (relUrl app "themes/admin/admin.css") ]
body [ _hxBoost; _hxIndicator "#loadOverlay" ] [ body [ hxInherited (_hxIndicator "#loadOverlay"); hxInherited (_hxTarget "body") ] [
yield! pageView content app yield! pageView content app
script [ _src "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/js/bootstrap.bundle.min.js" script [ _src "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/js/bootstrap.bundle.min.js"
_integrity "sha384-ka7Sk0Gln4gmtz2MlQnikT1wXgYsOg+OMhuP+IlRH9sENBO0LRn5q+8nbTov4+1p" _integrity "sha384-ka7Sk0Gln4gmtz2MlQnikT1wXgYsOg+OMhuP+IlRH9sENBO0LRn5q+8nbTov4+1p"
_crossorigin "anonymous" ] [] _crossorigin "anonymous" ] []
Script.minified script [ _src (relUrl app StaticAssetUrl.htmx[1..]) ] []
script [ _src (relUrl app "themes/admin/admin.js") ] [] 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 = let bare (content: AppViewContext -> XmlNode list) app =
html [ _lang "en" ] [ html [ _lang "en" ] [
title [] [] title [] []
@@ -309,16 +338,18 @@ module Layout =
// ~~ SHARED TEMPLATES BETWEEN POSTS AND PAGES // ~~ 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" let roundTrip = InstantPattern.CreateWithInvariantCulture "uuuu'-'MM'-'dd'T'HH':'mm':'ss'.'fffffff"
/// Capitalize the first letter in the given string /// Capitalize the first letter in the given string
let private capitalize (it: string) = let private capitalize (it: string) =
$"{(string it[0]).ToUpper()}{it[1..]}" $"{(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 = [ let commonEdit (model: EditCommonModel) app = [
textField [ _class "mb-3"; _required; _autofocus ] (nameof model.Title) "Title" model.Title [] textField [ _class "mb-3"; _required; _autofocus ] (nameof model.Title) "Title" model.Title []
textField [ _class "mb-3"; _required ] (nameof model.Permalink) "Permalink" model.Permalink [ textField [ _class "mb-3"; _required ] (nameof model.Permalink) "Permalink" model.Permalink [
@@ -334,7 +365,7 @@ let commonEdit (model: EditCommonModel) app = [
] ]
] ]
div [ _class "mb-2" ] [ div [ _class "mb-2" ] [
label [ _for "text" ] [ raw "Text" ]; raw " &nbsp; &nbsp; " raw "Text"; raw " &nbsp; &nbsp; "
div [ _class "btn-group btn-group-sm"; _roleGroup; _ariaLabel "Text format button group" ] [ div [ _class "btn-group btn-group-sm"; _roleGroup; _ariaLabel "Text format button group" ] [
input [ _type "radio"; _name (nameof model.Source); _id "source_html"; _class "btn-check" input [ _type "radio"; _name (nameof model.Source); _id "source_html"; _class "btn-check"
_value "HTML"; if model.Source = "HTML" then _checked ] _value "HTML"; if model.Source = "HTML" then _checked ]
@@ -352,19 +383,194 @@ 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) = let commonTemplates (model: EditCommonModel) (templates: MetaItem seq) =
selectField [ _class "mb-3" ] (nameof model.Template) $"{capitalize model.Entity} Template" model.Template templates 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 OpenGraph data edit form</summary>
/// <param name="model">The edit model</param>
/// <returns>Fields for editing OpenGraph data for a page or post</returns>
let commonOpenGraph (model: EditCommonModel) =
fieldset [ _class "mb-3" ] [
legend [] [
span [ _class "form-check form-switch" ] [
small [] [
input [ _type "checkbox"; _name (nameof model.AssignOpenGraph)
_id (nameof model.AssignOpenGraph); _class "form-check-input"; _value "true"
_data "bs-toggle" "collapse"; _data "bs-target" "#og_props"
_onclick "Admin.toggleOpenGraphFields()"; if model.AssignOpenGraph then _checked ]
]
label [ _for (nameof model.AssignOpenGraph) ] [ raw "OpenGraph Properties" ]
]
]
div [ _id "og_props"; _class $"""container p-0 collapse{if model.AssignOpenGraph then " show" else ""}""" ] [
fieldset [ _id "og_item" ] [
legend [] [ raw "Item Details" ]
div [ _class "row p-0" ] [
div [ _class "mb-3 col-xs-6 col-md-3" ] [
selectField [ _required ] (nameof model.OpenGraphType) "Type" model.OpenGraphType
OpenGraphType.Selections fst snd []
]
div [ _class "mb-3 col-xs-6 col-md-3" ] [
textField [] (nameof model.OpenGraphLocale) "Locale" model.OpenGraphLocale
[ span [ _class "form-text" ] [ raw "ex. en-US" ] ]
]
div [ _class "mb-3 col-xs-6 col-md-4" ] [
textField [] (nameof model.OpenGraphAlternateLocales) "Alternate Locales"
model.OpenGraphAlternateLocales
[ span [ _class "form-text" ] [ raw "comma separated" ] ]
]
div [ _class "mb-3 col-xs-6 col-md-2" ] [
textField [] (nameof model.OpenGraphDeterminer) "Determiner" model.OpenGraphDeterminer
[ span [ _class "form-text" ] [ raw "a/an/the"; br []; raw "(blank = auto)" ] ]
]
div [ _class "mb-3 col-12" ] [
textField [] (nameof model.OpenGraphDescription) "Short Description" model.OpenGraphDescription
[]
]
]
]
fieldset [ _id "og_image" ] [
legend [] [ raw "Image" ]
div [ _class "row p-0" ] [
let syncJS = $"Admin.pathOrFile('{nameof model.OpenGraphImageUrl}', 'OpenGraphImageFile')"
div [ _class "mb-3 col-12" ] [
textField [ _onkeyup syncJS ] (nameof model.OpenGraphImageUrl) "Existing Image URL"
model.OpenGraphImageUrl []
]
div [ _class "mb-3 col-12" ] [
if model.OpenGraphImageUrl = "" then
div [ _class "form-floating" ] [
input [ _type "file"; _id "OpenGraphImageFile"; _name "OpenGraphImageFile"
_class "form-control"; _accept "image/*"; _oninput syncJS ]
label [ _for "OpenGraphImageFile" ] [ raw "Upload Image File" ]
]
else
input [ _type "hidden"; _id "OpenGraphImageFile"; _name "OpenGraphImageFile" ]
]
div [ _class "mb-3 col-12" ] [
textField [] (nameof model.OpenGraphImageAlt) "Alternate Text" model.OpenGraphImageAlt []
]
div [ _class "mb-3 col-6" ] [
textField [] (nameof model.OpenGraphImageType) "MIME Type" model.OpenGraphImageType
[ span [ _class "form-text" ] [ raw "Leave blank to derive type from extension" ] ]
]
div [ _class "mb-3 col-3" ] [
numberField [] (nameof model.OpenGraphImageWidth) "Width" model.OpenGraphImageWidth
[ span [ _class "form-text" ] [ raw "px" ] ]
]
div [ _class "mb-3 col-3" ] [
numberField [] (nameof model.OpenGraphImageHeight) "Height" model.OpenGraphImageHeight
[ span [ _class "form-text" ] [ raw "px" ] ]
]
]
]
fieldset [ _id "og_audio" ] [
legend [] [ raw "Audio" ]
div [ _class "row p-0" ] [
let syncJS = $"Admin.pathOrFile('{nameof model.OpenGraphAudioUrl}', 'OpenGraphAudioFile')"
div [ _class "mb-3 col-12" ] [
textField [ _onkeyup syncJS ] (nameof model.OpenGraphAudioUrl) "Existing Audio URL"
model.OpenGraphAudioUrl []
]
div [ _class "mb-3 col-12" ] [
if model.OpenGraphAudioUrl = "" then
div [ _class "form-floating" ] [
input [ _type "file"; _id "OpenGraphAudioFile"; _name "OpenGraphAudioFile"
_class "form-control"; _accept "image/*"; _oninput syncJS ]
label [ _for "OpenGraphAudioFile" ] [ raw "Upload Audio File" ]
]
else
input [ _type "hidden"; _id "OpenGraphAudioFile"; _name "OpenGraphAudioFile" ]
]
div [ _class "mb-3 col-6" ] [
textField [] (nameof model.OpenGraphAudioType) "MIME Type" model.OpenGraphAudioType
[ span [ _class "form-text" ] [ raw "Leave blank to derive type from extension" ] ]
]
]
]
fieldset [ _id "og_video" ] [
legend [] [ raw "Video" ]
div [ _class "row p-0" ] [
let syncJS = $"Admin.pathOrFile('{nameof model.OpenGraphVideoUrl}', 'OpenGraphVideoFile')"
div [ _class "mb-3 col-12" ] [
textField [ _onkeyup syncJS ] (nameof model.OpenGraphVideoUrl) "Existing Video URL"
model.OpenGraphVideoUrl []
]
div [ _class "mb-3 col-12" ] [
if model.OpenGraphVideoUrl = "" then
div [ _class "form-floating" ] [
input [ _type "file"; _id "OpenGraphVideoFile"; _name "OpenGraphVideoFile"
_class "form-control"; _accept "image/*"; _oninput syncJS ]
label [ _for "OpenGraphVideoFile" ] [ raw "Upload Video File" ]
]
else
input [ _type "hidden"; _id "OpenGraphVideoFile"; _name "OpenGraphVideoFile" ]
]
div [ _class "mb-3 col-6" ] [
textField [] (nameof model.OpenGraphVideoType) "MIME Type" model.OpenGraphVideoType
[ span [ _class "form-text" ] [ raw "Leave blank to derive type from extension" ] ]
]
div [ _class "mb-3 col-3" ] [
numberField [] (nameof model.OpenGraphVideoWidth) "Width" model.OpenGraphVideoWidth
[ span [ _class "form-text" ] [ raw "px" ] ]
]
div [ _class "mb-3 col-3" ] [
numberField [] (nameof model.OpenGraphVideoHeight) "Height" model.OpenGraphVideoHeight
[ span [ _class "form-text" ] [ raw "px" ] ]
]
]
]
fieldset [] [
legend [] [ raw "Extra Properties" ]
let items = Array.zip model.OpenGraphExtraNames model.OpenGraphExtraValues
let extraDetail idx (name, value) =
div [ _id $"og_extra_%i{idx}"; _class "row mb-3" ] [
div [ _class "col-1 text-center align-self-center" ] [
button [ _type "button"; _class "btn btn-sm btn-danger"
_onclick $"Admin.removeMetaItem('og_extra', {idx})" ] [
raw "&minus;"
]
]
div [ _class "col-3" ] [
textField [ _id $"{nameof model.OpenGraphExtraNames}_{idx}" ]
(nameof model.OpenGraphExtraNames) "Name" name []
]
div [ _class "col-8" ] [
textField [ _id $"{nameof model.OpenGraphExtraValues}_{idx}" ]
(nameof model.OpenGraphExtraValues) "Value" value []
]
]
div [] [
div [ _id "og_extra_items"; _class "container p-0" ] (items |> Array.mapi extraDetail |> List.ofArray)
button [ _type "button"; _class "btn btn-sm btn-secondary"
_onclick "Admin.addMetaItem('og_extra')" ] [
raw "Add an Extra Property"
]
script [] [
raw """document.addEventListener("DOMContentLoaded", """
raw $"() => Admin.setNextExtraIndex({items.Length}))"
]
]
]
]
]
/// <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 commonMetaItems (model: EditCommonModel) =
let items = Array.zip model.MetaNames model.MetaValues let items = Array.zip model.MetaNames model.MetaValues
let metaDetail idx (name, value) = let metaDetail idx (name, value) =
div [ _id $"meta_%i{idx}"; _class "row mb-3" ] [ div [ _id $"meta_%i{idx}"; _class "row mb-3" ] [
div [ _class "col-1 text-center align-self-center" ] [ div [ _class "col-1 text-center align-self-center" ] [
button [ _type "button"; _class "btn btn-sm btn-danger"; _onclick $"Admin.removeMetaItem({idx})" ] [ button [ _type "button"; _class "btn btn-sm btn-danger"
_onclick $"Admin.removeMetaItem('meta', {idx})" ] [
raw "&minus;" raw "&minus;"
] ]
] ]
@@ -382,7 +588,7 @@ let commonMetaItems (model: EditCommonModel) =
] ]
div [ _id "meta_item_container"; _class "collapse" ] [ div [ _id "meta_item_container"; _class "collapse" ] [
div [ _id "meta_items"; _class "container" ] (items |> Array.mapi metaDetail |> List.ofArray) div [ _id "meta_items"; _class "container" ] (items |> Array.mapi metaDetail |> List.ofArray)
button [ _type "button"; _class "btn btn-sm btn-secondary"; _onclick "Admin.addMetaItem()" ] [ button [ _type "button"; _class "btn btn-sm btn-secondary"; _onclick "Admin.addMetaItem('meta')" ] [
raw "Add an Item" raw "Add an Item"
] ]
script [] [ script [] [
@@ -393,7 +599,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 = let commonPreview (rev: Revision) app =
div [ _class "mwl-revision-preview mb-3" ] [ div [ _class "mwl-revision-preview mb-3" ] [
rev.Text.AsHtml() |> addBaseToRelativeUrls app.WebLog.ExtraPath |> raw rev.Text.AsHtml() |> addBaseToRelativeUrls app.WebLog.ExtraPath |> raw
@@ -401,7 +610,10 @@ let commonPreview (rev: Revision) app =
|> List.singleton |> 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 managePermalinks (model: ManagePermalinksModel) app = [
let baseUrl = relUrl app $"admin/{model.Entity}/" let baseUrl = relUrl app $"admin/{model.Entity}/"
let linkDetail idx link = let linkDetail idx link =
@@ -465,7 +677,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 manageRevisions (model: ManageRevisionsModel) app = [
let revUrlBase = relUrl app $"admin/{model.Entity}/{model.Id}/revision" let revUrlBase = relUrl app $"admin/{model.Entity}/{model.Id}/revision"
let revDetail idx (rev: Revision) = let revDetail idx (rev: Revision) =
@@ -485,7 +700,7 @@ let manageRevisions (model: ManageRevisionsModel) app = [
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href revRestore; _hxPost revRestore ] [ raw "Restore as Current" ] a [ _href revRestore; _hxPost revRestore ] [ raw "Restore as Current" ]
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href revUrlPrefix; _hxDelete revUrlPrefix; _hxTarget $"#{asOfId}" a [ _href revUrlPrefix; _hxDelete revUrlPrefix; _hxTarget $"#{asOfId}"; _hxPushUrl "false"
_hxSwap HxSwap.OuterHtml; _class "text-danger" ] [ _hxSwap HxSwap.OuterHtml; _class "text-danger" ] [
raw "Delete" raw "Delete"
] ]
+47 -54
View File
@@ -7,9 +7,10 @@ open MyWebLog.ViewModels
/// The form to edit pages /// The form to edit pages
let pageEdit (model: EditPageModel) templates app = [ let pageEdit (model: EditPageModel) templates app = [
let url = relUrl app "admin/page/save"
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [] [
form [ _action (relUrl app "admin/page/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [ form [ _action url; _method "post"; _hxPost url; _class "container" ] [
antiCsrf app antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ] input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [ div [ _class "row mb-3" ] [
@@ -29,76 +30,68 @@ let pageEdit (model: EditPageModel) templates app = [
/// Display a list of pages for this web log /// Display a list of pages for this web log
let pageList (pages: DisplayPage list) pageNbr hasNext app = [ let pageList (pages: DisplayPage list) pageNbr hasNext app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [ _class "container mb-3" ] [
a [ _href (relUrl app "admin/page/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Create a New Page" ] a [ _href (relUrl app "admin/page/new/edit"); _hxBoost; _class "btn btn-primary btn-sm mb-3" ] [
raw "Create a New Page"
]
if pages.Length = 0 then if pages.Length = 0 then
p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no pages" ] p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no pages" ]
else else
let titleCol = "col-12 col-md-5" let titleCol = "col-12 col-md-5"
let linkCol = "col-12 col-md-5" let linkCol = "col-12 col-md-5"
let upd8Col = "col-12 col-md-2" let upd8Col = "col-12 col-md-2"
form [ _method "post"; _class "container mb-3"; _hxTarget "body" ] [ div [ _class "row mwl-table-heading" ] [
antiCsrf app div [ _class titleCol ] [
div [ _class "row mwl-table-heading" ] [ span [ _class "d-none d-md-inline" ] [ raw "Title" ]; span [ _class "d-md-none" ] [ raw "Page" ]
div [ _class titleCol ] [
span [ _class "d-none d-md-inline" ] [ raw "Title" ]; span [ _class "d-md-none" ] [ raw "Page" ]
]
div [ _class $"{linkCol} d-none d-md-inline-block" ] [ raw "Permalink" ]
div [ _class $"{upd8Col} d-none d-md-inline-block" ] [ raw "Updated" ]
] ]
for pg in pages do div [ _class $"{linkCol} d-none d-md-inline-block" ] [ raw "Permalink" ]
let pageLink = if pg.IsDefault then "" else pg.Permalink div [ _class $"{upd8Col} d-none d-md-inline-block" ] [ raw "Updated" ]
div [ _class "row mwl-table-detail" ] [ ]
div [ _class titleCol ] [ for pg in pages do
txt pg.Title let pageLink = if pg.IsDefault then "" else pg.Permalink
if pg.IsDefault then div [ _class "row mwl-table-detail" ] [
raw " &nbsp; "; span [ _class "badge bg-success" ] [ raw "HOME PAGE" ] div [ _class titleCol ] [
if pg.IsInPageList then txt pg.Title
raw " &nbsp; "; span [ _class "badge bg-primary" ] [ raw "IN PAGE LIST" ] if pg.IsDefault then
br [] ; small [] [ raw " &nbsp; "; span [ _class "badge bg-success" ] [ raw "HOME PAGE" ]
let adminUrl = relUrl app $"admin/page/{pg.Id}" if pg.IsInPageList then
a [ _href (relUrl app pageLink); _target "_blank" ] [ raw "View Page" ] raw " &nbsp; "; span [ _class "badge bg-primary" ] [ raw "IN PAGE LIST" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId pg.AuthorId) then br [] ; small [] [
span [ _class "text-muted" ] [ raw " &bull; " ] let adminUrl = relUrl app $"admin/page/{pg.Id}"
a [ _href $"{adminUrl}/edit" ] [ raw "Edit" ] a [ _href (relUrl app pageLink); _target "_blank" ] [ raw "View Page" ]
if app.IsWebLogAdmin then if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId pg.AuthorId) then
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href adminUrl; _hxDelete adminUrl; _class "text-danger" a [ _href $"{adminUrl}/edit"; _hxBoost ] [ raw "Edit" ]
_hxConfirm $"Are you sure you want to delete the page &ldquo;{pg.Title}&rdquo;? This action cannot be undone." ] [ if app.IsWebLogAdmin then
raw "Delete" span [ _class "text-muted" ] [ raw " &bull; " ]
] a [ _href adminUrl; _hxDelete adminUrl; _hxTarget "body"; _class "text-danger"
] _hxConfirm $"Are you sure you want to delete the page &ldquo;{pg.Title}&rdquo;? This action cannot be undone." ] [
] raw "Delete"
div [ _class linkCol ] [ ]
small [ _class "d-md-none" ] [ txt pageLink ]
span [ _class "d-none d-md-inline" ] [ txt pageLink ]
]
div [ _class upd8Col ] [
small [ _class "d-md-none text-muted" ] [
raw "Updated "; txt (pg.UpdatedOn.ToString "MMMM d, yyyy")
]
span [ _class "d-none d-md-inline" ] [ txt (pg.UpdatedOn.ToString "MMMM d, yyyy") ]
] ]
] ]
] div [ _class linkCol ] [
small [ _class "d-md-none" ] [ txt pageLink ]
span [ _class "d-none d-md-inline" ] [ txt pageLink ]
]
div [ _class upd8Col ] [
small [ _class "d-md-none text-muted" ] [
raw "Updated "; txt (pg.UpdatedOn.ToString "MMMM d, yyyy")
]
span [ _class "d-none d-md-inline" ] [ txt (pg.UpdatedOn.ToString "MMMM d, yyyy") ]
]
]
if pageNbr > 1 || hasNext then if pageNbr > 1 || hasNext then
let aAttrs link = [ _href (relUrl app link); _hxBoost; _class "btn btn-secondary" ]
div [ _class "d-flex justify-content-evenly mb-3" ] [ div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [ div [] [
if pageNbr > 1 then if pageNbr > 1 then
let prevPage = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}" let prevPage = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
p [] [ p [] [ a (aAttrs $"admin/pages{prevPage}") [ raw "&laquo; Previous" ] ]
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages{prevPage}") ] [
raw "&laquo; Previous"
]
]
] ]
div [ _class "text-right" ] [ div [ _class "text-right" ] [
if hasNext then if hasNext then
p [] [ p [] [ a (aAttrs $"admin/pages/page/{pageNbr + 1}") [ raw "Next &raquo;" ] ]
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages/page/{pageNbr + 1}") ] [
raw "Next &raquo;"
]
]
] ]
] ]
] ]
+19 -22
View File
@@ -102,9 +102,8 @@ let chapterEdit (model: EditChapterModel) app = [
/// Display a list of chapters /// Display a list of chapters
let chapterList withNew (model: ManageChaptersModel) app = let chapterList withNew (model: ManageChaptersModel) app =
form [ _method "post"; _id "chapter_list"; _class "container mb-3"; _hxTarget "this"; _hxSwap HxSwap.OuterHtml ] [ div [ _id "chapter_list"; _class "container mb-3"; hxInherited (_hxTarget "this")
antiCsrf app hxInherited (_hxSwap HxSwap.OuterHtml) ] [
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row mwl-table-heading" ] [ div [ _class "row mwl-table-heading" ] [
div [ _class "col-3 col-md-2" ] [ raw "Start" ] div [ _class "col-3 col-md-2" ] [ raw "Start" ]
div [ _class "col-3 col-md-6 col-lg-8" ] [ raw "Title" ] div [ _class "col-3 col-md-6 col-lg-8" ] [ raw "Title" ]
@@ -125,7 +124,7 @@ let chapterList withNew (model: ManageChaptersModel) app =
else else
let chapterUrl = relUrl app $"admin/post/{model.Id}/chapter/{idx}" let chapterUrl = relUrl app $"admin/post/{model.Id}/chapter/{idx}"
a [ _href chapterUrl; _hxGet chapterUrl; _hxTarget $"#chapter{idx}" a [ _href chapterUrl; _hxGet chapterUrl; _hxTarget $"#chapter{idx}"
_hxSwap $"{HxSwap.InnerHtml} show:#chapter{idx}:top" ] [ _hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#chapter{idx}" ] [
raw "Edit" raw "Edit"
] ]
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
@@ -140,12 +139,13 @@ let chapterList withNew (model: ManageChaptersModel) app =
div [ _class "row pb-3"; _id "chapter-1" ] [ div [ _class "row pb-3"; _id "chapter-1" ] [
let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1" let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1"
if withNew then if withNew then
span [ _hxGet newLink; _hxTarget "#chapter-1"; _hxTrigger "load"; _hxSwap "show:#chapter-1:top" ] [] span [ _hxGet newLink; _hxTarget "#chapter-1"; _hxTrigger "load"
_hxSwap "show:top showTarget:#chapter-1" ] []
else else
div [ _class "row pb-3 mwl-table-detail" ] [ div [ _class "row pb-3 mwl-table-detail" ] [
div [ _class "col-12" ] [ div [ _class "col-12" ] [
a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1" a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1"
_hxSwap "show:#chapter-1:top" ] [ _hxSwap "show:top showTarget:#chapter-1" ] [
raw "Add a New Chapter" raw "Add a New Chapter"
] ]
] ]
@@ -156,12 +156,13 @@ let chapterList withNew (model: ManageChaptersModel) app =
/// Manage Chapters page /// Manage Chapters page
let chapters withNew (model: ManageChaptersModel) app = [ let chapters withNew (model: ManageChaptersModel) app = [
let backUrl = relUrl app $"admin/post/{model.Id}/edit"
h2 [ _class "my-3" ] [ txt app.PageTitle ] h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [ article [] [
p [ _style "line-height:1.2rem;" ] [ p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.Title ]; br [] strong [] [ txt model.Title ]; br []
small [ _class "text-muted" ] [ small [ _class "text-muted" ] [
a [ _href (relUrl app $"admin/post/{model.Id}/edit") ] [ a [ _href backUrl; _hxGet backUrl; _hxPushUrl "true" ] [
raw "&laquo; Back to Edit Post" raw "&laquo; Back to Edit Post"
] ]
] ]
@@ -178,9 +179,11 @@ let list (model: PostDisplay) app = [
let tagCol = "col-lg-3 col-xl-4 col-xxl-5 d-none d-lg-inline-block" let tagCol = "col-lg-3 col-xl-4 col-xxl-5 d-none d-lg-inline-block"
h2 [ _class "my-3" ] [ txt app.PageTitle ] h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [ article [] [
a [ _href (relUrl app "admin/post/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Write a New Post" ] a [ _href (relUrl app "admin/post/new/edit"); _hxBoost; _class "btn btn-primary btn-sm mb-3" ] [
raw "Write a New Post"
]
if model.Posts.Length > 0 then if model.Posts.Length > 0 then
form [ _method "post"; _class "container mb-3"; _hxTarget "body" ] [ form [ _method "post"; _class "container mb-3" ] [
antiCsrf app antiCsrf app
div [ _class "row mwl-table-heading" ] [ div [ _class "row mwl-table-heading" ] [
div [ _class dateCol ] [ div [ _class dateCol ] [
@@ -221,7 +224,7 @@ let list (model: PostDisplay) app = [
a [ _href (relUrl app post.Permalink); _target "_blank" ] [ raw "View Post" ] a [ _href (relUrl app post.Permalink); _target "_blank" ] [ raw "View Post" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId post.AuthorId) then if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId post.AuthorId) then
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href $"{postUrl}/edit" ] [ raw "Edit" ] a [ _href $"{postUrl}/edit"; _hxBoost ] [ raw "Edit" ]
if app.IsWebLogAdmin then if app.IsWebLogAdmin then
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href postUrl; _hxDelete postUrl; _class "text-danger" a [ _href postUrl; _hxDelete postUrl; _class "text-danger"
@@ -254,22 +257,15 @@ let list (model: PostDisplay) app = [
] ]
] ]
if Option.isSome model.NewerLink || Option.isSome model.OlderLink then if Option.isSome model.NewerLink || Option.isSome model.OlderLink then
let aAttrs link = [ _href link; _hxBoost; _class "btn btn-secondary" ]
div [ _class "d-flex justify-content-evenly mb-3" ] [ div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [ div [] [
if Option.isSome model.NewerLink then if Option.isSome model.NewerLink then
p [] [ p [] [ a (aAttrs model.NewerLink.Value) [ raw "&laquo; Newer Posts" ] ]
a [ _href model.NewerLink.Value; _class "btn btn-secondary"; ] [
raw "&laquo; Newer Posts"
]
]
] ]
div [ _class "text-right" ] [ div [ _class "text-right" ] [
if Option.isSome model.OlderLink then if Option.isSome model.OlderLink then
p [] [ p [] [ a (aAttrs model.OlderLink.Value) [ raw "Older Posts &raquo;" ] ]
a [ _href model.OlderLink.Value; _class "btn btn-secondary" ] [
raw "Older Posts &raquo;"
]
]
] ]
] ]
else else
@@ -280,7 +276,7 @@ let list (model: PostDisplay) app = [
let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [ let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [] [
form [ _action (relUrl app "admin/post/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [ form [ _action (relUrl app "admin/post/save"); _method "post"; _hxBoost; _class "container" ] [
antiCsrf app antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ] input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [ div [ _class "row mb-3" ] [
@@ -293,6 +289,7 @@ let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [
checkboxSwitch [ _class "mb-2" ] (nameof model.DoPublish) "Publish This Post" model.DoPublish [] checkboxSwitch [ _class "mb-2" ] (nameof model.DoPublish) "Publish This Post" model.DoPublish []
saveButton saveButton
hr [ _class "mb-3" ] hr [ _class "mb-3" ]
commonOpenGraph model
fieldset [ _class "mb-3" ] [ fieldset [ _class "mb-3" ] [
legend [] [ legend [] [
span [ _class "form-check form-switch" ] [ span [ _class "form-check form-switch" ] [
@@ -355,7 +352,7 @@ let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [
] ]
div [ _class "col-12 col-md-4 pb-3" ] [ div [ _class "col-12 col-md-4 pb-3" ] [
selectField [] (nameof model.Explicit) "Explicit Rating" model.Explicit ratings selectField [] (nameof model.Explicit) "Explicit Rating" model.Explicit ratings
(_.Name) (_.Value) [ _.Name _.Value [
div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ] div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ]
] ]
] ]
+10 -12
View File
@@ -13,7 +13,7 @@ let edit (model: EditUserModel) app =
div [ _class "col-12" ] [ div [ _class "col-12" ] [
h5 [ _class "my-3" ] [ txt app.PageTitle ] h5 [ _class "my-3" ] [ txt app.PageTitle ]
form [ _hxPost (relUrl app "admin/settings/user/save"); _method "post"; _class "container" form [ _hxPost (relUrl app "admin/settings/user/save"); _method "post"; _class "container"
_hxTarget "#user_panel"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ _hxTarget "#user_panel"; _hxSwap $"{HxSwap.OuterHtml} show:top showTarget:body" ] [
antiCsrf app antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ] input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row" ] [ div [ _class "row" ] [
@@ -97,7 +97,7 @@ let edit (model: EditUserModel) app =
let logOn (model: LogOnModel) (app: AppViewContext) = [ let logOn (model: LogOnModel) (app: AppViewContext) = [
h2 [ _class "my-3" ] [ rawText "Log On to "; encodedText app.WebLog.Name ] h2 [ _class "my-3" ] [ rawText "Log On to "; encodedText app.WebLog.Name ]
article [ _class "py-3" ] [ article [ _class "py-3" ] [
form [ _action (relUrl app "user/log-on"); _method "post"; _class "container"; _hxPushUrl "true" ] [ form [ _action (relUrl app "user/log-on"); _method "post"; _hxBoost; _class "container" ] [
antiCsrf app antiCsrf app
if Option.isSome model.ReturnTo then input [ _type "hidden"; _name "ReturnTo"; _value model.ReturnTo.Value ] if Option.isSome model.ReturnTo then input [ _type "hidden"; _name "ReturnTo"; _value model.ReturnTo.Value ]
div [ _class "row" ] [ div [ _class "row" ] [
@@ -138,13 +138,13 @@ let userList (model: WebLogUser list) app =
if app.IsAdministrator || (app.IsWebLogAdmin && not (user.AccessLevel = Administrator)) then if app.IsAdministrator || (app.IsWebLogAdmin && not (user.AccessLevel = Administrator)) then
let userUrl = relUrl app $"admin/settings/user/{user.Id}" let userUrl = relUrl app $"admin/settings/user/{user.Id}"
small [] [ small [] [
a [ _href $"{userUrl}/edit"; _hxTarget $"#user_{user.Id}" a [ _href $"{userUrl}/edit"; _hxBoost; _hxTarget $"#user_{user.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#user_{user.Id}:top" ] [ _hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#user_{user.Id}" ] [
raw "Edit" raw "Edit"
] ]
if app.UserId.Value <> user.Id then if app.UserId.Value <> user.Id then
span [ _class "text-muted" ] [ raw " &bull; " ] span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href userUrl; _hxDelete userUrl; _class "text-danger" a [ _href userUrl; _hxDelete userUrl; _hxPushUrl "false"; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the user “{user.PreferredName}”? This action cannot be undone. (This action will not succeed if the user has authored any posts or pages.)" ] [ _hxConfirm $"Are you sure you want to delete the user “{user.PreferredName}”? This action cannot be undone. (This action will not succeed if the user has authored any posts or pages.)" ] [
raw "Delete" raw "Delete"
] ]
@@ -168,7 +168,7 @@ let userList (model: WebLogUser list) app =
] ]
] ]
div [ _id "user_panel" ] [ div [ _id "user_panel" ] [
a [ _href (relUrl app "admin/settings/user/new/edit"); _class "btn btn-primary btn-sm mb-3" a [ _href (relUrl app "admin/settings/user/new/edit"); _hxBoost; _class "btn btn-primary btn-sm mb-3"
_hxTarget "#user_new" ] [ _hxTarget "#user_new" ] [
raw "Add a New User" raw "Add a New User"
] ]
@@ -186,11 +186,9 @@ let userList (model: WebLogUser list) app =
div [ _class "container g-0" ] [ div [ _class "container g-0" ] [
div [ _class "row mwl-table-detail"; _id "user_new" ] [] div [ _class "row mwl-table-detail"; _id "user_new" ] []
] ]
form [ _method "post"; _class "container g-0"; _hxTarget "#user_panel" List.map userDetail model
_hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ |> div [ _class "container g-0"; hxInherited (_hxTarget "#user_panel")
antiCsrf app hxInherited (_hxSwap $"{HxSwap.OuterHtml} show:top showTarget:body") ]
yield! List.map userDetail model
]
] ]
] ]
|> List.singleton |> List.singleton
@@ -200,7 +198,7 @@ let userList (model: WebLogUser list) app =
let myInfo (model: EditMyInfoModel) (user: WebLogUser) app = [ let myInfo (model: EditMyInfoModel) (user: WebLogUser) app = [
h2 [ _class "my-3" ] [ txt app.PageTitle ] h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [ article [] [
form [ _action (relUrl app "admin/my-info"); _method "post" ] [ form [ _action (relUrl app "admin/my-info"); _method "post"; _hxBoost ] [
antiCsrf app antiCsrf app
div [ _class "d-flex flex-row flex-wrap justify-content-around" ] [ div [ _class "d-flex flex-row flex-wrap justify-content-around" ] [
div [ _class "text-center mb-3 lh-sm" ] [ div [ _class "text-center mb-3 lh-sm" ] [
+69 -60
View File
@@ -33,7 +33,7 @@ let categoryEdit (model: EditCategoryModel) app =
|> String.concat "" |> String.concat ""
{ Name = c.Id; Value = $"{parents}{c.Name}" }) { Name = c.Id; Value = $"{parents}{c.Name}" })
|> Seq.append [ { Name = ""; Value = "&ndash; None &ndash;" } ] |> Seq.append [ { Name = ""; Value = "&ndash; None &ndash;" } ]
selectField [] (nameof model.ParentId) "Parent Category" model.ParentId cats (_.Name) (_.Value) [] selectField [] (nameof model.ParentId) "Parent Category" model.ParentId cats _.Name _.Value []
] ]
div [ _class "col-12 col-xl-10 offset-xl-1 mb-3" ] [ div [ _class "col-12 col-xl-10 offset-xl-1 mb-3" ] [
textField [] (nameof model.Description) "Description" model.Description [] textField [] (nameof model.Description) "Description" model.Description []
@@ -70,8 +70,8 @@ let categoryList includeNew app = [
a [ _href (relUrl app $"category/{cat.Slug}"); _target "_blank" ] [ a [ _href (relUrl app $"category/{cat.Slug}"); _target "_blank" ] [
raw $"View { cat.PostCount} Post"; if cat.PostCount <> 1 then raw "s" raw $"View { cat.PostCount} Post"; if cat.PostCount <> 1 then raw "s"
]; actionSpacer ]; actionSpacer
a [ _href $"{catUrl}/edit"; _hxTarget $"#cat_{cat.Id}" a [ _href $"{catUrl}/edit"; _hxBoost; _hxTarget $"#cat_{cat.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#cat_{cat.Id}:top" ] [ _hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#cat_{cat.Id}" ] [
raw "Edit" raw "Edit"
]; actionSpacer ]; actionSpacer
a [ _href catUrl; _hxDelete catUrl; _hxTarget "body"; _class "text-danger" a [ _href catUrl; _hxDelete catUrl; _hxTarget "body"; _class "text-danger"
@@ -85,11 +85,13 @@ let categoryList includeNew app = [
] ]
] ]
let loadNew = let loadNew =
span [ _hxGet (relUrl app "admin/category/new/edit"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] [] span [ _hxGet (relUrl app "admin/category/new/edit"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml
_hxTarget "this" ] []
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [] [
a [ _href (relUrl app "admin/category/new/edit"); _class "btn btn-primary btn-sm mb-3"; _hxTarget "#cat_new" ] [ a [ _href (relUrl app "admin/category/new/edit"); _hxBoost; _class "btn btn-primary btn-sm mb-3"
_hxTarget "#cat_new" ] [
raw "Add a New Category" raw "Add a New Category"
] ]
div [ _id "catList"; _class "container" ] [ div [ _id "catList"; _class "container" ] [
@@ -107,9 +109,6 @@ let categoryList includeNew app = [
div [ _class catCol ] [ raw "Category"; span [ _class "d-md-none" ] [ raw "; Description" ] ] div [ _class catCol ] [ raw "Category"; span [ _class "d-md-none" ] [ raw "; Description" ] ]
div [ _class $"{descCol} d-none d-md-inline-block" ] [ raw "Description" ] div [ _class $"{descCol} d-none d-md-inline-block" ] [ raw "Description" ]
] ]
]
form [ _method "post"; _class "container" ] [
antiCsrf app
div [ _class "row mwl-table-detail"; _id "cat_new" ] [ if includeNew then loadNew ] div [ _class "row mwl-table-detail"; _id "cat_new" ] [ if includeNew then loadNew ]
yield! app.Categories |> Seq.ofArray |> Seq.map categoryDetail |> List.ofSeq yield! app.Categories |> Seq.ofArray |> Seq.map categoryDetail |> List.ofSeq
] ]
@@ -121,7 +120,7 @@ let categoryList includeNew app = [
/// The main dashboard /// The main dashboard
let dashboard (model: DashboardModel) app = [ let dashboard (model: DashboardModel) app = [
h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " &bull; Dashboard" ] h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " &bull; Dashboard" ]
article [ _class "container" ] [ article [ _class "container"; hxInherited _hxBoost ] [
div [ _class "row" ] [ div [ _class "row" ] [
section [ _class "col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3" ] [ section [ _class "col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3" ] [
div [ _class "card" ] [ div [ _class "card" ] [
@@ -196,7 +195,7 @@ let dashboard (model: DashboardModel) app = [
let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: MetaItem list) app = [ let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: MetaItem list) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [] [
form [ _action (relUrl app "admin/settings/rss/save"); _method "post"; _class "container" ] [ form [ _action (relUrl app "admin/settings/rss/save"); _method "post"; _hxBoost; _class "container" ] [
antiCsrf app antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ] input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row pb-3" ] [ div [ _class "row pb-3" ] [
@@ -249,8 +248,8 @@ let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: Met
|> Seq.append [ { Name = ""; Value = "&ndash; Select Category &ndash;" } ] |> Seq.append [ { Name = ""; Value = "&ndash; Select Category &ndash;" } ]
selectField [ _id "SourceValueCat"; _required selectField [ _id "SourceValueCat"; _required
if model.SourceType = "tag" then _disabled ] if model.SourceType = "tag" then _disabled ]
(nameof model.SourceValue) "Category" model.SourceValue cats (_.Name) (nameof model.SourceValue) "Category" model.SourceValue cats _.Name _.Value
(_.Value) [] []
] ]
div [ _class "col-1 d-flex justify-content-end pb-3" ] [ div [ _class "col-1 d-flex justify-content-end pb-3" ] [
div [ _class "form-check form-check-inline me-0" ] [ div [ _class "form-check form-check-inline me-0" ] [
@@ -305,7 +304,7 @@ let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: Met
] ]
div [ _class "col-12 col-md-3 col-lg-2 pb-3" ] [ div [ _class "col-12 col-md-3 col-lg-2 pb-3" ] [
selectField [ _required ] (nameof model.Explicit) "Explicit Rating" model.Explicit selectField [ _required ] (nameof model.Explicit) "Explicit Rating" model.Explicit
ratings (_.Name) (_.Value) [] ratings _.Name _.Value []
] ]
] ]
div [ _class "row" ] [ div [ _class "row" ] [
@@ -380,7 +379,7 @@ let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: Met
] ]
] ]
div [ _class "col-4 col-lg-3 offset-lg-2 pb-3" ] [ div [ _class "col-4 col-lg-3 offset-lg-2 pb-3" ] [
selectField [] (nameof model.Medium) "Medium" model.Medium mediums (_.Name) (_.Value) [ selectField [] (nameof model.Medium) "Medium" model.Medium mediums _.Name _.Value [
span [ _class "form-text fst-italic" ] [ span [ _class "form-text fst-italic" ] [
raw "Optional; medium of the podcast content (" raw "Optional; medium of the podcast content ("
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#medium" a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#medium"
@@ -404,7 +403,7 @@ let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: Met
let redirectEdit (model: EditRedirectRuleModel) app = [ let redirectEdit (model: EditRedirectRuleModel) app = [
let url = relUrl app $"admin/settings/redirect-rules/{model.RuleId}" let url = relUrl app $"admin/settings/redirect-rules/{model.RuleId}"
h3 [] [ raw (if model.RuleId < 0 then "Add" else "Edit"); raw " Redirect Rule" ] h3 [] [ raw (if model.RuleId < 0 then "Add" else "Edit"); raw " Redirect Rule" ]
form [ _action url; _hxPost url; _hxTarget "body"; _method "post"; _class "container" ] [ form [ _action url; _method "post"; _hxBoost; _class "container" ] [
antiCsrf app antiCsrf app
input [ _type "hidden"; _name "RuleId"; _value (string model.RuleId) ] input [ _type "hidden"; _name "RuleId"; _value (string model.RuleId) ]
div [ _class "row" ] [ div [ _class "row" ] [
@@ -438,7 +437,8 @@ let redirectEdit (model: EditRedirectRuleModel) app = [
div [ _class "row mb-3" ] [ div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [ div [ _class "col text-center" ] [
saveButton; raw " &nbsp; " saveButton; raw " &nbsp; "
a [ _href (relUrl app "admin/settings/redirect-rules"); _class "btn btn-sm btn-secondary ms-3" ] [ a [ _href (relUrl app "admin/settings/redirect-rules"); _hxBoost
_class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel" raw "Cancel"
] ]
] ]
@@ -453,11 +453,12 @@ let redirectList (model: RedirectRule list) app = [
let ruleDetail idx (rule: RedirectRule) = let ruleDetail idx (rule: RedirectRule) =
let ruleId = $"rule_{idx}" let ruleId = $"rule_{idx}"
div [ _class "row mwl-table-detail"; _id ruleId ] [ div [ _class "row mwl-table-detail"; _id ruleId ] [
div [ _class "col-5 no-wrap" ] [ div [ _class "col-10" ] [
txt rule.From; br [] txt rule.From; br []; raw "&#xbb; "; txt rule.To; br []
small [] [ small [] [
let ruleUrl = relUrl app $"admin/settings/redirect-rules/{idx}" let ruleUrl = relUrl app $"admin/settings/redirect-rules/{idx}"
a [ _href ruleUrl; _hxTarget $"#{ruleId}"; _hxSwap $"{HxSwap.InnerHtml} show:#{ruleId}:top" ] [ a [ _href ruleUrl; _hxBoost; _hxTarget $"#{ruleId}"
_hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#{ruleId}" ] [
raw "Edit" raw "Edit"
] ]
if idx > 0 then if idx > 0 then
@@ -465,24 +466,23 @@ let redirectList (model: RedirectRule list) app = [
if idx <> model.Length - 1 then if idx <> model.Length - 1 then
actionSpacer; a [ _href $"{ruleUrl}/down"; _hxPost $"{ruleUrl}/down" ] [ raw "Move Down" ] actionSpacer; a [ _href $"{ruleUrl}/down"; _hxPost $"{ruleUrl}/down" ] [ raw "Move Down" ]
actionSpacer actionSpacer
a [ _class "text-danger"; _href ruleUrl; _hxDelete ruleUrl a [ _class "text-danger"; _href ruleUrl; _hxDelete ruleUrl; _hxPushUrl "false"
_hxConfirm "Are you sure you want to delete this redirect rule?" ] [ _hxConfirm "Are you sure you want to delete this redirect rule?" ] [
raw "Delete" raw "Delete"
] ]
] ]
] ]
div [ _class "col-5" ] [ txt rule.To ]
div [ _class "col-2 text-center" ] [ yesOrNo rule.IsRegex ] div [ _class "col-2 text-center" ] [ yesOrNo rule.IsRegex ]
] ]
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [] [
p [ _class "mb-3" ] [ p [ _class "mb-3" ] [
a [ _href (relUrl app "admin/settings") ] [ raw "&laquo; Back to Settings" ] a [ _href (relUrl app "admin/settings"); _hxBoost ] [ raw "&laquo; Back to Settings" ]
] ]
div [ _class "container" ] [ div [ _class "container" ] [
p [] [ p [] [
a [ _href (relUrl app "admin/settings/redirect-rules/-1"); _class "btn btn-primary btn-sm mb-3" a [ _href (relUrl app "admin/settings/redirect-rules/-1"); _hxBoost; _hxTarget "#rule_new"
_hxTarget "#rule_new" ] [ _class "btn btn-primary btn-sm mb-3" ] [
raw "Add Redirect Rule" raw "Add Redirect Rule"
] ]
] ]
@@ -495,14 +495,14 @@ let redirectList (model: RedirectRule list) app = [
else else
div [ _class "container g-0" ] [ div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [ div [ _class "row mwl-table-heading" ] [
div [ _class "col-5" ] [ raw "From" ] div [ _class "col-10" ] [ raw "From &#xbb; To" ]
div [ _class "col-5" ] [ raw "To" ]
div [ _class "col-2 text-center" ] [ raw "RegEx?" ] div [ _class "col-2 text-center" ] [ raw "RegEx?" ]
] ]
] ]
div [ _class "row mwl-table-detail"; _id "rule_new" ] [] div [ _class "row mwl-table-detail"; _id "rule_new" ] []
form [ _method "post"; _class "container g-0"; _hxTarget "body" ] [ form [ _method "post"; _hxBoost; _class "container g-0" ] [
antiCsrf app; yield! List.mapi ruleDetail model antiCsrf app
yield! List.mapi ruleDetail model
] ]
] ]
p [ _class "mt-3 text-muted fst-italic text-center" ] [ p [ _class "mt-3 text-muted fst-italic text-center" ] [
@@ -520,8 +520,8 @@ let redirectList (model: RedirectRule list) app = [
/// Edit a tag mapping /// Edit a tag mapping
let tagMapEdit (model: EditTagMapModel) app = [ let tagMapEdit (model: EditTagMapModel) app = [
h5 [ _class "my-3" ] [ txt app.PageTitle ] h5 [ _class "my-3" ] [ txt app.PageTitle ]
form [ _hxPost (relUrl app "admin/settings/tag-mapping/save"); _method "post"; _class "container" form [ _hxPost (relUrl app "admin/settings/tag-mapping/save"); _method "post"; _hxBoost; _class "container"
_hxTarget "#tagList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ _hxTarget "#tagList"; _hxSwap $"{HxSwap.OuterHtml} show:top showTarget:top" ] [
antiCsrf app antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ] input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row mb-3" ] [ div [ _class "row mb-3" ] [
@@ -535,7 +535,8 @@ let tagMapEdit (model: EditTagMapModel) app = [
div [ _class "row mb-3" ] [ div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [ div [ _class "col text-center" ] [
saveButton; raw " &nbsp; " saveButton; raw " &nbsp; "
a [ _href (relUrl app "admin/settings/tag-mappings"); _class "btn btn-sm btn-secondary ms-3" ] [ a [ _href (relUrl app "admin/settings/tag-mappings"); _hxBoost
_class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel" raw "Cancel"
] ]
] ]
@@ -552,11 +553,12 @@ let tagMapList (model: TagMap list) app =
div [ _class "col no-wrap" ] [ div [ _class "col no-wrap" ] [
txt map.Tag; br [] txt map.Tag; br []
small [] [ small [] [
a [ _href $"{url}/edit"; _hxTarget $"#tag_{map.Id}" a [ _href $"{url}/edit"; _hxBoost; _hxTarget $"#tag_{map.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#tag_{map.Id}:top" ] [ _hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#tag_{map.Id}" ] [
raw "Edit" raw "Edit"
]; actionSpacer ]; actionSpacer
a [ _href url; _hxDelete url; _class "text-danger" a [ _href url; _hxDelete url; _hxTarget "#tagList"; _hxPushUrl "false"; _hxSwap HxSwap.OuterHtml
_class "text-danger"
_hxConfirm $"Are you sure you want to delete the mapping for “{map.Tag}”? This action cannot be undone." ] [ _hxConfirm $"Are you sure you want to delete the mapping for “{map.Tag}”? This action cannot be undone." ] [
raw "Delete" raw "Delete"
] ]
@@ -576,11 +578,8 @@ let tagMapList (model: TagMap list) app =
div [ _class "col" ] [ raw "URL Value" ] div [ _class "col" ] [ raw "URL Value" ]
] ]
] ]
form [ _method "post"; _class "container g-0"; _hxTarget "#tagList"; _hxSwap HxSwap.OuterHtml ] [ div [ _class "row mwl-table-detail"; _id "tag_new" ] []
antiCsrf app yield! List.map tagMapDetail model
div [ _class "row mwl-table-detail"; _id "tag_new" ] []
yield! List.map tagMapDetail model
]
] ]
|> List.singleton |> List.singleton
@@ -600,18 +599,18 @@ let uploadList (model: DisplayUpload seq) app = [
small [] [ small [] [
a [ _href $"{relativeBase}{pathAndName}"; _target "_blank" ] [ raw "View File" ] a [ _href $"{relativeBase}{pathAndName}"; _target "_blank" ] [ raw "View File" ]
actionSpacer; span [ _class "text-muted" ] [ raw "Copy " ] actionSpacer; span [ _class "text-muted" ] [ raw "Copy " ]
a [ _href $"{absoluteBase}{pathAndName}"; _hxNoBoost a [ _href $"{absoluteBase}{pathAndName}"
_onclick $"return Admin.copyText('{absoluteBase}{pathAndName}', this)" ] [ _onclick $"return Admin.copyText('{absoluteBase}{pathAndName}', this)" ] [
raw "Absolute" raw "Absolute"
] ]
span [ _class "text-muted" ] [ raw " | " ] span [ _class "text-muted" ] [ raw " | " ]
a [ _href $"{relativeBase}{pathAndName}"; _hxNoBoost a [ _href $"{relativeBase}{pathAndName}"
_onclick $"return Admin.copyText('{relativeBase}{pathAndName}', this)" ] [ _onclick $"return Admin.copyText('{relativeBase}{pathAndName}', this)" ] [
raw "Relative" raw "Relative"
] ]
if app.WebLog.ExtraPath <> "" then if app.WebLog.ExtraPath <> "" then
span [ _class "text-muted" ] [ raw " | " ] span [ _class "text-muted" ] [ raw " | " ]
a [ _href $"{webLogBase}{pathAndName}"; _hxNoBoost a [ _href $"{webLogBase}{pathAndName}"
_onclick $"return Admin.copyText('/{webLogBase}{pathAndName}', this)" ] [ _onclick $"return Admin.copyText('/{webLogBase}{pathAndName}', this)" ] [
raw "For Post" raw "For Post"
] ]
@@ -639,9 +638,10 @@ let uploadList (model: DisplayUpload seq) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [] [
a [ _href (relUrl app "admin/upload/new"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Upload a New File" ] a [ _href (relUrl app "admin/upload/new"); _hxBoost; _class "btn btn-primary btn-sm mb-3" ] [
form [ _method "post"; _class "container"; _hxTarget "body" ] [ raw "Upload a New File"
antiCsrf app ]
div [ _class "container"; _hxTarget "body" ] [
div [ _class "row" ] [ div [ _class "row" ] [
div [ _class "col text-center" ] [ div [ _class "col text-center" ] [
em [ _class "text-muted" ] [ raw "Uploaded files served from" ]; br []; raw relativeBase em [ _class "text-muted" ] [ raw "Uploaded files served from" ]; br []; raw relativeBase
@@ -670,7 +670,7 @@ let uploadNew app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ] h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [ article [] [
form [ _action (relUrl app "admin/upload/save"); _method "post"; _class "container" form [ _action (relUrl app "admin/upload/save"); _method "post"; _class "container"
_enctype "multipart/form-data"; _hxNoBoost ] [ _enctype "multipart/form-data" ] [
antiCsrf app antiCsrf app
div [ _class "row" ] [ div [ _class "row" ] [
div [ _class "col-12 col-md-6 pb-3" ] [ div [ _class "col-12 col-md-6 pb-3" ] [
@@ -706,8 +706,8 @@ let uploadNew app = [
/// Web log settings page /// Web log settings page
let webLogSettings let webLogSettings
(model: SettingsModel) (themes: Theme list) (pages: Page list) (uploads: UploadDestination list) (model: SettingsModel) (themes: Theme list) (pages: Page list) (htmxOpts: (string * string) list)
(rss: EditRssModel) (app: AppViewContext) = [ (uploads: UploadDestination list) (rss: EditRssModel) (app: AppViewContext) = [
let feedDetail (feed: CustomFeed) = let feedDetail (feed: CustomFeed) =
let source = let source =
match feed.Source with match feed.Source with
@@ -728,8 +728,8 @@ let webLogSettings
let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}" let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}"
a [ _href (relUrl app (string feed.Path)); _target "_blank" ] [ raw "View Feed" ] a [ _href (relUrl app (string feed.Path)); _target "_blank" ] [ raw "View Feed" ]
actionSpacer actionSpacer
a [ _href $"{feedUrl}/edit" ] [ raw "Edit" ]; actionSpacer a [ _href $"{feedUrl}/edit"; _hxBoost ] [ raw "Edit" ]; actionSpacer
a [ _href feedUrl; _hxDelete feedUrl; _class "text-danger" a [ _href feedUrl; _hxDelete feedUrl; _hxPushUrl "false"; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the custom RSS feed based on {feed.Source}? This action cannot be undone." ] [ _hxConfirm $"Are you sure you want to delete the custom RSS feed based on {feed.Source}? This action cannot be undone." ] [
raw "Delete" raw "Delete"
] ]
@@ -747,11 +747,11 @@ let webLogSettings
raw "Go to: "; a [ _href "#users" ] [ raw "Users" ]; raw " &bull; " raw "Go to: "; a [ _href "#users" ] [ raw "Users" ]; raw " &bull; "
a [ _href "#rss-settings" ] [ raw "RSS Settings" ]; raw " &bull; " a [ _href "#rss-settings" ] [ raw "RSS Settings" ]; raw " &bull; "
a [ _href "#tag-mappings" ] [ raw "Tag Mappings" ]; raw " &bull; " a [ _href "#tag-mappings" ] [ raw "Tag Mappings" ]; raw " &bull; "
a [ _href (relUrl app "admin/settings/redirect-rules") ] [ raw "Redirect Rules" ] a [ _href (relUrl app "admin/settings/redirect-rules"); _hxBoost ] [ raw "Redirect Rules" ]
] ]
fieldset [ _class "container mb-3" ] [ fieldset [ _class "container mb-3" ] [
legend [] [ raw "Web Log Settings" ] legend [] [ raw "Web Log Settings" ]
form [ _action (relUrl app "admin/settings"); _method "post" ] [ form [ _action (relUrl app "admin/settings"); _method "post"; _hxBoost ] [
antiCsrf app antiCsrf app
div [ _class "container g-0" ] [ div [ _class "container g-0" ] [
div [ _class "row" ] [ div [ _class "row" ] [
@@ -779,7 +779,7 @@ let webLogSettings
] ]
div [ _class "col-12 col-md-6 offset-md-1 col-xl-4 offset-xl-0 pb-3" ] [ div [ _class "col-12 col-md-6 offset-md-1 col-xl-4 offset-xl-0 pb-3" ] [
selectField [ _required ] (nameof model.DefaultPage) "Default Page" model.DefaultPage pages selectField [ _required ] (nameof model.DefaultPage) "Default Page" model.DefaultPage pages
(fun p -> string p.Id) (_.Title) [] (fun p -> string p.Id) _.Title []
] ]
div [ _class "col-12 col-md-4 col-xl-2 pb-3" ] [ div [ _class "col-12 col-md-4 col-xl-2 pb-3" ] [
numberField [ _required; _min "0"; _max "50" ] (nameof model.PostsPerPage) "Posts per Page" numberField [ _required; _min "0"; _max "50" ] (nameof model.PostsPerPage) "Posts per Page"
@@ -791,7 +791,8 @@ let webLogSettings
textField [ _required ] (nameof model.TimeZone) "Time Zone" model.TimeZone [] textField [ _required ] (nameof model.TimeZone) "Time Zone" model.TimeZone []
] ]
div [ _class "col-12 col-md-4 col-xl-2" ] [ div [ _class "col-12 col-md-4 col-xl-2" ] [
checkboxSwitch [] (nameof model.AutoHtmx) "Auto-Load htmx" model.AutoHtmx [] selectField [ _required ] (nameof model.AutoHtmx) "Auto-Load htmx" model.AutoHtmx htmxOpts
fst snd []
span [ _class "form-text fst-italic" ] [ span [ _class "form-text fst-italic" ] [
a [ _href "https://htmx.org"; _target "_blank"; _relNoOpener ] [ raw "What is this?" ] a [ _href "https://htmx.org"; _target "_blank"; _relNoOpener ] [ raw "What is this?" ]
] ]
@@ -800,6 +801,13 @@ let webLogSettings
selectField [] (nameof model.Uploads) "Default Upload Destination" model.Uploads uploads selectField [] (nameof model.Uploads) "Default Upload Destination" model.Uploads uploads
string string [] string string []
] ]
div [ _class "col-12 col-md-6 offset-md-3 col-xl-4 offset-xl-4" ] [
checkboxSwitch [] (nameof model.AutoOpenGraph) "Auto-Add OpenGraph Properties"
model.AutoOpenGraph []
span [ _class "form-text fst-italic" ] [
raw "Adds title, site name, and permalink to all pages and posts"
]
]
] ]
div [ _class "row pb-3" ] [ div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [ div [ _class "col text-center" ] [
@@ -811,11 +819,12 @@ let webLogSettings
] ]
fieldset [ _id "users"; _class "container mb-3 pb-0" ] [ fieldset [ _id "users"; _class "container mb-3 pb-0" ] [
legend [] [ raw "Users" ] legend [] [ raw "Users" ]
span [ _hxGet (relUrl app "admin/settings/users"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] [] span [ _hxGet (relUrl app "admin/settings/users"); _hxTarget "this"; _hxTrigger HxTrigger.Load
_hxSwap HxSwap.OuterHtml ] []
] ]
fieldset [ _id "rss-settings"; _class "container mb-3 pb-0" ] [ fieldset [ _id "rss-settings"; _class "container mb-3 pb-0" ] [
legend [] [ raw "RSS Settings" ] legend [] [ raw "RSS Settings" ]
form [ _action (relUrl app "admin/settings/rss"); _method "post"; _class "container g-0" ] [ form [ _action (relUrl app "admin/settings/rss"); _method "post"; _hxBoost; _class "container g-0" ] [
antiCsrf app antiCsrf app
div [ _class "row pb-3" ] [ div [ _class "row pb-3" ] [
div [ _class "col col-xl-8 offset-xl-2" ] [ div [ _class "col col-xl-8 offset-xl-2" ] [
@@ -869,7 +878,7 @@ let webLogSettings
if app.WebLog.Rss.CustomFeeds.Length = 0 then if app.WebLog.Rss.CustomFeeds.Length = 0 then
p [ _class "text-muted fst-italic text-center" ] [ raw "No custom feeds defined" ] p [ _class "text-muted fst-italic text-center" ] [ raw "No custom feeds defined" ]
else else
form [ _method "post"; _class "container g-0"; _hxTarget "body" ] [ form [ _method "post"; _class "container g-0"; _hxBoost ] [
antiCsrf app antiCsrf app
div [ _class "row mwl-table-heading" ] [ div [ _class "row mwl-table-heading" ] [
div [ _class "col-12 col-md-6" ] [ div [ _class "col-12 col-md-6" ] [
@@ -884,11 +893,11 @@ let webLogSettings
] ]
fieldset [ _id "tag-mappings"; _class "container mb-3 pb-0" ] [ fieldset [ _id "tag-mappings"; _class "container mb-3 pb-0" ] [
legend [] [ raw "Tag Mappings" ] legend [] [ raw "Tag Mappings" ]
a [ _href (relUrl app "admin/settings/tag-mapping/new/edit"); _class "btn btn-primary btn-sm mb-3" a [ _href (relUrl app "admin/settings/tag-mapping/new/edit"); _hxBoost; _hxTarget "#tag_new"
_hxTarget "#tag_new" ] [ _class "btn btn-primary btn-sm mb-3" ] [
raw "Add a New Tag Mapping" raw "Add a New Tag Mapping"
] ]
span [ _hxGet (relUrl app "admin/settings/tag-mappings"); _hxTrigger HxTrigger.Load span [ _hxGet (relUrl app "admin/settings/tag-mappings"); _hxTarget "this"; _hxTrigger HxTrigger.Load
_hxSwap HxSwap.OuterHtml ] [] _hxSwap HxSwap.OuterHtml ] []
] ]
] ]
+3 -3
View File
@@ -1,5 +1,5 @@
{ {
"Generator": "myWebLog 2.2", "Generator": "myWebLog 3",
"Logging": { "Logging": {
"LogLevel": { "LogLevel": {
"MyWebLog.Handlers": "Information" "MyWebLog.Handlers": "Information"
@@ -8,7 +8,7 @@
"Kestrel": { "Kestrel": {
"Endpoints": { "Endpoints": {
"Http": { "Http": {
"Url": "http://0.0.0.0:80" "Url": "http://0.0.0.0:5000"
} }
} }
} }
+1 -1
View File
@@ -1,2 +1,2 @@
myWebLog Admin myWebLog Admin
2.2 3
+89 -34
View File
@@ -2,6 +2,12 @@
* Support functions for the administrative UI * Support functions for the administrative UI
*/ */
this.Admin = { this.Admin = {
/**
* The next index for an OpenGraph extra property item
* @type {number}
*/
nextExtraIndex : 0,
/** /**
* The next index for a metadata item * The next index for a metadata item
* @type {number} * @type {number}
@@ -14,6 +20,14 @@ this.Admin = {
*/ */
nextPermalink : 0, nextPermalink : 0,
/**
* Set the next OpenGraph extra propery index
* @param {number} idx The index to set
*/
setNextExtraIndex(idx) {
this.nextExtraIndex = idx
},
/** /**
* Set the next meta item index * Set the next meta item index
* @param {number} idx The index to set * @param {number} idx The index to set
@@ -32,14 +46,16 @@ this.Admin = {
/** /**
* Create a metadata remove button * Create a metadata remove button
* @param {string} prefix The prefix of the row to be removed
* @returns {HTMLDivElement} The column with the remove button * @returns {HTMLDivElement} The column with the remove button
*/ */
createMetaRemoveColumn() { createMetaRemoveColumn(prefix) {
const removeBtn = document.createElement("button") const removeBtn = document.createElement("button")
removeBtn.type = "button" removeBtn.type = "button"
removeBtn.className = "btn btn-sm btn-danger" removeBtn.className = "btn btn-sm btn-danger"
removeBtn.innerHTML = "&minus;" removeBtn.innerHTML = "&minus;"
removeBtn.setAttribute("onclick", `Admin.removeMetaItem(${this.nextMetaIndex})`) removeBtn.setAttribute("onclick",
`Admin.removeMetaItem('${prefix}', ${prefix === "og_extra" ? this.nextExtraIndex : this.nextMetaIndex})`)
const removeCol = document.createElement("div") const removeCol = document.createElement("div")
removeCol.className = "col-1 text-center align-self-center" removeCol.className = "col-1 text-center align-self-center"
@@ -50,14 +66,16 @@ this.Admin = {
/** /**
* Create a metadata name field * Create a metadata name field
* @param {string} prefix The prefix for the element
* @returns {HTMLInputElement} The name input element * @returns {HTMLInputElement} The name input element
*/ */
createMetaNameField() { createMetaNameField(prefix) {
const namePfx = prefix === "og_extra" ? "OpenGraphExtra" : "Meta"
const nameField = document.createElement("input") const nameField = document.createElement("input")
nameField.type = "text" nameField.type = "text"
nameField.name = "MetaNames" nameField.name = `${namePfx}Names`
nameField.id = `metaNames_${this.nextMetaIndex}` nameField.id = `${namePfx}Names_${prefix === "og_extra" ? this.nextExtraIndex : this.nextMetaIndex}`
nameField.className = "form-control" nameField.className = "form-control"
nameField.placeholder = "Name" nameField.placeholder = "Name"
@@ -88,14 +106,16 @@ this.Admin = {
/** /**
* Create a metadata value field * Create a metadata value field
* @param {string} prefix The prefix for the field being created
* @returns {HTMLInputElement} The metadata value field * @returns {HTMLInputElement} The metadata value field
*/ */
createMetaValueField() { createMetaValueField(prefix) {
const namePfx = prefix === "og_extra" ? "OpenGraphExtra" : "Meta"
const valueField = document.createElement("input") const valueField = document.createElement("input")
valueField.type = "text" valueField.type = "text"
valueField.name = "MetaValues" valueField.name = `${namePfx}Values`
valueField.id = `metaValues_${this.nextMetaIndex}` valueField.id = `${namePfx}Values_${prefix === "og_extra" ? this.nextExtraIndex : this.nextMetaIndex}`
valueField.className = "form-control" valueField.className = "form-control"
valueField.placeholder = "Value" valueField.placeholder = "Value"
@@ -134,32 +154,39 @@ this.Admin = {
/** /**
* Construct and add a metadata item row * Construct and add a metadata item row
* @param {string} prefix The prefix of the row being added
* @param {HTMLDivElement} removeCol The column with the remove button * @param {HTMLDivElement} removeCol The column with the remove button
* @param {HTMLDivElement} nameCol The column with the name field * @param {HTMLDivElement} nameCol The column with the name field
* @param {HTMLDivElement} valueCol The column with the value field * @param {HTMLDivElement} valueCol The column with the value field
*/ */
createMetaRow(removeCol, nameCol, valueCol) { createMetaRow(prefix, removeCol, nameCol, valueCol) {
const newRow = document.createElement("div") const newRow = document.createElement("div")
newRow.className = "row mb-3" newRow.className = "row mb-3"
newRow.id = `meta_${this.nextMetaIndex}` newRow.id = `${prefix}_${prefix === "og_extra" ? this.nextExtraIndex : this.nextMetaIndex}`
newRow.appendChild(removeCol) newRow.appendChild(removeCol)
newRow.appendChild(nameCol) newRow.appendChild(nameCol)
newRow.appendChild(valueCol) newRow.appendChild(valueCol)
document.getElementById("meta_items").appendChild(newRow) document.getElementById(`${prefix}_items`).appendChild(newRow)
this.nextMetaIndex++ if (prefix === "og_extra") {
this.nextExtraIndex++
} else {
this.nextMetaIndex++
}
}, },
/** /**
* Add a new row for metadata entry * Add a new row for metadata entry
* @param {string} prefix The prefix for the field being created
*/ */
addMetaItem() { addMetaItem(prefix) {
const nameField = this.createMetaNameField() const nameField = this.createMetaNameField(prefix)
this.createMetaRow( this.createMetaRow(
this.createMetaRemoveColumn(), prefix,
this.createMetaRemoveColumn(prefix),
this.createMetaNameColumn(nameField), this.createMetaNameColumn(nameField),
this.createMetaValueColumn(this.createMetaValueField(), undefined)) this.createMetaValueColumn(this.createMetaValueField(prefix), undefined))
document.getElementById(nameField.id).focus() document.getElementById(nameField.id).focus()
}, },
@@ -227,6 +254,34 @@ this.Admin = {
if (link) link.style.display = src === "none" || src === "external" ? "none" : "" if (link) link.style.display = src === "none" || src === "external" ? "none" : ""
}, },
/**
* Enable or disable OpenGraph fields
*/
toggleOpenGraphFields() {
const disabled = !document.getElementById("AssignOpenGraph").checked
let fieldsets = ["og_item", "og_image", "og_audio", "og_video"]
fieldsets.forEach(it => document.getElementById(it).disabled = disabled)
},
/**
* Disable the file upload or path field if the other is entered
* @param {string} pathElt The path element to check
* @param {string} fileElt The file element to check
*/
pathOrFile(pathElt, fileElt) {
/** @type {HTMLInputElement} */
const path = document.getElementById(pathElt)
/** @type {HTMLInputElement} */
const file = document.getElementById(fileElt)
if (path.value.length > 0) {
file.disabled = true
} else if (file.value.length > 0) {
path.disabled = true
} else {
file.disabled = path.disabled = false
}
},
/** /**
* Enable or disable podcast fields * Enable or disable podcast fields
*/ */
@@ -284,10 +339,11 @@ this.Admin = {
/** /**
* Remove a metadata item * Remove a metadata item
* @param {number} idx The index of the metadata item to remove * @param {string} id The ID prefix of the item to remove
* @param {number} idx The index of the item to remove
*/ */
removeMetaItem(idx) { removeMetaItem(id, idx) {
document.getElementById(`meta_${idx}`).remove() document.getElementById(`${id}_${idx}`).remove()
}, },
/** /**
@@ -357,6 +413,7 @@ this.Admin = {
toast.setAttribute("role", "alert") toast.setAttribute("role", "alert")
toast.setAttribute("aria-live", "assertive") toast.setAttribute("aria-live", "assertive")
toast.setAttribute("aria-atomic", "true") toast.setAttribute("aria-atomic", "true")
toast.setAttribute("data-mwl-shown", "true")
toast.appendChild(toastHead) toast.appendChild(toastHead)
toast.appendChild(toastBody) toast.appendChild(toastBody)
@@ -374,34 +431,32 @@ this.Admin = {
* Initialize any toasts that were pre-rendered from the server * Initialize any toasts that were pre-rendered from the server
*/ */
showPreRenderedMessages() { showPreRenderedMessages() {
[...document.querySelectorAll(".toast")].forEach(el => { [...document.querySelectorAll(".toast")]
if (el.getAttribute("data-mwl-shown") !== "true") { .filter(el => !el.hasAttribute("data-mwl-shown"))
.forEach(el => {
const toast = new bootstrap.Toast(el, const toast = new bootstrap.Toast(el,
el.getAttribute("data-bs-autohide") === "false" el.getAttribute("data-bs-autohide") === "false" ? { autohide: false } : { delay: 6000, autohide: true })
? { autohide: false } : { delay: 6000, autohide: true })
toast.show() toast.show()
el.setAttribute("data-mwl-shown", "true") el.setAttribute("data-mwl-shown", "true")
} })
})
} }
} }
htmx.on("htmx:afterOnLoad", function (evt) { htmx.on("htmx:after:swap", function (evt) {
const hdrs = evt.detail.xhr.getAllResponseHeaders()
// Initialize any toasts that were pre-rendered from the server // Initialize any toasts that were pre-rendered from the server
Admin.showPreRenderedMessages() Admin.showPreRenderedMessages()
// Show messages if there were any in the response // Show messages if there were any in the response
if (hdrs.indexOf("x-message") >= 0) { const hdrs = evt.detail.ctx.response.headers
Admin.showMessage(evt.detail.xhr.getResponseHeader("x-message")) if (hdrs.has("x-message")) {
hdrs.get("x-message").split(", ").forEach(Admin.showMessage)
} }
}) })
htmx.on("htmx:responseError", function (evt) { htmx.on("htmx:response:error", function (evt) {
const xhr = evt.detail.xhr const resp = evt.detail.ctx.response
const hdrs = xhr.getAllResponseHeaders()
// Show an error message if there were none in the response // Show an error message if there were none in the response
if (hdrs.indexOf("x-message") < 0) { if (!resp.headers.has("x-message")) {
Admin.showMessage(`danger|||${xhr.status}: ${xhr.statusText}`) Admin.showMessage(`danger|||${resp.status}: ${resp.statusText}`)
} }
}) })
+3 -3
View File
@@ -1,6 +1,6 @@
{%- if is_category or is_tag %} {%- if is_category or is_tag %}
<h1 class=index-title>{{ page_title }}</h1> <h1 class=index-title>{{ page_title }}</h1>
{%- if subtitle %}<h4 class=text-muted>{{ subtitle }}</h4>{% endif -%} {%- if subtitle <> "" %}<h4 class=text-muted>{{ subtitle }}</h4>{% endif -%}
{% endif %} {% endif %}
{%- assign post_count = model.posts | size -%} {%- assign post_count = model.posts | size -%}
{%- if post_count > 0 %} {%- if post_count > 0 %}
@@ -13,8 +13,8 @@
</a> </a>
</h1> </h1>
<p> <p>
Published on {{ post.published_on | date: "MMMM d, yyyy" }} Published on {{ post.published_on | format_date: "MMMM d, yyyy" }}
at {{ post.published_on | date: "h:mmtt" | downcase }} at {{ post.published_on | format_date: "h:mmtt" | downcase }}
by {{ model.authors | value: post.author_id }} by {{ model.authors | value: post.author_id }}
{{ post.text }} {{ post.text }}
{%- assign category_count = post.category_ids | size -%} {%- assign category_count = post.category_ids | size -%}
+1 -1
View File
@@ -4,7 +4,7 @@
<meta name=viewport content="width=device-width"> <meta name=viewport content="width=device-width">
<link rel=stylesheet href=https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/css/bootstrap.min.css <link rel=stylesheet href=https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/css/bootstrap.min.css
integrity=sha384-1BmE4kWBq78iYhFldvKuhfTAU6auU8tT94WrHftjDbrCEXSU1oBoqyl2QvZ6jIW3 crossorigin=anonymous> integrity=sha384-1BmE4kWBq78iYhFldvKuhfTAU6auU8tT94WrHftjDbrCEXSU1oBoqyl2QvZ6jIW3 crossorigin=anonymous>
<title>{{ page_title | strip_html }}{% if page_title %} &laquo; {% endif %}{{ web_log.name | strip_html }}</title> <title>{{ page_title | strip_html }}{% if page_title <> "" %} &laquo; {% endif %}{{ web_log.name | strip_html }}</title>
{% page_head -%} {% page_head -%}
<header> <header>
<nav class="navbar navbar-light bg-light navbar-expand-md justify-content-start px-2"> <nav class="navbar navbar-light bg-light navbar-expand-md justify-content-start px-2">
+2 -2
View File
@@ -2,8 +2,8 @@
<h1>{{ post.title }}</h1> <h1>{{ post.title }}</h1>
<h4 class="item-meta text-muted"> <h4 class="item-meta text-muted">
{% if post.published_on -%} {% if post.published_on -%}
Published {{ post.published_on | date: "dddd, MMMM d, yyyy" }} Published {{ post.published_on | format_date: "dddd, MMMM d, yyyy" }}
at {{ post.published_on | date: "h:mm tt" | downcase }} at {{ post.published_on | format_date: "h:mm tt" | downcase }}
{%- else -%} {%- else -%}
**DRAFT** **DRAFT**
{% endif %} {% endif %}
+1 -1
View File
@@ -1,2 +1,2 @@
myWebLog Default Theme myWebLog Default Theme
2.2 3