23 Commits

Author SHA1 Message Date
f4be57b665 v2.2
Reviewed-on: #51
2024-06-20 00:08:40 +00:00
7f94e0beef Remove .NET 7 from build target (#48) 2024-06-19 20:07:45 -04:00
f59566a3d3 Create theme dir if needed (#49)
- Use Path.Combine throughout
- Update theme versions
- Update generator version
2024-06-19 17:02:05 -04:00
f2f766fc05 Update htmx to v2.0.0 (#50)
- Also update all other deps
2024-06-19 16:17:45 -04:00
75c4d4f991 Tweaks to v2.2 data migration (#45) 2024-06-19 16:04:53 -04:00
b50d0d9884 Drop .NET 7 support (#48)
- Bump version to 2.2
2024-06-18 22:06:02 -04:00
7ae15b9e93 Force URLs and e-mail to be lowercase (#45)
- Added v2.2 migration to lower existing e-mails
2024-06-18 22:01:41 -04:00
823286255b Fix PostgreSQL v2.1 migration (#44)
fixes #43
2024-03-28 22:25:09 -04:00
f1a7e55f3e Version 2.1 (#41)
- Add full chapter support (#6)
- Add built-in redirect functionality (#39)
- Support building Docker containers for release (#38)
- Support canonical domain configuration (#37)
- Add unit tests for domain/models and integration tests for all three data stores
- Convert SQLite storage to use JSON documents, similar to PostgreSQL
- Convert admin templates to Giraffe View Engine (from Liquid)
- Add .NET 8 support
2024-03-26 20:13:28 -04:00
7b325dc19e v2 (#36)
* Use PostgreSQL JSON-based data implementation
* Fix back link on RSS settings page (#34)
* Show theme upload messages (#28)
* Fix admin page list paging (#35)
* Add db migrations for all stores
* Support both .NET 6 and 7
2023-02-26 13:01:21 -05:00
5f3daa1de9 v2 RC2 (#33)
* Add PostgreSQL back end (#30)
* Upgrade password storage (#32)
* Change podcast/episode storage for SQLite (#29)
* Move date/time handling to NodaTime (#31)
2022-08-21 18:56:18 -04:00
1ec664ad24 Fix casing on CLI usage examples 2022-08-01 07:46:53 -04:00
33698bd182 Reassign child cats when deleting parent cat (#27)
- Create common page/post edit field template (#25)
- Fix relative URL adjustment throughout
- Fix upload name sanitization regex
- Create modules within Admin handler module
- Enable/disable podcast episode fields on page load
- Fix upload destination casing in templates
- Tweak default theme to show no posts found on index template
- Update Bootstrap to 5.1.3 in default theme
2022-07-28 20:36:02 -04:00
6b49793fbb Change alerts to toasts (#25)
- Upgrade to Bootstrap 5.1.3
- Move RSS settings and tag mappings to web log settings (#25)
- Fix parameters in 2 SQLite queries
2022-07-27 21:38:46 -04:00
a8386d6c97 Add loading indicator for admin theme (#25) 2022-07-26 22:34:19 -04:00
b1ca48c2c5 Add docs link to admin header (#25)
- Change executable name in release packages
2022-07-26 20:37:18 -04:00
3189681021 Tweak admin UI templates (#25)
- Move user management under web log settings
- Move user self-update to my-info
- Return meaningful error if a template does not exist
- Tweak margins/paddings throughout
- Do not show headings on list pages if lists are empty
- Fix pagination styles for page/post list pages
2022-07-26 16:28:14 -04:00
ff9c08842b First cut at cache management (#23) 2022-07-24 23:55:00 -04:00
e103738d39 Prevent deletion if theme is in use (#20) 2022-07-24 19:26:36 -04:00
d854178255 Upload / delete themes (#20)
- Moved themes to section of installation admin page (will also implement #23 there)
2022-07-24 19:18:20 -04:00
0a32181e65 WIP on theme upload (#20) 2022-07-24 16:32:37 -04:00
81fe03b8f3 WIP on theme admin page (#20) 2022-07-22 21:19:19 -04:00
4514c4864d Load themes at startup (#20)
- Adjust release packaging (#20)
- Fix default theme for beta-5 changes (#24)
- Remove RethinkDB case fix (cleanup from #21)
- Bump versions for next release
2022-07-22 10:33:11 -04:00
121 changed files with 17268 additions and 8456 deletions

View File

@@ -1,12 +0,0 @@
{
"version": 1,
"isRoot": true,
"tools": {
"fake-cli": {
"version": "5.22.0",
"commands": [
"fake"
]
}
}
}

99
.github/workflows/ci.yml vendored Normal file
View File

@@ -0,0 +1,99 @@
name: Continuous Integration
on:
push:
branches:
- main
pull_request:
branches:
- main
workflow_dispatch:
env:
MWL_TEST_RETHINK_URI: rethinkdb://localhost/mwl_test
jobs:
build_and_test:
name: Build / Test
runs-on: ubuntu-latest
strategy:
matrix:
dotnet-version:
- "6.0"
- "7.0"
- "8.0"
services:
postgres:
image: postgres:latest
env:
POSTGRES_PASSWORD: postgres
options: >-
--health-cmd pg_isready
--health-interval 10s
--health-timeout 5s
--health-retries 5
ports:
- 5432:5432
rethink:
image: rethinkdb:latest
ports:
- 28015:28015
steps:
- name: Check Out Code
uses: actions/checkout@v4
- name: Setup .NET Core SDK
uses: actions/setup-dotnet@v4.0.0
with:
dotnet-version: 8.x
- name: Restore dependencies
run: dotnet restore src/MyWebLog.sln
- name: Build (${{ matrix.dotnet-version }})
run: dotnet build src/MyWebLog.sln -f net${{ matrix.dotnet-version }}
- name: Test (${{ matrix.dotnet-version }})
run: cd src/MyWebLog.Tests; dotnet run -f net${{ matrix.dotnet-version }}
publish:
name: Publish Packages
runs-on: ubuntu-latest
needs: build_and_test
strategy:
matrix:
ver:
- "net6.0"
- "net7.0"
- "net8.0"
os:
- "linux-x64"
- "win-x64"
include:
- os: "linux-x64"
bz2: true
- os: "win-x64"
zip: true
steps:
- name: Check Out Code
uses: actions/checkout@v4
- name: Setup .NET Core SDK
uses: actions/setup-dotnet@v4.0.0
with:
dotnet-version: 8.x
- name: Publish (Release)
run: dotnet publish -c Release -f ${{ matrix.ver }} -r ${{ matrix.os }} src/MyWebLog/MyWebLog.fsproj
- name: Zip Admin Theme
run: cd src/admin-theme; zip -r ../MyWebLog/bin/Release/${{ matrix.ver }}/${{ matrix.os }}/publish/admin-theme.zip *; cd ../..
- name: Zip Default Theme
run: cd src/default-theme; zip -r ../MyWebLog/bin/Release/${{ matrix.ver }}/${{ matrix.os }}/publish/default-theme.zip *; cd ../..
- if: ${{ matrix.bz2 }}
name: Create .tar.bz2 Archive
run: tar cfj myWebLog-${{ matrix.ver }}-${{ matrix.os }}.tar.bz2 -C src/MyWebLog/bin/Release/${{ matrix.ver }}/${{ matrix.os }}/publish .
- if: ${{ matrix.zip }}
name: Create .zip Archive
run: cd src/MyWebLog/bin/Release/${{ matrix.ver }}/${{ matrix.os }}/publish; zip -r myWebLog-${{ matrix.ver }}-${{ matrix.os }}.zip *; cp myWeb*.zip ../../../../../../..; cd ../../../../../../..
- name: Upload Artifacts
uses: actions/upload-artifact@v4
with:
name: package-${{ matrix.ver }}-${{ matrix.os }}
path: |
*x64.zip
*.bz2

3
.gitignore vendored
View File

@@ -261,7 +261,8 @@ src/MyWebLog/wwwroot/img/daniel-j-summers
src/MyWebLog/wwwroot/img/bit-badger
.ionide
.vscode
src/MyWebLog/appsettings.Production.json
# SQLite database files
src/MyWebLog/*.db*
src/MyWebLog/data/*.db*

166
build.fs Normal file
View File

@@ -0,0 +1,166 @@
open System.IO
open Fake.Core
open Fake.DotNet
open Fake.IO
open Fake.IO.Globbing.Operators
let execContext = Context.FakeExecutionContext.Create false "build.fsx" []
Context.setExecutionContext (Context.RuntimeContext.Fake execContext)
/// The output directory for release ZIPs
let releasePath = "releases"
/// The path to the main project
let projectPath = "src/MyWebLog"
/// The path and name of the main project
let projName = $"{projectPath}/MyWebLog.fsproj"
/// The version being packaged (extracted from appsettings.json)
let version =
let settings = File.ReadAllText $"{projectPath}/appsettings.json"
let generator = settings.Substring (settings.IndexOf "\"Generator\":")
let appVersion = generator.Replace("\"Generator\": \"", "")
let appVersion = appVersion.Substring (0, appVersion.IndexOf "\"")
appVersion.Split ' ' |> Array.last
/// Zip a theme distributed with myWebLog
let zipTheme (name : string) (_ : TargetParameter) =
let path = $"src/{name}-theme"
!! $"{path}/**/*"
|> Zip.filesAsSpecs path
|> Seq.filter (fun (_, name) -> not (name.EndsWith ".zip"))
|> Zip.zipSpec $"{releasePath}/{name}-theme.zip"
/// Frameworks supported by this build
let frameworks = [ "net6.0"; "net8.0" ]
/// Publish the project for the given runtime ID
let publishFor rid (_ : TargetParameter) =
frameworks
|> List.iter (fun fwk ->
DotNet.publish
(fun opts ->
{ opts with Runtime = Some rid; SelfContained = Some false; NoLogo = true; Framework = Some fwk })
projName)
/// Package published output for the given runtime ID
let packageFor rid (_ : TargetParameter) =
frameworks
|> List.iter (fun fwk ->
let path = $"{projectPath}/bin/Release/{fwk}/%s{rid}/publish"
let prodSettings = $"{path}/appsettings.Production.json"
if File.exists prodSettings then File.delete prodSettings
[ !! $"{path}/**/*"
|> Zip.filesAsSpecs path
|> Seq.map (fun (orig, dest) ->
orig, if dest.StartsWith "MyWebLog" then dest.Replace ("MyWebLog", "myWebLog") else dest)
Seq.singleton ($"{releasePath}/admin-theme.zip", "admin-theme.zip")
Seq.singleton ($"{releasePath}/default-theme.zip", "default-theme.zip")
]
|> Seq.concat
|> Zip.zipSpec $"{releasePath}/myWebLog-{version}.{fwk}.{rid}.zip")
Target.create "Clean" (fun _ ->
!! "src/**/bin"
++ "src/**/obj"
|> Shell.cleanDirs
Shell.cleanDir releasePath
)
Target.create "Build" (fun _ ->
DotNet.build (fun opts -> { opts with NoLogo = true }) projName
)
Target.create "ZipAdminTheme" (zipTheme "admin")
Target.create "ZipDefaultTheme" (zipTheme "default")
Target.create "PublishWindows" (publishFor "win-x64")
Target.create "PackageWindows" (packageFor "win-x64")
Target.create "PublishLinux" (publishFor "linux-x64")
Target.create "PackageLinux" (packageFor "linux-x64")
Target.create "RepackageLinux" (fun _ ->
let workDir = $"{releasePath}/linux"
frameworks
|> List.iter (fun fwk ->
let zipArchive = $"{releasePath}/myWebLog-{version}.{fwk}.linux-x64.zip"
let sh command args =
CreateProcess.fromRawCommand command args
|> CreateProcess.redirectOutput
|> Proc.run
|> ignore
Shell.mkdir workDir
Zip.unzip workDir zipArchive
Shell.cd workDir
sh "chmod" [ "+x"; "./myWebLog" ]
sh "tar" [ "cfj"; $"../myWebLog-{version}.{fwk}.linux-x64.tar.bz2"; "." ]
Shell.cd "../.."
Shell.rm zipArchive)
Shell.rm_rf workDir
)
Target.create "All" ignore
Target.create "RemoveThemeArchives" (fun _ ->
Shell.rm $"{releasePath}/admin-theme.zip"
Shell.rm $"{releasePath}/default-theme.zip"
)
Target.create "CI" ignore
open Fake.Core.TargetOperators
let dependencies = [
"Clean"
==> "All"
"Clean"
?=> "Build"
==> "All"
"Clean"
?=> "ZipDefaultTheme"
==> "All"
"Clean"
?=> "ZipAdminTheme"
==> "All"
"Build"
==> "PublishWindows"
==> "All"
"Build"
==> "PublishLinux"
==> "All"
"PublishWindows"
==> "PackageWindows"
==> "All"
"PublishLinux"
==> "PackageLinux"
==> "All"
"PackageLinux"
==> "RepackageLinux"
==> "All"
"All"
==> "RemoveThemeArchives"
==> "CI"
]
[<EntryPoint>]
let main args =
try
match args with
| [| target |] -> Target.runOrDefault target
| _ -> Target.runOrDefault "All"
0
with e ->
printfn "%A" e
1

20
build.fsproj Normal file
View File

@@ -0,0 +1,20 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<OutputType>Exe</OutputType>
<TargetFramework>net8.0</TargetFramework>
</PropertyGroup>
<ItemGroup>
<Compile Include="build.fs" />
</ItemGroup>
<ItemGroup>
<PackageReference Include="Fake.Core.Target" Version="6.0.0" />
<PackageReference Include="Fake.DotNet.Cli" Version="6.0.0" />
<PackageReference Include="Fake.IO.FileSystem" Version="6.0.0" />
<PackageReference Include="Fake.IO.Zip" Version="6.0.0" />
<PackageReference Include="MSBuild.StructuredLogger" Version="2.2.206" />
</ItemGroup>
</Project>

144
build.fsx
View File

@@ -1,144 +0,0 @@
#r "paket:
nuget Fake.DotNet.Cli
nuget Fake.IO.FileSystem
nuget Fake.IO.Zip
nuget Fake.Core.Target //"
#load ".fake/build.fsx/intellisense.fsx"
open System.IO
open Fake.Core
open Fake.DotNet
open Fake.IO
open Fake.IO.Globbing.Operators
open Fake.Core.TargetOperators
Target.initEnvironment ()
/// The output directory for release ZIPs
let releasePath = "releases"
/// The path to the main project
let projectPath = "src/MyWebLog"
/// The path and name of the main project
let projName = $"{projectPath}/MyWebLog.fsproj"
/// The version being packaged (extracted from appsettings.json)
let version =
let settings = File.ReadAllText $"{projectPath}/appsettings.json"
let generator = settings.Substring (settings.IndexOf "\"Generator\":")
let appVersion = generator.Replace("\"Generator\": \"", "")
let appVersion = appVersion.Substring (0, appVersion.IndexOf "\"")
appVersion.Split ' ' |> Array.last
/// Zip a theme distributed with myWebLog
let zipTheme (name : string) (_ : TargetParameter) =
let path = $"src/{name}-theme"
!! $"{path}/**/*"
|> Zip.filesAsSpecs path //$"src/{name}-theme"
|> Seq.filter (fun (_, name) -> not (name.EndsWith ".zip"))
|> Zip.zipSpec $"{releasePath}/{name}.zip"
/// Publish the project for the given runtime ID
let publishFor rid (_ : TargetParameter) =
DotNet.publish (fun opts -> { opts with Runtime = Some rid; SelfContained = Some false; NoLogo = true }) projName
/// Package published output for the given runtime ID
let packageFor (rid : string) (_ : TargetParameter) =
let path = $"{projectPath}/bin/Release/net6.0/{rid}/publish"
[ !! $"{path}/**/*"
|> Zip.filesAsSpecs path
|> Zip.moveToFolder "app"
Seq.singleton ($"{releasePath}/admin.zip", "admin.zip")
Seq.singleton ($"{releasePath}/default.zip", "default.zip")
]
|> Seq.concat
|> Zip.zipSpec $"{releasePath}/myWebLog-{version}.{rid}.zip"
Target.create "Clean" (fun _ ->
!! "src/**/bin"
++ "src/**/obj"
|> Shell.cleanDirs
Shell.cleanDir releasePath
)
Target.create "Build" (fun _ ->
DotNet.build (fun opts -> { opts with NoLogo = true }) projName
)
Target.create "ZipAdminTheme" (zipTheme "admin")
Target.create "ZipDefaultTheme" (zipTheme "default")
Target.create "PublishWindows" (publishFor "win-x64")
Target.create "PackageWindows" (packageFor "win-x64")
Target.create "PublishLinux" (publishFor "linux-x64")
Target.create "PackageLinux" (packageFor "linux-x64")
Target.create "RepackageLinux" (fun _ ->
let workDir = $"{releasePath}/linux"
let zipArchive = $"{releasePath}/myWebLog-{version}.linux-x64.zip"
let sh command args =
CreateProcess.fromRawCommand command args
|> CreateProcess.redirectOutput
|> Proc.run
|> ignore
Shell.mkdir workDir
Zip.unzip workDir zipArchive
Shell.cd workDir
sh "chmod" [ "+x"; "app/MyWebLog" ]
sh "tar" [ "cfj"; $"../myWebLog-{version}.linux-x64.tar.bz2"; "." ]
Shell.cd "../.."
Shell.rm zipArchive
Shell.rm_rf workDir
)
Target.create "All" ignore
Target.create "RemoveThemeArchives" (fun _ ->
Shell.rm $"{releasePath}/admin.zip"
Shell.rm $"{releasePath}/default.zip"
)
Target.create "CI" ignore
"Clean"
==> "All"
"Clean"
?=> "Build"
==> "All"
"Clean"
?=> "ZipDefaultTheme"
==> "All"
"Clean"
?=> "ZipAdminTheme"
==> "All"
"Build"
==> "PublishWindows"
==> "All"
"Build"
==> "PublishLinux"
==> "All"
"PublishWindows"
==> "PackageWindows"
==> "All"
"PublishLinux"
==> "PackageLinux"
==> "All"
"PackageLinux"
==> "RepackageLinux"
==> "All"
"All"
==> "RemoveThemeArchives"
==> "CI"
Target.runOrDefault "All"

View File

@@ -1,227 +0,0 @@
STORAGE: NONE
RESTRICTION: || (== net6.0) (== netstandard2.0)
NUGET
remote: https://api.nuget.org/v3/index.json
BlackFox.VsWhere (1.1)
FSharp.Core (>= 4.2.3)
Microsoft.Win32.Registry (>= 4.7)
Fake.Core.CommandLineParsing (5.22)
FParsec (>= 1.1.1)
FSharp.Core (>= 6.0)
Fake.Core.Context (5.22)
FSharp.Core (>= 6.0)
Fake.Core.Environment (5.22)
FSharp.Core (>= 6.0)
Fake.Core.FakeVar (5.22)
Fake.Core.Context (>= 5.22)
FSharp.Core (>= 6.0)
Fake.Core.Process (5.22)
Fake.Core.Environment (>= 5.22)
Fake.Core.FakeVar (>= 5.22)
Fake.Core.String (>= 5.22)
Fake.Core.Trace (>= 5.22)
Fake.IO.FileSystem (>= 5.22)
FSharp.Core (>= 6.0)
System.Collections.Immutable (>= 5.0)
Fake.Core.SemVer (5.22)
FSharp.Core (>= 6.0)
Fake.Core.String (5.22)
FSharp.Core (>= 6.0)
Fake.Core.Target (5.22)
Fake.Core.CommandLineParsing (>= 5.22)
Fake.Core.Context (>= 5.22)
Fake.Core.Environment (>= 5.22)
Fake.Core.FakeVar (>= 5.22)
Fake.Core.Process (>= 5.22)
Fake.Core.String (>= 5.22)
Fake.Core.Trace (>= 5.22)
FSharp.Control.Reactive (>= 5.0.2)
FSharp.Core (>= 6.0)
Fake.Core.Tasks (5.22)
Fake.Core.Trace (>= 5.22)
FSharp.Core (>= 6.0)
Fake.Core.Trace (5.22)
Fake.Core.Environment (>= 5.22)
Fake.Core.FakeVar (>= 5.22)
FSharp.Core (>= 6.0)
Fake.Core.Xml (5.22)
Fake.Core.String (>= 5.22)
FSharp.Core (>= 6.0)
Fake.DotNet.Cli (5.22)
Fake.Core.Environment (>= 5.22)
Fake.Core.Process (>= 5.22)
Fake.Core.String (>= 5.22)
Fake.Core.Trace (>= 5.22)
Fake.DotNet.MSBuild (>= 5.22)
Fake.DotNet.NuGet (>= 5.22)
Fake.IO.FileSystem (>= 5.22)
FSharp.Core (>= 6.0)
Mono.Posix.NETStandard (>= 1.0)
Newtonsoft.Json (>= 13.0.1)
Fake.DotNet.MSBuild (5.22)
BlackFox.VsWhere (>= 1.1)
Fake.Core.Environment (>= 5.22)
Fake.Core.Process (>= 5.22)
Fake.Core.String (>= 5.22)
Fake.Core.Trace (>= 5.22)
Fake.IO.FileSystem (>= 5.22)
FSharp.Core (>= 6.0)
MSBuild.StructuredLogger (>= 2.1.545)
Fake.DotNet.NuGet (5.22)
Fake.Core.Environment (>= 5.22)
Fake.Core.Process (>= 5.22)
Fake.Core.SemVer (>= 5.22)
Fake.Core.String (>= 5.22)
Fake.Core.Tasks (>= 5.22)
Fake.Core.Trace (>= 5.22)
Fake.Core.Xml (>= 5.22)
Fake.IO.FileSystem (>= 5.22)
Fake.Net.Http (>= 5.22)
FSharp.Core (>= 6.0)
Newtonsoft.Json (>= 13.0.1)
NuGet.Protocol (>= 5.11)
Fake.IO.FileSystem (5.22)
Fake.Core.String (>= 5.22)
FSharp.Core (>= 6.0)
Fake.IO.Zip (5.22)
Fake.Core.String (>= 5.22)
Fake.IO.FileSystem (>= 5.22)
FSharp.Core (>= 6.0)
Fake.Net.Http (5.22)
Fake.Core.Trace (>= 5.22)
FSharp.Core (>= 6.0)
FParsec (1.1.1)
FSharp.Core (>= 4.3.4)
FSharp.Control.Reactive (5.0.5)
FSharp.Core (>= 4.7.2)
System.Reactive (>= 5.0 < 6.0)
FSharp.Core (6.0.5)
Microsoft.Build (17.2)
Microsoft.Build.Framework (>= 17.2) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
Microsoft.NET.StringTools (>= 1.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
Microsoft.Win32.Registry (>= 4.3) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net6.0))
System.Collections.Immutable (>= 5.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
System.Configuration.ConfigurationManager (>= 4.7) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
System.Reflection.Metadata (>= 1.6) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net6.0))
System.Security.Principal.Windows (>= 4.7) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net6.0))
System.Text.Encoding.CodePages (>= 4.0.1) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net6.0))
System.Text.Json (>= 6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
System.Threading.Tasks.Dataflow (>= 6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
Microsoft.Build.Framework (17.2)
Microsoft.Win32.Registry (>= 4.3)
System.Security.Permissions (>= 4.7)
Microsoft.Build.Tasks.Core (17.2)
Microsoft.Build.Framework (>= 17.2)
Microsoft.Build.Utilities.Core (>= 17.2)
Microsoft.NET.StringTools (>= 1.0)
Microsoft.Win32.Registry (>= 4.3)
System.CodeDom (>= 4.4)
System.Collections.Immutable (>= 5.0)
System.Reflection.Metadata (>= 1.6)
System.Resources.Extensions (>= 4.6)
System.Security.Cryptography.Pkcs (>= 4.7)
System.Security.Cryptography.Xml (>= 4.7)
System.Security.Permissions (>= 4.7)
System.Threading.Tasks.Dataflow (>= 6.0)
Microsoft.Build.Utilities.Core (17.2)
Microsoft.Build.Framework (>= 17.2)
Microsoft.NET.StringTools (>= 1.0)
Microsoft.Win32.Registry (>= 4.3)
System.Collections.Immutable (>= 5.0)
System.Configuration.ConfigurationManager (>= 4.7)
System.Security.Permissions (>= 4.7) - restriction: == netstandard2.0
System.Text.Encoding.CodePages (>= 4.0.1) - restriction: == netstandard2.0
Microsoft.NET.StringTools (1.0)
System.Memory (>= 4.5.4)
System.Runtime.CompilerServices.Unsafe (>= 5.0)
Microsoft.NETCore.Platforms (6.0.4) - restriction: || (&& (== net6.0) (< netcoreapp3.1)) (&& (== net6.0) (< netstandard1.2)) (&& (== net6.0) (< netstandard1.3)) (&& (== net6.0) (< netstandard1.5)) (== netstandard2.0)
Microsoft.NETCore.Targets (5.0) - restriction: || (&& (== net6.0) (< netcoreapp3.1)) (&& (== net6.0) (< netstandard1.2)) (&& (== net6.0) (< netstandard1.3)) (&& (== net6.0) (< netstandard1.5)) (== netstandard2.0)
Microsoft.Win32.Registry (5.0)
System.Buffers (>= 4.5.1) - restriction: || (&& (== net6.0) (>= monoandroid) (< netstandard1.3)) (&& (== net6.0) (>= monotouch)) (&& (== net6.0) (< netcoreapp2.0)) (&& (== net6.0) (>= xamarinios)) (&& (== net6.0) (>= xamarinmac)) (&& (== net6.0) (>= xamarintvos)) (&& (== net6.0) (>= xamarinwatchos)) (== netstandard2.0)
System.Memory (>= 4.5.4) - restriction: || (&& (== net6.0) (< netcoreapp2.0)) (&& (== net6.0) (< netcoreapp2.1)) (&& (== net6.0) (>= uap10.1)) (== netstandard2.0)
System.Security.AccessControl (>= 5.0)
System.Security.Principal.Windows (>= 5.0)
Microsoft.Win32.SystemEvents (6.0.1) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= netcoreapp3.1))
Mono.Posix.NETStandard (1.0)
MSBuild.StructuredLogger (2.1.669)
Microsoft.Build (>= 16.10)
Microsoft.Build.Framework (>= 16.10)
Microsoft.Build.Tasks.Core (>= 16.10)
Microsoft.Build.Utilities.Core (>= 16.10)
Newtonsoft.Json (13.0.1)
NuGet.Common (6.2.1)
NuGet.Frameworks (>= 6.2.1)
NuGet.Configuration (6.2.1)
NuGet.Common (>= 6.2.1)
System.Security.Cryptography.ProtectedData (>= 4.4)
NuGet.Frameworks (6.2.1)
NuGet.Packaging (6.2.1)
Newtonsoft.Json (>= 13.0.1)
NuGet.Configuration (>= 6.2.1)
NuGet.Versioning (>= 6.2.1)
System.Security.Cryptography.Cng (>= 5.0)
System.Security.Cryptography.Pkcs (>= 5.0)
NuGet.Protocol (6.2.1)
NuGet.Packaging (>= 6.2.1)
NuGet.Versioning (6.2.1)
System.Buffers (4.5.1) - restriction: || (&& (== net6.0) (>= monoandroid) (< netstandard1.3)) (&& (== net6.0) (>= monotouch)) (&& (== net6.0) (< netcoreapp2.0)) (&& (== net6.0) (>= xamarinios)) (&& (== net6.0) (>= xamarinmac)) (&& (== net6.0) (>= xamarintvos)) (&& (== net6.0) (>= xamarinwatchos)) (== netstandard2.0)
System.CodeDom (6.0)
System.Collections.Immutable (6.0)
System.Memory (>= 4.5.4) - restriction: || (&& (== net6.0) (>= net461)) (== netstandard2.0)
System.Runtime.CompilerServices.Unsafe (>= 6.0)
System.Configuration.ConfigurationManager (6.0)
System.Security.Cryptography.ProtectedData (>= 6.0)
System.Security.Permissions (>= 6.0)
System.Drawing.Common (6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= netcoreapp3.1))
Microsoft.Win32.SystemEvents (>= 6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= netcoreapp3.1))
System.Formats.Asn1 (6.0)
System.Buffers (>= 4.5.1) - restriction: || (&& (== net6.0) (>= net461)) (== netstandard2.0)
System.Memory (>= 4.5.4) - restriction: || (&& (== net6.0) (>= net461)) (== netstandard2.0)
System.Memory (4.5.5)
System.Buffers (>= 4.5.1) - restriction: || (&& (== net6.0) (>= monotouch)) (&& (== net6.0) (>= net461)) (&& (== net6.0) (< netcoreapp2.0)) (&& (== net6.0) (< netstandard1.1)) (&& (== net6.0) (< netstandard2.0)) (&& (== net6.0) (>= xamarinios)) (&& (== net6.0) (>= xamarinmac)) (&& (== net6.0) (>= xamarintvos)) (&& (== net6.0) (>= xamarinwatchos)) (== netstandard2.0)
System.Numerics.Vectors (>= 4.4) - restriction: || (&& (== net6.0) (< netcoreapp2.0)) (== netstandard2.0)
System.Runtime.CompilerServices.Unsafe (>= 4.5.3) - restriction: || (&& (== net6.0) (>= monotouch)) (&& (== net6.0) (>= net461)) (&& (== net6.0) (< netcoreapp2.0)) (&& (== net6.0) (< netcoreapp2.1)) (&& (== net6.0) (< netstandard1.1)) (&& (== net6.0) (< netstandard2.0)) (&& (== net6.0) (>= uap10.1)) (&& (== net6.0) (>= xamarinios)) (&& (== net6.0) (>= xamarinmac)) (&& (== net6.0) (>= xamarintvos)) (&& (== net6.0) (>= xamarinwatchos)) (== netstandard2.0)
System.Numerics.Vectors (4.5) - restriction: || (&& (== net6.0) (>= net461)) (== netstandard2.0)
System.Reactive (5.0)
System.Runtime.InteropServices.WindowsRuntime (>= 4.3) - restriction: || (&& (== net6.0) (< netcoreapp3.1)) (== netstandard2.0)
System.Threading.Tasks.Extensions (>= 4.5.4) - restriction: || (&& (== net6.0) (>= net472)) (&& (== net6.0) (< netcoreapp3.1)) (&& (== net6.0) (>= uap10.1)) (== netstandard2.0)
System.Reflection.Metadata (6.0.1)
System.Collections.Immutable (>= 6.0)
System.Resources.Extensions (6.0)
System.Memory (>= 4.5.4) - restriction: || (&& (== net6.0) (>= net461)) (== netstandard2.0)
System.Runtime (4.3.1) - restriction: || (&& (== net6.0) (< netcoreapp3.1)) (== netstandard2.0)
Microsoft.NETCore.Platforms (>= 1.1.1)
Microsoft.NETCore.Targets (>= 1.1.3)
System.Runtime.CompilerServices.Unsafe (6.0)
System.Runtime.InteropServices.WindowsRuntime (4.3) - restriction: || (&& (== net6.0) (< netcoreapp3.1)) (== netstandard2.0)
System.Runtime (>= 4.3)
System.Security.AccessControl (6.0)
System.Security.Principal.Windows (>= 5.0) - restriction: || (&& (== net6.0) (>= net461)) (== netstandard2.0)
System.Security.Cryptography.Cng (5.0)
System.Formats.Asn1 (>= 5.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= netcoreapp3.0))
System.Security.Cryptography.Pkcs (6.0.1)
System.Buffers (>= 4.5.1) - restriction: || (&& (== net6.0) (< netstandard2.1)) (== netstandard2.0)
System.Formats.Asn1 (>= 6.0)
System.Memory (>= 4.5.4) - restriction: || (&& (== net6.0) (< netstandard2.1)) (== netstandard2.0)
System.Security.Cryptography.Cng (>= 5.0) - restriction: || (&& (== net6.0) (< netcoreapp3.1)) (&& (== net6.0) (< netstandard2.1)) (== netstandard2.0)
System.Security.Cryptography.ProtectedData (6.0)
System.Security.Cryptography.Xml (6.0)
System.Memory (>= 4.5.4) - restriction: == netstandard2.0
System.Security.AccessControl (>= 6.0)
System.Security.Cryptography.Pkcs (>= 6.0)
System.Security.Permissions (6.0)
System.Security.AccessControl (>= 6.0)
System.Windows.Extensions (>= 6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= netcoreapp3.1))
System.Security.Principal.Windows (5.0)
System.Text.Encoding.CodePages (6.0)
System.Runtime.CompilerServices.Unsafe (>= 6.0)
System.Text.Encodings.Web (6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
System.Runtime.CompilerServices.Unsafe (>= 6.0)
System.Text.Json (6.0.5) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= net472)) (&& (== netstandard2.0) (>= net6.0))
System.Runtime.CompilerServices.Unsafe (>= 6.0)
System.Text.Encodings.Web (>= 6.0)
System.Threading.Tasks.Dataflow (6.0)
System.Threading.Tasks.Extensions (4.5.4) - restriction: || (&& (== net6.0) (>= net472)) (&& (== net6.0) (< netcoreapp3.1)) (&& (== net6.0) (>= uap10.1)) (== netstandard2.0)
System.Runtime.CompilerServices.Unsafe (>= 4.5.3) - restriction: || (&& (== net6.0) (>= net461)) (&& (== net6.0) (< netcoreapp2.1)) (&& (== net6.0) (< netstandard1.0)) (&& (== net6.0) (< netstandard2.0)) (&& (== net6.0) (>= wp8)) (== netstandard2.0)
System.Windows.Extensions (6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= netcoreapp3.1))
System.Drawing.Common (>= 6.0) - restriction: || (== net6.0) (&& (== netstandard2.0) (>= netcoreapp3.1))

View File

@@ -1,2 +0,0 @@
dotnet tool restore
dotnet fake %*

View File

@@ -1,7 +0,0 @@
#!/usr/bin/env bash
set -eu
set -o pipefail
dotnet tool restore
dotnet fake "$@"

View File

@@ -1,171 +0,0 @@
// Category
r.db('myWebLog').table('Category').map({
Description: r.row('description'),
Id: r.row('id'),
Name: r.row('name'),
ParentId: r.row('parentId'),
Slug: r.row('slug'),
WebLogId: r.row('webLogId')
})
// Page
r.db('myWebLog').table('Page').map({
AuthorId: r.row('authorId'),
Id: r.row('id'),
Metadata: r.row('metadata').map(function (meta) {
return { Name: meta('name'), Value: meta('value') }
}),
Permalink: r.row('permalink'),
PriorPermalinks: r.row('priorPermalinks'),
PublishedOn: r.row('publishedOn'),
Revisions: r.row('revisions').map(function (rev) {
return {
AsOf: rev('asOf'),
Text: rev('text')
}
}),
IsInPageList: r.row('showInPageList'),
Template: r.row('template'),
Text: r.row('text'),
Title: r.row('title'),
UpdatedOn: r.row('updatedOn'),
WebLogId: r.row('webLogId')
})
// Post
r.db('myWebLog').table('Post').map({
AuthorId: r.row('authorId'),
CategoryIds: r.row('categoryIds'),
Episode: r.branch(r.row.hasFields('episode'), {
Duration: r.row('episode')('duration'),
Length: r.row('episode')('length'),
Media: r.row('episode')('media'),
MediaType: r.row('episode')('mediaType').default(null),
ImageUrl: r.row('episode')('imageUrl').default(null),
Subtitle: r.row('episode')('subtitle').default(null),
Explicit: r.row('episode')('explicit').default(null),
ChapterFile: r.row('episode')('chapterFile').default(null),
ChapterType: r.row('episode')('chapterType').default(null),
TranscriptUrl: r.row('episode')('transcriptUrl').default(null),
TranscriptType: r.row('episode')('transcriptType').default(null),
TranscriptLang: r.row('episode')('transcriptLang').default(null),
TranscriptCaptions: r.row('episode')('transcriptCaptions').default(null),
SeasonNumber: r.row('episode')('seasonNumber').default(null),
SeasonDescription: r.row('episode')('seasonDescription').default(null),
EpisodeNumber: r.row('episode')('episodeNumber').default(null),
EpisodeDescription: r.row('episode')('episodeDescription').default(null)
}, null),
Id: r.row('id'),
Metadata: r.row('metadata').map(function (meta) {
return { Name: meta('name'), Value: meta('value') }
}),
Permalink: r.row('permalink'),
PriorPermalinks: r.row('priorPermalinks'),
PublishedOn: r.row('publishedOn'),
Revisions: r.row('revisions').map(function (rev) {
return {
AsOf: rev('asOf'),
Text: rev('text')
}
}),
Status: r.row('status'),
Tags: r.row('tags'),
Template: r.row('template').default(null),
Text: r.row('text'),
Title: r.row('title'),
UpdatedOn: r.row('updatedOn'),
WebLogId: r.row('webLogId')
})
// TagMap
r.db('myWebLog').table('TagMap').map({
Id: r.row('id'),
Tag: r.row('tag'),
UrlValue: r.row('urlValue'),
WebLogId: r.row('webLogId')
})
// Theme
r.db('myWebLog').table('Theme').map({
Id: r.row('id'),
Name: r.row('name'),
Templates: r.row('templates').map(function (tmpl) {
return {
Name: tmpl('name'),
Text: tmpl('text')
}
}),
Version: r.row('version')
})
// ThemeAsset
r.db('myWebLog').table('ThemeAsset').map({
Data: r.row('data'),
Id: r.row('id'),
UpdatedOn: r.row('updatedOn')
})
// WebLog
r.db('myWebLog').table('WebLog').map(
{ AutoHtmx: r.row('autoHtmx'),
DefaultPage: r.row('defaultPage'),
Id: r.row('id'),
Name: r.row('name'),
PostsPerPage: r.row('postsPerPage'),
Rss: {
IsCategoryEnabled: r.row('rss')('categoryEnabled'),
Copyright: r.row('rss')('copyright'),
CustomFeeds: r.row('rss')('customFeeds').map(function (feed) {
return {
Id: feed('id'),
Path: feed('path'),
Podcast: {
DefaultMediaType: feed('podcast')('defaultMediaType'),
DisplayedAuthor: feed('podcast')('displayedAuthor'),
Email: feed('podcast')('email'),
Explicit: feed('podcast')('explicit'),
FundingText: feed('podcast')('fundingText'),
FundingUrl: feed('podcast')('fundingUrl'),
PodcastGuid: feed('podcast')('guid'),
AppleCategory: feed('podcast')('iTunesCategory'),
AppleSubcategory: feed('podcast')('iTunesSubcategory'),
ImageUrl: feed('podcast')('imageUrl'),
ItemsInFeed: feed('podcast')('itemsInFeed'),
MediaBaseUrl: feed('podcast')('mediaBaseUrl'),
Medium: feed('podcast')('medium'),
Subtitle: feed('podcast')('subtitle'),
Summary: feed('podcast')('summary'),
Title: feed('podcast')('title')
},
Source: feed('source')
}
}),
IsFeedEnabled: r.row('rss')('feedEnabled'),
FeedName: r.row('rss')('feedName'),
ItemsInFeed: r.row('rss')('itemsInFeed'),
IsTagEnabled: r.row('rss')('tagEnabled')
},
Slug: r.row('slug'),
Subtitle: r.row('subtitle'),
ThemeId: r.row('themePath'),
TimeZone: r.row('timeZone'),
Uploads: r.row('uploads'),
UrlBase: r.row('urlBase')
})
// WebLogUser
r.db('myWebLog').table('WebLogUser').map({
AccessLevel: r.row('authorizationLevel'),
FirstName: r.row('firstName'),
Id: r.row('id'),
LastName: r.row('lastName'),
PasswordHash: r.row('passwordHash'),
PreferredName: r.row('preferredName'),
Salt: r.row('salt'),
Url: r.row('url'),
Email: r.row('userName'),
WebLogId: r.row('webLogId'),
CreatedOn: r.branch(r.row.hasFields('createdOn'), r.row('createdOn'), r.expr(new Date(0))),
LastSeenOn: r.row('lastSeenOn').default(null)
})

4
src/.dockerignore Normal file
View File

@@ -0,0 +1,4 @@
**/bin
**/obj
**/*.db
**/appsettings.*.json

View File

@@ -0,0 +1,9 @@
<Project>
<PropertyGroup>
<TargetFrameworks>net6.0;net8.0</TargetFrameworks>
<DebugType>embedded</DebugType>
<AssemblyVersion>2.2.0.0</AssemblyVersion>
<FileVersion>2.2.0.0</FileVersion>
<Version>2.2.0</Version>
</PropertyGroup>
</Project>

33
src/Dockerfile Normal file
View File

@@ -0,0 +1,33 @@
FROM mcr.microsoft.com/dotnet/sdk:8.0-alpine AS build
WORKDIR /mwl
COPY ./MyWebLog.sln ./
COPY ./Directory.Build.props ./
COPY ./MyWebLog/MyWebLog.fsproj ./MyWebLog/
COPY ./MyWebLog.Data/MyWebLog.Data.fsproj ./MyWebLog.Data/
COPY ./MyWebLog.Domain/MyWebLog.Domain.fsproj ./MyWebLog.Domain/
COPY ./MyWebLog.Tests/MyWebLog.Tests.fsproj ./MyWebLog.Tests/
RUN dotnet restore
COPY . ./
WORKDIR /mwl/MyWebLog
RUN dotnet publish -f net8.0 -c Release -r linux-x64 --no-self-contained -p:PublishSingleFile=false
FROM alpine AS theme
RUN apk add --no-cache zip
WORKDIR /themes/default-theme
COPY ./default-theme ./
RUN zip -r ../default-theme.zip ./*
WORKDIR /themes/admin-theme
COPY ./admin-theme ./
RUN zip -r ../admin-theme.zip ./*
FROM mcr.microsoft.com/dotnet/aspnet:8.0-alpine as final
WORKDIR /app
RUN apk add --no-cache icu-libs
ENV DOTNET_SYSTEM_GLOBALIZATION_INVARIANT=false
COPY --from=build /mwl/MyWebLog/bin/Release/net8.0/linux-x64/publish/ ./
COPY --from=theme /themes/*.zip /app/
RUN mkdir themes
EXPOSE 80
CMD [ "dotnet", "/app/MyWebLog.dll" ]

View File

@@ -12,123 +12,132 @@ module Json =
type CategoryIdConverter() =
inherit JsonConverter<CategoryId>()
override _.WriteJson(writer: JsonWriter, value: CategoryId, _: JsonSerializer) =
writer.WriteValue (CategoryId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: CategoryId, _: bool, _: JsonSerializer) =
(string >> CategoryId) reader.Value
type CommentIdConverter() =
inherit JsonConverter<CommentId>()
override _.WriteJson(writer: JsonWriter, value: CommentId, _: JsonSerializer) =
writer.WriteValue (CommentId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: CommentId, _: bool, _: JsonSerializer) =
(string >> CommentId) reader.Value
type CommentStatusConverter() =
inherit JsonConverter<CommentStatus>()
override _.WriteJson(writer: JsonWriter, value: CommentStatus, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: CommentStatus, _: bool, _: JsonSerializer) =
(string >> CommentStatus.Parse) reader.Value
type CustomFeedIdConverter() =
inherit JsonConverter<CustomFeedId>()
override _.WriteJson(writer: JsonWriter, value: CustomFeedId, _: JsonSerializer) =
writer.WriteValue (CustomFeedId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedId, _: bool, _: JsonSerializer) =
(string >> CustomFeedId) reader.Value
type CustomFeedSourceConverter() =
inherit JsonConverter<CustomFeedSource>()
override _.WriteJson(writer: JsonWriter, value: CustomFeedSource, _: JsonSerializer) =
writer.WriteValue (CustomFeedSource.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedSource, _: bool, _: JsonSerializer) =
(string >> CustomFeedSource.parse) reader.Value
(string >> CustomFeedSource.Parse) reader.Value
type ExplicitRatingConverter() =
inherit JsonConverter<ExplicitRating>()
override _.WriteJson(writer: JsonWriter, value: ExplicitRating, _: JsonSerializer) =
writer.WriteValue (ExplicitRating.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: ExplicitRating, _: bool, _: JsonSerializer) =
(string >> ExplicitRating.parse) reader.Value
(string >> ExplicitRating.Parse) reader.Value
type MarkupTextConverter() =
inherit JsonConverter<MarkupText>()
override _.WriteJson(writer: JsonWriter, value: MarkupText, _: JsonSerializer) =
writer.WriteValue (MarkupText.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: MarkupText, _: bool, _: JsonSerializer) =
(string >> MarkupText.parse) reader.Value
(string >> MarkupText.Parse) reader.Value
type PermalinkConverter() =
inherit JsonConverter<Permalink>()
override _.WriteJson(writer: JsonWriter, value: Permalink, _: JsonSerializer) =
writer.WriteValue (Permalink.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: Permalink, _: bool, _: JsonSerializer) =
(string >> Permalink) reader.Value
type PageIdConverter() =
inherit JsonConverter<PageId>()
override _.WriteJson(writer: JsonWriter, value: PageId, _: JsonSerializer) =
writer.WriteValue (PageId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: PageId, _: bool, _: JsonSerializer) =
(string >> PageId) reader.Value
type PodcastMediumConverter() =
inherit JsonConverter<PodcastMedium>()
override _.WriteJson(writer: JsonWriter, value: PodcastMedium, _: JsonSerializer) =
writer.WriteValue (PodcastMedium.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: PodcastMedium, _: bool, _: JsonSerializer) =
(string >> PodcastMedium.parse) reader.Value
(string >> PodcastMedium.Parse) reader.Value
type PostIdConverter() =
inherit JsonConverter<PostId>()
override _.WriteJson(writer: JsonWriter, value: PostId, _: JsonSerializer) =
writer.WriteValue (PostId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: PostId, _: bool, _: JsonSerializer) =
(string >> PostId) reader.Value
type TagMapIdConverter() =
inherit JsonConverter<TagMapId>()
override _.WriteJson(writer: JsonWriter, value: TagMapId, _: JsonSerializer) =
writer.WriteValue (TagMapId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: TagMapId, _: bool, _: JsonSerializer) =
(string >> TagMapId) reader.Value
type ThemeAssetIdConverter() =
inherit JsonConverter<ThemeAssetId>()
override _.WriteJson(writer: JsonWriter, value: ThemeAssetId, _: JsonSerializer) =
writer.WriteValue (ThemeAssetId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: ThemeAssetId, _: bool, _: JsonSerializer) =
(string >> ThemeAssetId.ofString) reader.Value
(string >> ThemeAssetId.Parse) reader.Value
type ThemeIdConverter() =
inherit JsonConverter<ThemeId>()
override _.WriteJson(writer: JsonWriter, value: ThemeId, _: JsonSerializer) =
writer.WriteValue (ThemeId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: ThemeId, _: bool, _: JsonSerializer) =
(string >> ThemeId) reader.Value
type UploadIdConverter() =
inherit JsonConverter<UploadId>()
override _.WriteJson(writer: JsonWriter, value: UploadId, _: JsonSerializer) =
writer.WriteValue (UploadId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: UploadId, _: bool, _: JsonSerializer) =
(string >> UploadId) reader.Value
type WebLogIdConverter() =
inherit JsonConverter<WebLogId>()
override _.WriteJson(writer: JsonWriter, value: WebLogId, _: JsonSerializer) =
writer.WriteValue (WebLogId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: WebLogId, _: bool, _: JsonSerializer) =
(string >> WebLogId) reader.Value
type WebLogUserIdConverter() =
inherit JsonConverter<WebLogUserId> ()
override _.WriteJson(writer: JsonWriter, value: WebLogUserId, _: JsonSerializer) =
writer.WriteValue (WebLogUserId.toString value)
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: WebLogUserId, _: bool, _: JsonSerializer) =
(string >> WebLogUserId) reader.Value
open Microsoft.FSharpLu.Json
open NodaTime
open NodaTime.Serialization.JsonNet
/// All converters to use for data conversion
let all () : JsonConverter seq =
seq {
/// Configure a serializer to use these converters
let configure (ser : JsonSerializer) =
// Our converters
CategoryIdConverter ()
[ CategoryIdConverter() :> JsonConverter
CommentIdConverter()
CommentStatusConverter()
CustomFeedIdConverter()
CustomFeedSourceConverter()
ExplicitRatingConverter()
@@ -142,7 +151,37 @@ module Json =
ThemeIdConverter()
UploadIdConverter()
WebLogIdConverter()
WebLogUserIdConverter ()
WebLogUserIdConverter() ]
|> List.iter ser.Converters.Add
// NodaTime
let _ = ser.ConfigureForNodaTime DateTimeZoneProviders.Tzdb
// Handles DUs with no associated data, as well as option fields
CompactUnionJsonConverter ()
}
ser.Converters.Add(CompactUnionJsonConverter())
ser.NullValueHandling <- NullValueHandling.Ignore
ser.MissingMemberHandling <- MissingMemberHandling.Ignore
ser
/// Serializer settings extracted from a JsonSerializer (a property sure would be nice...)
let mutable private serializerSettings : JsonSerializerSettings option = None
/// Extract settings from the serializer to be used in JsonConvert calls
let settings (ser : JsonSerializer) =
if Option.isNone serializerSettings then
serializerSettings <- JsonSerializerSettings (
ConstructorHandling = ser.ConstructorHandling,
ContractResolver = ser.ContractResolver,
Converters = ser.Converters,
DefaultValueHandling = ser.DefaultValueHandling,
DateFormatHandling = ser.DateFormatHandling,
DateParseHandling = ser.DateParseHandling,
MetadataPropertyHandling = ser.MetadataPropertyHandling,
MissingMemberHandling = ser.MissingMemberHandling,
NullValueHandling = ser.NullValueHandling,
ObjectCreationHandling = ser.ObjectCreationHandling,
ReferenceLoopHandling = ser.ReferenceLoopHandling,
SerializationBinder = ser.SerializationBinder,
TraceWriter = ser.TraceWriter,
TypeNameAssemblyFormatHandling = ser.TypeNameAssemblyFormatHandling,
TypeNameHandling = ser.TypeNameHandling)
|> Some
serializerSettings.Value

View File

@@ -1,9 +1,21 @@
namespace MyWebLog.Data
open System
open System.Threading.Tasks
open MyWebLog
open MyWebLog.ViewModels
open Newtonsoft.Json
open NodaTime
/// The result of a category deletion attempt
[<Struct>]
type CategoryDeleteResult =
/// The category was deleted successfully
| CategoryDeleted
/// The category was deleted successfully, and its children were reassigned to its parent
| ReassignedChildCategories
/// The category was not found, so no effort was made to delete it
| CategoryNotFound
/// Data functions to support manipulating categories
type ICategoryData =
@@ -18,10 +30,10 @@ type ICategoryData =
abstract member CountTopLevel : WebLogId -> Task<int>
/// Delete a category (also removes it from posts)
abstract member Delete : CategoryId -> WebLogId -> Task<bool>
abstract member Delete : CategoryId -> WebLogId -> Task<CategoryDeleteResult>
/// Find all categories for a web log, sorted alphabetically and grouped by hierarchy
abstract member FindAllForView : WebLogId -> Task<DisplayCategory[]>
abstract member FindAllForView : WebLogId -> Task<DisplayCategory array>
/// Find a category by its ID
abstract member FindById : CategoryId -> WebLogId -> Task<Category option>
@@ -42,7 +54,7 @@ type IPageData =
/// Add a page
abstract member Add : Page -> Task<unit>
/// Get all pages for the web log (excluding meta items, text, revisions, and prior permalinks)
/// Get all pages for the web log (excluding text, metadata, revisions, and prior permalinks)
abstract member All : WebLogId -> Task<Page list>
/// Count all pages for the given web log
@@ -116,7 +128,7 @@ type IPostData =
abstract member FindPageOfCategorizedPosts :
WebLogId -> CategoryId list -> pageNbr: int -> postsPerPage: int -> Task<Post list>
/// Find posts to be displayed on an admin page (excluding revisions and prior permalinks)
/// Find posts to be displayed on an admin page (excluding text, revisions, and prior permalinks)
abstract member FindPageOfPosts : WebLogId -> pageNbr: int -> postsPerPage: int -> Task<Post list>
/// Find posts to be displayed on a page (excluding revisions and prior permalinks)
@@ -127,7 +139,7 @@ type IPostData =
WebLogId -> tag : string -> pageNbr: int -> postsPerPage: int -> Task<Post list>
/// Find the next older and newer post for the given published date/time (excluding revisions and prior permalinks)
abstract member FindSurroundingPosts : WebLogId -> publishedOn : DateTime -> Task<Post option * Post option>
abstract member FindSurroundingPosts : WebLogId -> publishedOn: Instant -> Task<Post option * Post option>
/// Restore posts from a backup
abstract member Restore : Post list -> Task<unit>
@@ -167,9 +179,15 @@ type ITagMapData =
/// Functions to manipulate themes
type IThemeData =
/// Retrieve all themes (except "admin")
/// Retrieve all themes (except "admin") (excluding the text of templates)
abstract member All : unit -> Task<Theme list>
/// Delete a theme
abstract member Delete : ThemeId -> Task<bool>
/// Determine if a theme exists
abstract member Exists : ThemeId -> Task<bool>
/// Find a theme by its ID
abstract member FindById : ThemeId -> Task<Theme option>
@@ -242,6 +260,9 @@ type IWebLogData =
/// Find a web log by its ID
abstract member FindById : WebLogId -> Task<WebLog option>
/// Update redirect rules for a web log
abstract member UpdateRedirectRules : WebLog -> Task<unit>
/// Update RSS options for a web log
abstract member UpdateRssOptions : WebLog -> Task<unit>
@@ -310,6 +331,9 @@ type IData =
/// Web log user data functions
abstract member WebLogUser : IWebLogUserData
/// A JSON serializer for use in persistence
abstract member Serializer : JsonSerializer
/// Do any required start up data checks
abstract member StartUp : unit -> Task<unit>

View File

@@ -1,23 +1,21 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net6.0</TargetFramework>
<GenerateDocumentationFile>true</GenerateDocumentationFile>
<DebugType>embedded</DebugType>
</PropertyGroup>
<ItemGroup>
<ProjectReference Include="..\MyWebLog.Domain\MyWebLog.Domain.fsproj" />
</ItemGroup>
<ItemGroup>
<PackageReference Include="Microsoft.Data.Sqlite" Version="6.0.7" />
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="6.0.0" />
<PackageReference Include="BitBadger.Documents.Postgres" Version="3.1.0" />
<PackageReference Include="BitBadger.Documents.Sqlite" Version="3.1.0" />
<PackageReference Include="Microsoft.Data.Sqlite" Version="8.0.6" />
<PackageReference Include="Microsoft.Extensions.Caching.Abstractions" Version="8.0.0" />
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="8.0.0" />
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.1" />
<PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.1.0" />
<PackageReference Include="Npgsql.NodaTime" Version="8.0.3" />
<PackageReference Include="RethinkDb.Driver" Version="2.3.150" />
<PackageReference Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-07" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
</ItemGroup>
<ItemGroup>
@@ -25,7 +23,7 @@
<Compile Include="Interfaces.fs" />
<Compile Include="Utils.fs" />
<Compile Include="RethinkDbData.fs" />
<Compile Include="SQLite\Helpers.fs" />
<Compile Include="SQLite\SQLiteHelpers.fs" />
<Compile Include="SQLite\SQLiteCategoryData.fs" />
<Compile Include="SQLite\SQLitePageData.fs" />
<Compile Include="SQLite\SQLitePostData.fs" />
@@ -35,6 +33,23 @@
<Compile Include="SQLite\SQLiteWebLogData.fs" />
<Compile Include="SQLite\SQLiteWebLogUserData.fs" />
<Compile Include="SQLiteData.fs" />
<Compile Include="Postgres\PostgresHelpers.fs" />
<Compile Include="Postgres\PostgresCache.fs" />
<Compile Include="Postgres\PostgresCategoryData.fs" />
<Compile Include="Postgres\PostgresPageData.fs" />
<Compile Include="Postgres\PostgresPostData.fs" />
<Compile Include="Postgres\PostgresTagMapData.fs" />
<Compile Include="Postgres\PostgresThemeData.fs" />
<Compile Include="Postgres\PostgresUploadData.fs" />
<Compile Include="Postgres\PostgresWebLogData.fs" />
<Compile Include="Postgres\PostgresWebLogUserData.fs" />
<Compile Include="PostgresData.fs" />
</ItemGroup>
<ItemGroup>
<AssemblyAttribute Include="System.Runtime.CompilerServices.InternalsVisibleToAttribute">
<_Parameter1>MyWebLog.Tests</_Parameter1>
</AssemblyAttribute>
</ItemGroup>
</Project>

View File

@@ -0,0 +1,187 @@
namespace MyWebLog.Data.Postgres
open System.Threading
open System.Threading.Tasks
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Caching.Distributed
open NodaTime
/// Helper types and functions for the cache
[<AutoOpen>]
module private Helpers =
/// The cache entry
type Entry = {
/// The ID of the cache entry
Id: string
/// The value to be cached
Payload: byte array
/// When this entry will expire
ExpireAt: Instant
/// The duration by which the expiration should be pushed out when being refreshed
SlidingExpiration: Duration option
/// The must-expire-by date/time for the cache entry
AbsoluteExpiration: Instant option
}
/// Run a task synchronously
let sync<'T> (it: Task<'T>) = it |> (Async.AwaitTask >> Async.RunSynchronously)
/// Get the current instant
let getNow () = SystemClock.Instance.GetCurrentInstant()
/// Create a parameter for the expire-at time
let expireParam =
typedParam "expireAt"
/// A distributed cache implementation in PostgreSQL used to handle sessions for myWebLog
type DistributedCache () =
// ~~~ INITIALIZATION ~~~
do
task {
let! exists =
Custom.scalar
"SELECT EXISTS
(SELECT 1 FROM pg_tables WHERE schemaname = 'public' AND tablename = 'session')
AS it"
[]
toExists
if not exists then
do! Custom.nonQuery
"CREATE TABLE session (
id TEXT NOT NULL PRIMARY KEY,
payload BYTEA NOT NULL,
expire_at TIMESTAMPTZ NOT NULL,
sliding_expiration INTERVAL,
absolute_expiration TIMESTAMPTZ);
CREATE INDEX idx_session_expiration ON session (expire_at)" []
} |> sync
// ~~~ SUPPORT FUNCTIONS ~~~
/// Get an entry, updating it for sliding expiration
let getEntry key = backgroundTask {
let idParam = "@id", Sql.string key
let! tryEntry =
Custom.single
"SELECT * FROM session WHERE id = @id"
[ idParam ]
(fun row ->
{ Id = row.string "id"
Payload = row.bytea "payload"
ExpireAt = row.fieldValue<Instant> "expire_at"
SlidingExpiration = row.fieldValueOrNone<Duration> "sliding_expiration"
AbsoluteExpiration = row.fieldValueOrNone<Instant> "absolute_expiration" })
match tryEntry with
| Some entry ->
let now = getNow ()
let slideExp = defaultArg entry.SlidingExpiration Duration.MinValue
let absExp = defaultArg entry.AbsoluteExpiration Instant.MinValue
let needsRefresh, item =
if entry.ExpireAt = absExp then false, entry
elif slideExp = Duration.MinValue && absExp = Instant.MinValue then false, entry
elif absExp > Instant.MinValue && entry.ExpireAt.Plus slideExp > absExp then
true, { entry with ExpireAt = absExp }
else true, { entry with ExpireAt = now.Plus slideExp }
if needsRefresh then
do! Custom.nonQuery
"UPDATE session SET expire_at = @expireAt WHERE id = @id"
[ expireParam item.ExpireAt; idParam ]
()
return if item.ExpireAt > now then Some entry else None
| None -> return None
}
/// The last time expired entries were purged (runs every 30 minutes)
let mutable lastPurge = Instant.MinValue
/// Purge expired entries every 30 minutes
let purge () = backgroundTask {
let now = getNow ()
if lastPurge.Plus(Duration.FromMinutes 30L) < now then
do! Custom.nonQuery "DELETE FROM session WHERE expire_at < @expireAt" [ expireParam now ]
lastPurge <- now
}
/// Remove a cache entry
let removeEntry key =
Custom.nonQuery "DELETE FROM session WHERE id = @id" [ "@id", Sql.string key ]
/// Save an entry
let saveEntry (opts: DistributedCacheEntryOptions) key payload =
let now = getNow ()
let expireAt, slideExp, absExp =
if opts.SlidingExpiration.HasValue then
let slide = Duration.FromTimeSpan opts.SlidingExpiration.Value
now.Plus slide, Some slide, None
elif opts.AbsoluteExpiration.HasValue then
let exp = Instant.FromDateTimeOffset opts.AbsoluteExpiration.Value
exp, None, Some exp
elif opts.AbsoluteExpirationRelativeToNow.HasValue then
let exp = now.Plus(Duration.FromTimeSpan opts.AbsoluteExpirationRelativeToNow.Value)
exp, None, Some exp
else
// Default to 1 hour sliding expiration
let slide = Duration.FromHours 1
now.Plus slide, Some slide, None
Custom.nonQuery
"INSERT INTO session (
id, payload, expire_at, sliding_expiration, absolute_expiration
) VALUES (
@id, @payload, @expireAt, @slideExp, @absExp
) ON CONFLICT (id) DO UPDATE
SET payload = EXCLUDED.payload,
expire_at = EXCLUDED.expire_at,
sliding_expiration = EXCLUDED.sliding_expiration,
absolute_expiration = EXCLUDED.absolute_expiration"
[ "@id", Sql.string key
"@payload", Sql.bytea payload
expireParam expireAt
optParam "slideExp" slideExp
optParam "absExp" absExp ]
// ~~~ IMPLEMENTATION FUNCTIONS ~~~
/// Retrieve the data for a cache entry
let get key (_: CancellationToken) = backgroundTask {
match! getEntry key with
| Some entry ->
do! purge ()
return entry.Payload
| None -> return null
}
/// Refresh an entry
let refresh key (cancelToken: CancellationToken) = backgroundTask {
let! _ = get key cancelToken
()
}
/// Remove an entry
let remove key (_: CancellationToken) = backgroundTask {
do! removeEntry key
do! purge ()
}
/// Set an entry
let set key value options (_: CancellationToken) = backgroundTask {
do! saveEntry options key value
do! purge ()
}
interface IDistributedCache with
member _.Get key = get key CancellationToken.None |> sync
member _.GetAsync(key, token) = get key token
member _.Refresh key = refresh key CancellationToken.None |> sync
member _.RefreshAsync(key, token) = refresh key token
member _.Remove key = remove key CancellationToken.None |> sync
member _.RemoveAsync(key, token) = remove key token
member _.Set(key, value, options) = set key value options CancellationToken.None |> sync
member _.SetAsync(key, value, options, token) = set key value options token

View File

@@ -0,0 +1,155 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open Npgsql.FSharp
/// PostgreSQL myWebLog category data implementation
type PostgresCategoryData(log: ILogger) =
/// Count all categories for the given web log
let countAll webLogId =
log.LogTrace "Category.countAll"
Count.byContains Table.Category (webLogDoc webLogId)
/// Count all top-level categories for the given web log
let countTopLevel webLogId =
log.LogTrace "Category.countTopLevel"
Custom.scalar
$"""{Query.Count.byContains Table.Category}
AND {Query.whereByField (Field.NEX (nameof Category.Empty.ParentId)) ""}"""
[ webLogContains webLogId ]
toCount
/// Retrieve all categories for the given web log in a DotLiquid-friendly format
let findAllForView webLogId = backgroundTask {
log.LogTrace "Category.findAllForView"
let! cats =
Custom.list
$"{selectWithCriteria Table.Category} ORDER BY LOWER(data ->> '{nameof Category.Empty.Name}')"
[ webLogContains webLogId ]
fromData<Category>
let ordered = Utils.orderByHierarchy cats None None []
let counts =
ordered
|> Seq.map (fun it ->
// Parent category post counts include posts in subcategories
let catIdSql, catIdParams =
ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map _.Id
|> Seq.append (Seq.singleton it.Id)
|> List.ofSeq
|> arrayContains (nameof Post.Empty.CategoryIds) id
let postCount =
Custom.scalar
$"""SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') AS it
FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"}
AND {catIdSql}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catIdParams ]
toCount
|> Async.AwaitTask
|> Async.RunSynchronously
it.Id, postCount)
|> List.ofSeq
return
ordered
|> Seq.map (fun cat ->
{ cat with
PostCount = counts
|> List.tryFind (fun c -> fst c = cat.Id)
|> Option.map snd
|> Option.defaultValue 0 })
|> Array.ofSeq
}
/// Find a category by its ID for the given web log
let findById catId webLogId =
log.LogTrace "Category.findById"
Document.findByIdAndWebLog<CategoryId, Category> Table.Category catId webLogId
/// Find all categories for the given web log
let findByWebLog webLogId =
log.LogTrace "Category.findByWebLog"
Document.findByWebLog<Category> Table.Category webLogId
/// Delete a category
let delete catId webLogId = backgroundTask {
log.LogTrace "Category.delete"
match! findById catId webLogId with
| Some cat ->
// Reassign any children to the category's parent category
let! children = Find.byContains<Category> Table.Category {| ParentId = catId |}
let hasChildren = not (List.isEmpty children)
if hasChildren then
let childQuery, childParams =
if cat.ParentId.IsSome then
Query.Patch.byId Table.Category,
children
|> List.map (fun child -> [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ])
else
Query.RemoveFields.byId Table.Category,
children
|> List.map (fun child ->
[ idParam child.Id; fieldNameParam [ nameof Category.Empty.ParentId ] ])
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync [ childQuery, childParams ]
()
// Delete the category off all posts where it is assigned
let! posts =
Custom.list
$"SELECT data FROM {Table.Post} WHERE data -> '{nameof Post.Empty.CategoryIds}' @> @id"
[ jsonParam "@id" [| string catId |] ]
fromData<Post>
if not (List.isEmpty posts) then
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
[ Query.Patch.byId Table.Post,
posts
|> List.map (fun post ->
[ idParam post.Id
jsonParam
"@data"
{| CategoryIds = post.CategoryIds |> List.filter (fun cat -> cat <> catId) |} ]) ]
()
// Delete the category itself
do! Delete.byId Table.Category catId
return if hasChildren then ReassignedChildCategories else CategoryDeleted
| None -> return CategoryNotFound
}
/// Save a category
let save (cat: Category) = backgroundTask {
log.LogTrace "Category.save"
do! save Table.Category cat
}
/// Restore categories from a backup
let restore cats = backgroundTask {
log.LogTrace "Category.restore"
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync [
Query.insert Table.Category, cats |> List.map (fun c -> [ jsonParam "@data" c ])
]
()
}
interface ICategoryData with
member _.Add cat = save cat
member _.CountAll webLogId = countAll webLogId
member _.CountTopLevel webLogId = countTopLevel webLogId
member _.FindAllForView webLogId = findAllForView webLogId
member _.FindById catId webLogId = findById catId webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.Delete catId webLogId = delete catId webLogId
member _.Restore cats = restore cats
member _.Update cat = save cat

View File

@@ -0,0 +1,223 @@
/// Helper functions for the PostgreSQL data implementation
[<AutoOpen>]
module MyWebLog.Data.Postgres.PostgresHelpers
/// The table names used in the PostgreSQL implementation
[<RequireQualifiedAccess>]
module Table =
/// Categories
[<Literal>]
let Category = "category"
/// Database Version
[<Literal>]
let DbVersion = "db_version"
/// Pages
[<Literal>]
let Page = "page"
/// Page Revisions
[<Literal>]
let PageRevision = "page_revision"
/// Posts
[<Literal>]
let Post = "post"
/// Post Comments
[<Literal>]
let PostComment = "post_comment"
/// Post Revisions
[<Literal>]
let PostRevision = "post_revision"
/// Tag/URL Mappings
[<Literal>]
let TagMap = "tag_map"
/// Themes
[<Literal>]
let Theme = "theme"
/// Theme Assets
[<Literal>]
let ThemeAsset = "theme_asset"
/// Uploads
[<Literal>]
let Upload = "upload"
/// Web Logs
[<Literal>]
let WebLog = "web_log"
/// Users
[<Literal>]
let WebLogUser = "web_log_user"
open System
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Postgres
open MyWebLog
open MyWebLog.Data
open NodaTime
open Npgsql
open Npgsql.FSharp
/// Create a SQL parameter for the web log ID
let webLogIdParam (webLogId: WebLogId) =
"@webLogId", Sql.string (string webLogId)
/// Create an anonymous record with the given web log ID
let webLogDoc (webLogId: WebLogId) =
{| WebLogId = webLogId |}
/// Create a parameter for a web log document-contains query
let webLogContains webLogId =
jsonParam "@criteria" (webLogDoc webLogId)
/// A SQL string to select data from a table with the given JSON document contains criteria
let selectWithCriteria tableName =
$"""{Query.selectFromTable tableName} WHERE {Query.whereDataContains "@criteria"}"""
/// Create the SQL and parameters for an IN clause
let inClause<'T> colNameAndPrefix paramName (items: 'T list) =
if List.isEmpty items then "", []
else
let mutable idx = 0
items
|> List.skip 1
|> List.fold (fun (itemS, itemP) it ->
idx <- idx + 1
$"{itemS}, @%s{paramName}{idx}", ($"@%s{paramName}{idx}", Sql.string (string it)) :: itemP)
(Seq.ofList items
|> Seq.map (fun it ->
$"%s{colNameAndPrefix} IN (@%s{paramName}0", [ $"@%s{paramName}0", Sql.string (string it) ])
|> Seq.head)
|> function sql, ps -> $"{sql})", ps
/// Create the SQL and parameters for match-any array query
let arrayContains<'T> name (valueFunc: 'T -> string) (items: 'T list) =
$"data['{name}'] ?| @{name}Values",
($"@{name}Values", Sql.stringArray (items |> List.map valueFunc |> Array.ofList))
/// Get the first result of the given query
let tryHead<'T> (query: Task<'T list>) = backgroundTask {
let! results = query
return List.tryHead results
}
/// Create a parameter for a non-standard type
let typedParam<'T> name (it: 'T) =
$"@%s{name}", Sql.parameter (NpgsqlParameter($"@{name}", it))
/// Create a parameter for a possibly-missing non-standard type
let optParam<'T> name (it: 'T option) =
let p = NpgsqlParameter($"@%s{name}", if Option.isSome it then box it.Value else DBNull.Value)
p.ParameterName, Sql.parameter p
/// Mapping functions for SQL queries
module Map =
/// Create a permalink from the current row
let toPermalink (row: RowReader) =
Permalink (row.string "permalink")
/// Create a revision from the current row
let toRevision (row: RowReader) : Revision =
{ AsOf = row.fieldValue<Instant> "as_of"
Text = row.string "revision_text" |> MarkupText.Parse }
/// Create a theme asset from the current row
let toThemeAsset includeData (row: RowReader) : ThemeAsset =
{ Id = ThemeAssetId (ThemeId (row.string "theme_id"), row.string "path")
UpdatedOn = row.fieldValue<Instant> "updated_on"
Data = if includeData then row.bytea "data" else [||] }
/// Create an uploaded file from the current row
let toUpload includeData (row: RowReader) : Upload =
{ Id = row.string "id" |> UploadId
WebLogId = row.string "web_log_id" |> WebLogId
Path = row.string "path" |> Permalink
UpdatedOn = row.fieldValue<Instant> "updated_on"
Data = if includeData then row.bytea "data" else [||] }
/// Document manipulation functions
module Document =
/// Determine whether a document exists with the given key for the given web log
let existsByWebLog<'TKey> table (key: 'TKey) webLogId =
Custom.scalar
$"""SELECT EXISTS (
SELECT 1 FROM %s{table} WHERE {Query.whereById "@id"} AND {Query.whereDataContains "@criteria"}
) AS it"""
[ "@id", Sql.string (string key); webLogContains webLogId ]
toExists
/// Find a document by its ID for the given web log
let findByIdAndWebLog<'TKey, 'TDoc> table (key: 'TKey) webLogId =
Custom.single
$"""{Query.selectFromTable table} WHERE {Query.whereById "@id"} AND {Query.whereDataContains "@criteria"}"""
[ "@id", Sql.string (string key); webLogContains webLogId ]
fromData<'TDoc>
/// Find documents for the given web log
let findByWebLog<'TDoc> table webLogId : Task<'TDoc list> =
Find.byContains table (webLogDoc webLogId)
/// Functions to support revisions
module Revisions =
/// Find all revisions for the given entity
let findByEntityId<'TKey> revTable entityTable (key: 'TKey) =
Custom.list
$"SELECT as_of, revision_text FROM %s{revTable} WHERE %s{entityTable}_id = @id ORDER BY as_of DESC"
[ "@id", Sql.string (string key) ]
Map.toRevision
/// Find all revisions for all posts for the given web log
let findByWebLog<'TKey> revTable entityTable (keyFunc: string -> 'TKey) webLogId =
Custom.list
$"""SELECT pr.*
FROM %s{revTable} pr
INNER JOIN %s{entityTable} p ON p.data ->> '{nameof Post.Empty.Id}' = pr.{entityTable}_id
WHERE p.{Query.whereDataContains "@criteria"}
ORDER BY as_of DESC"""
[ webLogContains webLogId ]
(fun row -> keyFunc (row.string $"{entityTable}_id"), Map.toRevision row)
/// Parameters for a revision INSERT statement
let revParams<'TKey> (key: 'TKey) rev = [
typedParam "asOf" rev.AsOf
"@id", Sql.string (string key)
"@text", Sql.string (string rev.Text)
]
/// The SQL statement to insert a revision
let insertSql table =
$"INSERT INTO %s{table} VALUES (@id, @asOf, @text)"
/// Update a page's revisions
let update<'TKey> revTable entityTable (key: 'TKey) oldRevs newRevs = backgroundTask {
let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs
if not (List.isEmpty toDelete) || not (List.isEmpty toAdd) then
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
[ if not (List.isEmpty toDelete) then
$"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf",
toDelete
|> List.map (fun it ->
[ "@id", Sql.string (string key)
typedParam "asOf" it.AsOf ])
if not (List.isEmpty toAdd) then
insertSql revTable, toAdd |> List.map (revParams key) ]
()
}

View File

@@ -0,0 +1,201 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open Npgsql.FSharp
/// PostgreSQL myWebLog page data implementation
type PostgresPageData(log: ILogger) =
// SUPPORT FUNCTIONS
/// Append revisions to a page
let appendPageRevisions (page: Page) = backgroundTask {
log.LogTrace "Page.appendPageRevisions"
let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id
return { page with Revisions = revisions }
}
/// Return a page with no text or revisions
let pageWithoutText (row: RowReader) =
{ fromData<Page> row with Text = "" }
/// Update a page's revisions
let updatePageRevisions (pageId: PageId) oldRevs newRevs =
log.LogTrace "Page.updatePageRevisions"
Revisions.update Table.PageRevision Table.Page pageId oldRevs newRevs
/// Does the given page exist?
let pageExists (pageId: PageId) webLogId =
log.LogTrace "Page.pageExists"
Document.existsByWebLog Table.Page pageId webLogId
// IMPLEMENTATION FUNCTIONS
/// Add a page
let add (page: Page) = backgroundTask {
log.LogTrace "Page.add"
do! insert Table.Page { page with Revisions = [] }
do! updatePageRevisions page.Id [] page.Revisions
()
}
/// Get all pages for a web log (without text, metadata, revisions, or prior permalinks)
let all webLogId =
log.LogTrace "Page.all"
Custom.list
$"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')"
[ webLogContains webLogId ]
(fun row -> { fromData<Page> row with Text = ""; Metadata = []; PriorPermalinks = [] })
/// Count all pages for the given web log
let countAll webLogId =
log.LogTrace "Page.countAll"
Count.byContains Table.Page (webLogDoc webLogId)
/// Count all pages shown in the page list for the given web log
let countListed webLogId =
log.LogTrace "Page.countListed"
Count.byContains Table.Page {| webLogDoc webLogId with IsInPageList = true |}
/// Find a page by its ID (without revisions or prior permalinks)
let findById pageId webLogId = backgroundTask {
log.LogTrace "Page.findById"
match! Document.findByIdAndWebLog<PageId, Page> Table.Page pageId webLogId with
| Some page -> return Some { page with PriorPermalinks = [] }
| None -> return None
}
/// Find a complete page by its ID
let findFullById pageId webLogId = backgroundTask {
log.LogTrace "Page.findFullById"
match! Document.findByIdAndWebLog<PageId, Page> Table.Page pageId webLogId with
| Some page ->
let! withMore = appendPageRevisions page
return Some withMore
| None -> return None
}
// TODO: need to handle when the page being deleted is the home page
/// Delete a page by its ID
let delete pageId webLogId = backgroundTask {
log.LogTrace "Page.delete"
match! pageExists pageId webLogId with
| true ->
do! Custom.nonQuery
$"""DELETE FROM {Table.PageRevision} WHERE page_id = @id;
DELETE FROM {Table.Page} WHERE {Query.whereById "@id"}"""
[ idParam pageId ]
return true
| false -> return false
}
/// Find a page by its permalink for the given web log
let findByPermalink (permalink: Permalink) webLogId = backgroundTask {
log.LogTrace "Page.findByPermalink"
let! page =
Find.byContains<Page> Table.Page {| webLogDoc webLogId with Permalink = permalink |}
|> tryHead
return page |> Option.map (fun pg -> { pg with PriorPermalinks = [] })
}
/// Find the current permalink within a set of potential prior permalinks for the given web log
let findCurrentPermalink (permalinks: Permalink list) webLogId = backgroundTask {
log.LogTrace "Page.findCurrentPermalink"
if List.isEmpty permalinks then return None
else
let linkSql, linkParam = arrayContains (nameof Page.Empty.PriorPermalinks) string permalinks
return!
Custom.single
$"""SELECT data ->> '{nameof Page.Empty.Permalink}' AS permalink
FROM page
WHERE {Query.whereDataContains "@criteria"}
AND {linkSql}"""
[ webLogContains webLogId; linkParam ]
Map.toPermalink
}
/// Get all complete pages for the given web log
let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Page.findFullByWebLog"
let! pages = Document.findByWebLog<Page> Table.Page webLogId
let! revisions = Revisions.findByWebLog Table.PageRevision Table.Page PageId webLogId
return
pages
|> List.map (fun it ->
{ it with Revisions = revisions |> List.filter (fun r -> fst r = it.Id) |> List.map snd })
}
/// Get all listed pages for the given web log (without revisions or text)
let findListed webLogId =
log.LogTrace "Page.findListed"
Custom.list
$"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')"
[ jsonParam "@criteria" {| webLogDoc webLogId with IsInPageList = true |} ]
pageWithoutText
/// Get a page of pages for the given web log (without revisions)
let findPageOfPages webLogId pageNbr =
log.LogTrace "Page.findPageOfPages"
Custom.list
$"{selectWithCriteria Table.Page}
ORDER BY LOWER(data->>'{nameof Page.Empty.Title}')
LIMIT @pageSize OFFSET @toSkip"
[ webLogContains webLogId; "@pageSize", Sql.int 26; "@toSkip", Sql.int ((pageNbr - 1) * 25) ]
(fun row -> { fromData<Page> row with Metadata = []; PriorPermalinks = [] })
/// Restore pages from a backup
let restore (pages: Page list) = backgroundTask {
log.LogTrace "Page.restore"
let revisions = pages |> List.collect (fun p -> p.Revisions |> List.map (fun r -> p.Id, r))
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
[ Query.insert Table.Page,
pages |> List.map (fun page -> [ jsonParam "@data" { page with Revisions = [] } ])
Revisions.insertSql Table.PageRevision,
revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId rev) ]
()
}
/// Update a page
let update (page: Page) = backgroundTask {
log.LogTrace "Page.update"
match! findFullById page.Id page.WebLogId with
| Some oldPage ->
do! Update.byId Table.Page page.Id { page with Revisions = [] }
do! updatePageRevisions page.Id oldPage.Revisions page.Revisions
| None -> ()
()
}
/// Update a page's prior permalinks
let updatePriorPermalinks pageId webLogId (permalinks: Permalink list) = backgroundTask {
log.LogTrace "Page.updatePriorPermalinks"
match! pageExists pageId webLogId with
| true ->
do! Patch.byId Table.Page pageId {| PriorPermalinks = permalinks |}
return true
| false -> return false
}
interface IPageData with
member _.Add page = add page
member _.All webLogId = all webLogId
member _.CountAll webLogId = countAll webLogId
member _.CountListed webLogId = countListed webLogId
member _.Delete pageId webLogId = delete pageId webLogId
member _.FindById pageId webLogId = findById pageId webLogId
member _.FindByPermalink permalink webLogId = findByPermalink permalink webLogId
member _.FindCurrentPermalink permalinks webLogId = findCurrentPermalink permalinks webLogId
member _.FindFullById pageId webLogId = findFullById pageId webLogId
member _.FindFullByWebLog webLogId = findFullByWebLog webLogId
member _.FindListed webLogId = findListed webLogId
member _.FindPageOfPages webLogId pageNbr = findPageOfPages webLogId pageNbr
member _.Restore pages = restore pages
member _.Update page = update page
member _.UpdatePriorPermalinks pageId webLogId permalinks = updatePriorPermalinks pageId webLogId permalinks

View File

@@ -0,0 +1,236 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open NodaTime
open Npgsql.FSharp
/// PostgreSQL myWebLog post data implementation
type PostgresPostData(log: ILogger) =
// SUPPORT FUNCTIONS
/// Append revisions to a post
let appendPostRevisions (post: Post) = backgroundTask {
log.LogTrace "Post.appendPostRevisions"
let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id
return { post with Revisions = revisions }
}
/// Return a post with no revisions or prior permalinks
let postWithoutLinks row =
{ fromData<Post> row with PriorPermalinks = [] }
/// Return a post with no revisions, prior permalinks, or text
let postWithoutText row =
{ postWithoutLinks row with Text = "" }
/// Update a post's revisions
let updatePostRevisions (postId: PostId) oldRevs newRevs =
log.LogTrace "Post.updatePostRevisions"
Revisions.update Table.PostRevision Table.Post postId oldRevs newRevs
/// Does the given post exist?
let postExists (postId: PostId) webLogId =
log.LogTrace "Post.postExists"
Document.existsByWebLog Table.Post postId webLogId
// IMPLEMENTATION FUNCTIONS
/// Add a post
let add (post : Post) = backgroundTask {
log.LogTrace "Post.add"
do! insert Table.Post { post with Revisions = [] }
do! updatePostRevisions post.Id [] post.Revisions
}
/// Count posts in a status for the given web log
let countByStatus (status: PostStatus) webLogId =
log.LogTrace "Post.countByStatus"
Count.byContains Table.Post {| webLogDoc webLogId with Status = status |}
/// Find a post by its ID for the given web log (excluding revisions)
let findById postId webLogId = backgroundTask {
log.LogTrace "Post.findById"
match! Document.findByIdAndWebLog<PostId, Post> Table.Post postId webLogId with
| Some post -> return Some { post with PriorPermalinks = [] }
| None -> return None
}
/// Find a post by its permalink for the given web log (excluding revisions)
let findByPermalink (permalink: Permalink) webLogId =
log.LogTrace "Post.findByPermalink"
Custom.single
(selectWithCriteria Table.Post)
[ jsonParam "@criteria" {| webLogDoc webLogId with Permalink = permalink |} ]
postWithoutLinks
/// Find a complete post by its ID for the given web log
let findFullById postId webLogId = backgroundTask {
log.LogTrace "Post.findFullById"
match! Document.findByIdAndWebLog<PostId, Post> Table.Post postId webLogId with
| Some post ->
let! withRevisions = appendPostRevisions post
return Some withRevisions
| None -> return None
}
/// Delete a post by its ID for the given web log
let delete postId webLogId = backgroundTask {
log.LogTrace "Post.delete"
match! postExists postId webLogId with
| true ->
do! Custom.nonQuery
$"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"};
DELETE FROM {Table.PostRevision} WHERE post_id = @id;
DELETE FROM {Table.Post} WHERE {Query.whereById "@id"}"""
[ idParam postId; jsonParam "@criteria" {| PostId = postId |} ]
return true
| false -> return false
}
/// Find the current permalink from a list of potential prior permalinks for the given web log
let findCurrentPermalink (permalinks: Permalink list) webLogId = backgroundTask {
log.LogTrace "Post.findCurrentPermalink"
if List.isEmpty permalinks then return None
else
let linkSql, linkParam = arrayContains (nameof Post.Empty.PriorPermalinks) string permalinks
return!
Custom.single
$"""SELECT data ->> '{nameof Post.Empty.Permalink}' AS permalink
FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"}
AND {linkSql}"""
[ webLogContains webLogId; linkParam ]
Map.toPermalink
}
/// Get all complete posts for the given web log
let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Post.findFullByWebLog"
let! posts = Document.findByWebLog<Post> Table.Post webLogId
let! revisions = Revisions.findByWebLog Table.PostRevision Table.Post PostId webLogId
return
posts
|> List.map (fun it ->
{ it with Revisions = revisions |> List.filter (fun r -> fst r = it.Id) |> List.map snd })
}
/// Get a page of categorized posts for the given web log (excludes revisions)
let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfCategorizedPosts"
let catSql, catParam = arrayContains (nameof Post.Empty.CategoryIds) string categoryIds
Custom.list
$"{selectWithCriteria Table.Post}
AND {catSql}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catParam ]
postWithoutLinks
/// Get a page of posts for the given web log (excludes text and revisions)
let findPageOfPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPosts"
Custom.list
$"{selectWithCriteria Table.Post}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC NULLS FIRST,
data ->> '{nameof Post.Empty.UpdatedOn}'
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ webLogContains webLogId ]
postWithoutText
/// Get a page of published posts for the given web log (excludes revisions)
let findPageOfPublishedPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPublishedPosts"
Custom.list
$"{selectWithCriteria Table.Post}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ]
postWithoutLinks
/// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks)
let findPageOfTaggedPosts webLogId (tag: string) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfTaggedPosts"
Custom.list
$"{selectWithCriteria Table.Post}
AND data['{nameof Post.Empty.Tags}'] @> @tag
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; jsonParam "@tag" [| tag |] ]
postWithoutLinks
/// Find the next newest and oldest post from a publish date for the given web log
let findSurroundingPosts webLogId (publishedOn: Instant) = backgroundTask {
log.LogTrace "Post.findSurroundingPosts"
let queryParams () =
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}
"@publishedOn", Sql.timestamptz (publishedOn.ToDateTimeOffset()) ]
let query op direction =
$"{selectWithCriteria Table.Post}
AND (data ->> '{nameof Post.Empty.PublishedOn}')::timestamp with time zone %s{op} @publishedOn
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' %s{direction}
LIMIT 1"
let! older = Custom.list (query "<" "DESC") (queryParams ()) postWithoutLinks
let! newer = Custom.list (query ">" "") (queryParams ()) postWithoutLinks
return List.tryHead older, List.tryHead newer
}
/// Update a post
let update (post : Post) = backgroundTask {
log.LogTrace "Post.save"
match! findFullById post.Id post.WebLogId with
| Some oldPost ->
do! Update.byId Table.Post post.Id { post with Revisions = [] }
do! updatePostRevisions post.Id oldPost.Revisions post.Revisions
| None -> ()
}
/// Restore posts from a backup
let restore posts = backgroundTask {
log.LogTrace "Post.restore"
let revisions = posts |> List.collect (fun p -> p.Revisions |> List.map (fun r -> p.Id, r))
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
[ Query.insert Table.Post,
posts |> List.map (fun post -> [ jsonParam "@data" { post with Revisions = [] } ])
Revisions.insertSql Table.PostRevision,
revisions |> List.map (fun (postId, rev) -> Revisions.revParams postId rev) ]
()
}
/// Update prior permalinks for a post
let updatePriorPermalinks postId webLogId (permalinks: Permalink list) = backgroundTask {
log.LogTrace "Post.updatePriorPermalinks"
match! postExists postId webLogId with
| true ->
do! Patch.byId Table.Post postId {| PriorPermalinks = permalinks |}
return true
| false -> return false
}
interface IPostData with
member _.Add post = add post
member _.CountByStatus status webLogId = countByStatus status webLogId
member _.Delete postId webLogId = delete postId webLogId
member _.FindById postId webLogId = findById postId webLogId
member _.FindByPermalink permalink webLogId = findByPermalink permalink webLogId
member _.FindCurrentPermalink permalinks webLogId = findCurrentPermalink permalinks webLogId
member _.FindFullById postId webLogId = findFullById postId webLogId
member _.FindFullByWebLog webLogId = findFullByWebLog webLogId
member _.FindPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage =
findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage
member _.FindPageOfPosts webLogId pageNbr postsPerPage = findPageOfPosts webLogId pageNbr postsPerPage
member _.FindPageOfPublishedPosts webLogId pageNbr postsPerPage =
findPageOfPublishedPosts webLogId pageNbr postsPerPage
member _.FindPageOfTaggedPosts webLogId tag pageNbr postsPerPage =
findPageOfTaggedPosts webLogId tag pageNbr postsPerPage
member _.FindSurroundingPosts webLogId publishedOn = findSurroundingPosts webLogId publishedOn
member _.Restore posts = restore posts
member _.Update post = update post
member _.UpdatePriorPermalinks postId webLogId permalinks = updatePriorPermalinks postId webLogId permalinks

View File

@@ -0,0 +1,73 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open Npgsql.FSharp
/// PostgreSQL myWebLog tag mapping data implementation
type PostgresTagMapData(log: ILogger) =
/// Find a tag mapping by its ID for the given web log
let findById tagMapId webLogId =
log.LogTrace "TagMap.findById"
Document.findByIdAndWebLog<TagMapId, TagMap> Table.TagMap tagMapId webLogId
/// Delete a tag mapping for the given web log
let delete (tagMapId: TagMapId) webLogId = backgroundTask {
log.LogTrace "TagMap.delete"
let! exists = Document.existsByWebLog Table.TagMap tagMapId webLogId
if exists then
do! Delete.byId Table.TagMap tagMapId
return true
else return false
}
/// Find a tag mapping by its URL value for the given web log
let findByUrlValue (urlValue: string) webLogId =
log.LogTrace "TagMap.findByUrlValue"
Find.firstByContains<TagMap> Table.TagMap {| webLogDoc webLogId with UrlValue = urlValue |}
/// Get all tag mappings for the given web log
let findByWebLog webLogId =
log.LogTrace "TagMap.findByWebLog"
Custom.list
$"{selectWithCriteria Table.TagMap} ORDER BY data ->> 'tag'"
[ webLogContains webLogId ]
fromData<TagMap>
/// Find any tag mappings in a list of tags for the given web log
let findMappingForTags tags webLogId =
log.LogTrace "TagMap.findMappingForTags"
let tagSql, tagParam = arrayContains (nameof TagMap.Empty.Tag) id tags
Custom.list
$"{selectWithCriteria Table.TagMap} AND {tagSql}"
[ webLogContains webLogId; tagParam ]
fromData<TagMap>
/// Save a tag mapping
let save (tagMap: TagMap) =
log.LogTrace "TagMap.save"
save Table.TagMap tagMap
/// Restore tag mappings from a backup
let restore (tagMaps: TagMap list) = backgroundTask {
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
[ Query.insert Table.TagMap,
tagMaps |> List.map (fun tagMap -> [ jsonParam "@data" tagMap ]) ]
()
}
interface ITagMapData with
member _.Delete tagMapId webLogId = delete tagMapId webLogId
member _.FindById tagMapId webLogId = findById tagMapId webLogId
member _.FindByUrlValue urlValue webLogId = findByUrlValue urlValue webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.FindMappingForTags tags webLogId = findMappingForTags tags webLogId
member _.Save tagMap = save tagMap
member _.Restore tagMaps = restore tagMaps

View File

@@ -0,0 +1,127 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
/// PostreSQL myWebLog theme data implementation
type PostgresThemeData(log: ILogger) =
/// Clear out the template text from a theme
let withoutTemplateText row =
let theme = fromData<Theme> row
{ theme with Templates = theme.Templates |> List.map (fun template -> { template with Text = "" }) }
/// Retrieve all themes (except 'admin'; excludes template text)
let all () =
log.LogTrace "Theme.all"
Custom.list
$"{Query.selectFromTable Table.Theme}
WHERE data ->> '{nameof Theme.Empty.Id}' <> 'admin'
ORDER BY data ->> '{nameof Theme.Empty.Id}'"
[]
withoutTemplateText
/// Does a given theme exist?
let exists (themeId: ThemeId) =
log.LogTrace "Theme.exists"
Exists.byId Table.Theme themeId
/// Find a theme by its ID
let findById (themeId: ThemeId) =
log.LogTrace "Theme.findById"
Find.byId<ThemeId, Theme> Table.Theme themeId
/// Find a theme by its ID (excludes the text of templates)
let findByIdWithoutText (themeId: ThemeId) =
log.LogTrace "Theme.findByIdWithoutText"
Custom.single (Query.Find.byId Table.Theme) [ idParam themeId ] withoutTemplateText
/// Delete a theme by its ID
let delete themeId = backgroundTask {
log.LogTrace "Theme.delete"
match! exists themeId with
| true ->
do! Custom.nonQuery
$"""DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id;
DELETE FROM {Table.Theme} WHERE {Query.whereById "@id"}"""
[ idParam themeId ]
return true
| false -> return false
}
/// Save a theme
let save (theme: Theme) =
log.LogTrace "Theme.save"
save Table.Theme theme
interface IThemeData with
member _.All() = all ()
member _.Delete themeId = delete themeId
member _.Exists themeId = exists themeId
member _.FindById themeId = findById themeId
member _.FindByIdWithoutText themeId = findByIdWithoutText themeId
member _.Save theme = save theme
/// PostreSQL myWebLog theme data implementation
type PostgresThemeAssetData(log: ILogger) =
/// Get all theme assets (excludes data)
let all () =
log.LogTrace "ThemeAsset.all"
Custom.list $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset}" [] (Map.toThemeAsset false)
/// Delete all assets for the given theme
let deleteByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.deleteByTheme"
Custom.nonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ]
/// Find a theme asset by its ID
let findById assetId =
log.LogTrace "ThemeAsset.findById"
let (ThemeAssetId (ThemeId themeId, path)) = assetId
Custom.single
$"SELECT * FROM {Table.ThemeAsset} WHERE theme_id = @id AND path = @path"
[ idParam themeId; "@path", Sql.string path ]
(Map.toThemeAsset true)
/// Get theme assets for the given theme (excludes data)
let findByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.findByTheme"
Custom.list
$"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @id"
[ idParam themeId ]
(Map.toThemeAsset false)
/// Get theme assets for the given theme
let findByThemeWithData (themeId: ThemeId) =
log.LogTrace "ThemeAsset.findByThemeWithData"
Custom.list $"SELECT * FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ] (Map.toThemeAsset true)
/// Save a theme asset
let save (asset: ThemeAsset) =
log.LogTrace "ThemeAsset.save"
let (ThemeAssetId (ThemeId themeId, path)) = asset.Id
Custom.nonQuery
$"INSERT INTO {Table.ThemeAsset} (
theme_id, path, updated_on, data
) VALUES (
@themeId, @path, @updatedOn, @data
) ON CONFLICT (theme_id, path) DO UPDATE
SET updated_on = EXCLUDED.updated_on,
data = EXCLUDED.data"
[ "@themeId", Sql.string themeId
"@path", Sql.string path
"@data", Sql.bytea asset.Data
typedParam "updatedOn" asset.UpdatedOn ]
interface IThemeAssetData with
member _.All() = all ()
member _.DeleteByTheme themeId = deleteByTheme themeId
member _.FindById assetId = findById assetId
member _.FindByTheme themeId = findByTheme themeId
member _.FindByThemeWithData themeId = findByThemeWithData themeId
member _.Save asset = save asset

View File

@@ -0,0 +1,90 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open Npgsql.FSharp
/// PostgreSQL myWebLog uploaded file data implementation
type PostgresUploadData(log: ILogger) =
/// The INSERT statement for an uploaded file
let upInsert = $"
INSERT INTO {Table.Upload} (
id, web_log_id, path, updated_on, data
) VALUES (
@id, @webLogId, @path, @updatedOn, @data
)"
/// Parameters for adding an uploaded file
let upParams (upload: Upload) =
[ webLogIdParam upload.WebLogId
typedParam "updatedOn" upload.UpdatedOn
idParam upload.Id
"@path", Sql.string (string upload.Path)
"@data", Sql.bytea upload.Data ]
/// Save an uploaded file
let add upload =
log.LogTrace "Upload.add"
Custom.nonQuery upInsert (upParams upload)
/// Delete an uploaded file by its ID
let delete uploadId webLogId = backgroundTask {
log.LogTrace "Upload.delete"
let idParam = [ idParam uploadId ]
let! path =
Custom.single
$"SELECT path FROM {Table.Upload} WHERE id = @id AND web_log_id = @webLogId"
(webLogIdParam webLogId :: idParam)
(fun row -> row.string "path")
if Option.isSome path then
do! Custom.nonQuery $"DELETE FROM {Table.Upload} WHERE id = @id" idParam
return Ok path.Value
else return Error $"Upload ID {uploadId} not found"
}
/// Find an uploaded file by its path for the given web log
let findByPath path webLogId =
log.LogTrace "Upload.findByPath"
Custom.single
$"SELECT * FROM {Table.Upload} WHERE web_log_id = @webLogId AND path = @path"
[ webLogIdParam webLogId; "@path", Sql.string path ]
(Map.toUpload true)
/// Find all uploaded files for the given web log (excludes data)
let findByWebLog webLogId =
log.LogTrace "Upload.findByWebLog"
Custom.list
$"SELECT id, web_log_id, path, updated_on FROM {Table.Upload} WHERE web_log_id = @webLogId"
[ webLogIdParam webLogId ]
(Map.toUpload false)
/// Find all uploaded files for the given web log
let findByWebLogWithData webLogId =
log.LogTrace "Upload.findByWebLogWithData"
Custom.list
$"SELECT * FROM {Table.Upload} WHERE web_log_id = @webLogId"
[ webLogIdParam webLogId ]
(Map.toUpload true)
/// Restore uploads from a backup
let restore uploads = backgroundTask {
log.LogTrace "Upload.restore"
for batch in uploads |> List.chunkBySize 5 do
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync [ upInsert, batch |> List.map upParams ]
()
}
interface IUploadData with
member _.Add upload = add upload
member _.Delete uploadId webLogId = delete uploadId webLogId
member _.FindByPath path webLogId = findByPath path webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.FindByWebLogWithData webLogId = findByWebLogWithData webLogId
member _.Restore uploads = restore uploads

View File

@@ -0,0 +1,83 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
/// PostgreSQL myWebLog web log data implementation
type PostgresWebLogData(log: ILogger) =
/// Add a web log
let add (webLog: WebLog) =
log.LogTrace "WebLog.add"
insert Table.WebLog webLog
/// Retrieve all web logs
let all () =
log.LogTrace "WebLog.all"
Find.all<WebLog> Table.WebLog
/// Delete a web log by its ID
let delete webLogId =
log.LogTrace "WebLog.delete"
Custom.nonQuery
$"""DELETE FROM {Table.PostComment}
WHERE data ->> '{nameof Comment.Empty.PostId}'
IN (SELECT data ->> '{nameof Post.Empty.Id}'
FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"});
DELETE FROM {Table.PostRevision}
WHERE post_id IN (SELECT data ->> 'Id' FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"});
DELETE FROM {Table.PageRevision}
WHERE page_id IN (SELECT data ->> 'Id' FROM {Table.Page} WHERE {Query.whereDataContains "@criteria"});
{Query.Delete.byContains Table.Post};
{Query.Delete.byContains Table.Page};
{Query.Delete.byContains Table.Category};
{Query.Delete.byContains Table.TagMap};
{Query.Delete.byContains Table.WebLogUser};
DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId;
DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}"""
[ webLogIdParam webLogId; webLogContains webLogId ]
/// Find a web log by its host (URL base)
let findByHost (url: string) =
log.LogTrace "WebLog.findByHost"
Find.firstByContains<WebLog> Table.WebLog {| UrlBase = url |}
/// Find a web log by its ID
let findById (webLogId: WebLogId) =
log.LogTrace "WebLog.findById"
Find.byId<WebLogId, WebLog> Table.WebLog webLogId
/// Update redirect rules for a web log
let updateRedirectRules (webLog: WebLog) = backgroundTask {
log.LogTrace "WebLog.updateRedirectRules"
match! findById webLog.Id with
| Some _ -> do! Patch.byId Table.WebLog webLog.Id {| RedirectRules = webLog.RedirectRules |}
| None -> ()
}
/// Update RSS options for a web log
let updateRssOptions (webLog: WebLog) = backgroundTask {
log.LogTrace "WebLog.updateRssOptions"
match! findById webLog.Id with
| Some _ -> do! Patch.byId Table.WebLog webLog.Id {| Rss = webLog.Rss |}
| None -> ()
}
/// Update settings for a web log
let updateSettings (webLog: WebLog) =
log.LogTrace "WebLog.updateSettings"
Update.byId Table.WebLog webLog.Id webLog
interface IWebLogData with
member _.Add webLog = add webLog
member _.All() = all ()
member _.Delete webLogId = delete webLogId
member _.FindByHost url = findByHost url
member _.FindById webLogId = findById webLogId
member _.UpdateRedirectRules webLog = updateRedirectRules webLog
member _.UpdateRssOptions webLog = updateRssOptions webLog
member _.UpdateSettings webLog = updateSettings webLog

View File

@@ -0,0 +1,102 @@
namespace MyWebLog.Data.Postgres
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open Npgsql.FSharp
/// PostgreSQL myWebLog user data implementation
type PostgresWebLogUserData(log: ILogger) =
/// Add a user
let add (user: WebLogUser) =
log.LogTrace "WebLogUser.add"
insert Table.WebLogUser user
/// Find a user by their ID for the given web log
let findById userId webLogId =
log.LogTrace "WebLogUser.findById"
Document.findByIdAndWebLog<WebLogUserId, WebLogUser> Table.WebLogUser userId webLogId
/// Delete a user if they have no posts or pages
let delete userId webLogId = backgroundTask {
log.LogTrace "WebLogUser.delete"
match! findById userId webLogId with
| Some _ ->
let criteria = Query.whereDataContains "@criteria"
let! isAuthor =
Custom.scalar
$" SELECT ( EXISTS (SELECT 1 FROM {Table.Page} WHERE {criteria})
OR EXISTS (SELECT 1 FROM {Table.Post} WHERE {criteria})
) AS it"
[ jsonParam "@criteria" {| AuthorId = userId |} ]
toExists
if isAuthor then
return Error "User has pages or posts; cannot delete"
else
do! Delete.byId Table.WebLogUser userId
return Ok true
| None -> return Error "User does not exist"
}
/// Find a user by their e-mail address for the given web log
let findByEmail (email: string) webLogId =
log.LogTrace "WebLogUser.findByEmail"
Find.firstByContains<WebLogUser> Table.WebLogUser {| webLogDoc webLogId with Email = email |}
/// Get all users for the given web log
let findByWebLog webLogId =
log.LogTrace "WebLogUser.findByWebLog"
Custom.list
$"{selectWithCriteria Table.WebLogUser} ORDER BY LOWER(data ->> '{nameof WebLogUser.Empty.PreferredName}')"
[ webLogContains webLogId ]
fromData<WebLogUser>
/// Find the names of users by their IDs for the given web log
let findNames webLogId (userIds: WebLogUserId list) = backgroundTask {
log.LogTrace "WebLogUser.findNames"
let idSql, idParams = inClause $"AND data ->> '{nameof WebLogUser.Empty.Id}'" "id" userIds
let! users =
Custom.list
$"{selectWithCriteria Table.WebLogUser} {idSql}"
(webLogContains webLogId :: idParams)
fromData<WebLogUser>
return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName })
}
/// Restore users from a backup
let restore (users: WebLogUser list) = backgroundTask {
log.LogTrace "WebLogUser.restore"
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
[ Query.insert Table.WebLogUser, users |> List.map (fun user -> [ jsonParam "@data" user ]) ]
()
}
/// Set a user's last seen date/time to now
let setLastSeen (userId: WebLogUserId) webLogId = backgroundTask {
log.LogTrace "WebLogUser.setLastSeen"
match! Document.existsByWebLog Table.WebLogUser userId webLogId with
| true -> do! Patch.byId Table.WebLogUser userId {| LastSeenOn = Some (Noda.now ()) |}
| false -> ()
}
/// Update a user
let update (user: WebLogUser) =
log.LogTrace "WebLogUser.update"
Update.byId Table.WebLogUser user.Id user
interface IWebLogUserData with
member _.Add user = add user
member _.Delete userId webLogId = delete userId webLogId
member _.FindByEmail email webLogId = findByEmail email webLogId
member _.FindById userId webLogId = findById userId webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.FindNames webLogId userIds = findNames webLogId userIds
member _.Restore users = restore users
member _.SetLastSeen userId webLogId = setLastSeen userId webLogId
member _.Update user = update user

View File

@@ -0,0 +1,269 @@
namespace MyWebLog.Data
open BitBadger.Documents
open BitBadger.Documents.Postgres
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data.Postgres
open Newtonsoft.Json
open Npgsql.FSharp
/// Data implementation for PostgreSQL
type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
/// Create any needed tables
let ensureTables () = backgroundTask {
// Set up the PostgreSQL document store
Configuration.useSerializer (Utils.createDocumentSerializer ser)
let! tables =
Custom.list
"SELECT tablename FROM pg_tables WHERE schemaname = 'public'" [] (fun row -> row.string "tablename")
let needsTable table = not (List.contains table tables)
let sql = seq {
// Theme tables
if needsTable Table.Theme then
Query.Definition.ensureTable Table.Theme
Query.Definition.ensureKey Table.Theme
if needsTable Table.ThemeAsset then
$"CREATE TABLE {Table.ThemeAsset} (
theme_id TEXT NOT NULL,
path TEXT NOT NULL,
updated_on TIMESTAMPTZ NOT NULL,
data BYTEA NOT NULL,
PRIMARY KEY (theme_id, path))"
// Web log table
if needsTable Table.WebLog then
Query.Definition.ensureTable Table.WebLog
Query.Definition.ensureKey Table.WebLog
Query.Definition.ensureDocumentIndex Table.WebLog Optimized
// Category table
if needsTable Table.Category then
Query.Definition.ensureTable Table.Category
Query.Definition.ensureKey Table.Category
Query.Definition.ensureDocumentIndex Table.Category Optimized
// Web log user table
if needsTable Table.WebLogUser then
Query.Definition.ensureTable Table.WebLogUser
Query.Definition.ensureKey Table.WebLogUser
Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized
// Page tables
if needsTable Table.Page then
Query.Definition.ensureTable Table.Page
Query.Definition.ensureKey Table.Page
Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ]
Query.Definition.ensureIndexOn
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]
if needsTable Table.PageRevision then
$"CREATE TABLE {Table.PageRevision} (
page_id TEXT NOT NULL,
as_of TIMESTAMPTZ NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))"
// Post tables
if needsTable Table.Post then
Query.Definition.ensureTable Table.Post
Query.Definition.ensureKey Table.Post
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ]
Query.Definition.ensureIndexOn
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]
Query.Definition.ensureIndexOn
Table.Post
"status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]
$"CREATE INDEX idx_post_category ON {Table.Post} USING GIN ((data['{nameof Post.Empty.CategoryIds}']))"
$"CREATE INDEX idx_post_tag ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))"
if needsTable Table.PostRevision then
$"CREATE TABLE {Table.PostRevision} (
post_id TEXT NOT NULL,
as_of TIMESTAMPTZ NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))"
if needsTable Table.PostComment then
Query.Definition.ensureTable Table.PostComment
Query.Definition.ensureKey Table.PostComment
Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ]
// Tag map table
if needsTable Table.TagMap then
Query.Definition.ensureTable Table.TagMap
Query.Definition.ensureKey Table.TagMap
Query.Definition.ensureDocumentIndex Table.TagMap Optimized
// Uploaded file table
if needsTable Table.Upload then
$"CREATE TABLE {Table.Upload} (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL,
path TEXT NOT NULL,
updated_on TIMESTAMPTZ NOT NULL,
data BYTEA NOT NULL)"
$"CREATE INDEX idx_upload_web_log ON {Table.Upload} (web_log_id)"
$"CREATE INDEX idx_upload_path ON {Table.Upload} (web_log_id, path)"
// Database version table
if needsTable Table.DbVersion then
$"CREATE TABLE {Table.DbVersion} (id TEXT NOT NULL PRIMARY KEY)"
$"INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')"
}
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
(sql
|> Seq.map (fun s ->
let parts = s.Replace(" IF NOT EXISTS", "", System.StringComparison.OrdinalIgnoreCase).Split ' '
if parts[1].ToLowerInvariant() = "table" then
log.LogInformation $"Creating {parts[2]} table..."
s, [ [] ])
|> List.ofSeq)
|> Async.AwaitTask
|> Async.RunSynchronously
|> ignore
}
/// Set a specific database version
let setDbVersion version = backgroundTask {
do! Custom.nonQuery $"DELETE FROM db_version; INSERT INTO db_version VALUES ('%s{version}')" []
return version
}
/// Migrate from v2-rc2 to v2 (manual migration required)
let migrateV2Rc2ToV2 () = backgroundTask {
let! webLogs =
Custom.list
$"SELECT url_base, slug FROM {Table.WebLog}" [] (fun row -> row.string "url_base", row.string "slug")
Utils.Migration.backupAndRestoreRequired log "v2-rc2" "v2" webLogs
}
/// Migrate from v2 to v2.1.1
let migrateV2ToV2point1point1 () = backgroundTask {
let migration = "v2 to v2.1.1"
Utils.Migration.logStep log migration "Adding empty redirect rule set to all weblogs"
do! Custom.nonQuery $"""UPDATE {Table.WebLog} SET data = data || '{{ "RedirectRules": [] }}'::jsonb""" []
let tables =
[ Table.Category; Table.Page; Table.Post; Table.PostComment; Table.TagMap; Table.Theme; Table.WebLog
Table.WebLogUser ]
Utils.Migration.logStep log migration "Adding unique indexes on ID fields"
do! Custom.nonQuery (tables |> List.map Query.Definition.ensureKey |> String.concat "; ") []
Utils.Migration.logStep log migration "Removing constraints"
let fkToDrop =
[ "page_revision", "page_revision_page_id_fkey"
"post_revision", "post_revision_post_id_fkey"
"theme_asset", "theme_asset_theme_id_fkey"
"upload", "upload_web_log_id_fkey"
"category", "category_pkey"
"page", "page_pkey"
"post", "post_pkey"
"post_comment", "post_comment_pkey"
"tag_map", "tag_map_pkey"
"theme", "theme_pkey"
"web_log", "web_log_pkey"
"web_log_user", "web_log_user_pkey" ]
do! Custom.nonQuery
(fkToDrop
|> List.map (fun (tbl, fk) -> $"ALTER TABLE {tbl} DROP CONSTRAINT {fk}")
|> String.concat "; ")
[]
Utils.Migration.logStep log migration "Dropping old indexes"
let toDrop =
[ "idx_category"; "page_author_idx"; "page_permalink_idx"; "page_web_log_idx"; "post_author_idx"
"post_category_idx"; "post_permalink_idx"; "post_status_idx"; "post_tag_idx"; "post_web_log_idx"
"post_comment_post_idx"; "idx_tag_map"; "idx_web_log"; "idx_web_log_user" ]
do! Custom.nonQuery (toDrop |> List.map (sprintf "DROP INDEX %s") |> String.concat "; ") []
Utils.Migration.logStep log migration "Dropping old ID columns"
do! Custom.nonQuery (tables |> List.map (sprintf "ALTER TABLE %s DROP COLUMN id") |> String.concat "; ") []
Utils.Migration.logStep log migration "Adding new indexes"
let newIdx =
[ yield! tables |> List.map Query.Definition.ensureKey
Query.Definition.ensureDocumentIndex Table.Category Optimized
Query.Definition.ensureDocumentIndex Table.TagMap Optimized
Query.Definition.ensureDocumentIndex Table.WebLog Optimized
Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized
Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ]
Query.Definition.ensureIndexOn
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ]
Query.Definition.ensureIndexOn
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]
Query.Definition.ensureIndexOn
Table.Post
"status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]
$"CREATE INDEX idx_post_category ON {Table.Post} USING GIN ((data['{nameof Post.Empty.CategoryIds}']))"
$"CREATE INDEX idx_post_tag ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))"
Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ] ]
do! Custom.nonQuery (newIdx |> String.concat "; ") []
Utils.Migration.logStep log migration "Setting database to version 2.1.1"
return! setDbVersion "v2.1.1"
}
/// Migrate from v2.1.1 to v2.2
let migrateV2point1point1ToV2point2 () = backgroundTask {
Utils.Migration.logStep log "v2.1.1 to v2.2" "Setting e-mail to lowercase"
do! Custom.nonQuery
$"""UPDATE {Table.WebLogUser} SET data = data || ('{{"Email":"' || lower(data->>'Email') || '"}}')::jsonb"""
[]
Utils.Migration.logStep log "v2.1.1 to v2.2" "Setting database version to v2.2"
return! setDbVersion "v2.2"
}
/// Do required data migration between versions
let migrate version = backgroundTask {
let mutable v = defaultArg version ""
if v = "v2-rc2" then
let! webLogs =
Custom.list
$"SELECT url_base, slug FROM {Table.WebLog}" []
(fun row -> row.string "url_base", row.string "slug")
Utils.Migration.backupAndRestoreRequired log "v2-rc2" "v2" webLogs
if v = "v2" then
let! ver = migrateV2ToV2point1point1 ()
v <- ver
if v = "v2.1.1" then
let! ver = migrateV2point1point1ToV2point2 ()
v <- ver
if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
let! _ = setDbVersion Utils.Migration.currentDbVersion
()
}
interface IData with
member _.Category = PostgresCategoryData log
member _.Page = PostgresPageData log
member _.Post = PostgresPostData log
member _.TagMap = PostgresTagMapData log
member _.Theme = PostgresThemeData log
member _.ThemeAsset = PostgresThemeAssetData log
member _.Upload = PostgresUploadData log
member _.WebLog = PostgresWebLogData log
member _.WebLogUser = PostgresWebLogUserData log
member _.Serializer = ser
member _.StartUp () = backgroundTask {
log.LogTrace "PostgresData.StartUp"
do! ensureTables ()
let! version = Custom.single "SELECT id FROM db_version" [] (fun row -> row.string "id")
do! migrate version
}

View File

@@ -5,7 +5,6 @@ open MyWebLog
open RethinkDb.Driver
/// Functions to assist with retrieving data
[<AutoOpen>]
module private RethinkHelpers =
/// Table names
@@ -18,6 +17,9 @@ module private RethinkHelpers =
/// The comment table
let Comment = "Comment"
/// The database version table
let DbVersion = "DbVersion"
/// The page table
let Page = "Page"
@@ -43,7 +45,7 @@ module private RethinkHelpers =
let WebLogUser = "WebLogUser"
/// A list of all tables
let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ]
let all = [ Category; Comment; DbVersion; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ]
/// Index names for indexes not on a data item's name
@@ -87,14 +89,19 @@ open System
open Microsoft.Extensions.Logging
open MyWebLog.ViewModels
open RethinkDb.Driver.FSharp
open RethinkHelpers
/// RethinkDB implementation of data functions for myWebLog
type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<RethinkDbData>) =
/// Match theme asset IDs by their prefix (the theme ID)
let matchAssetByThemeId themeId =
let keyPrefix = $"^{ThemeId.toString themeId}/"
fun (row : Ast.ReqlExpr) -> row[nameof ThemeAsset.empty.Id].Match keyPrefix :> obj
let keyPrefix = $"^{themeId}/"
fun (row: Ast.ReqlExpr) -> row[nameof ThemeAsset.Empty.Id].Match keyPrefix :> obj
/// Function to exclude template text from themes
let withoutTemplateText (row: Ast.ReqlExpr) : obj =
{| Templates = row[nameof Theme.Empty.Templates].Merge(r.HashMap(nameof ThemeTemplate.Empty.Text, "")) |}
/// Ensure field indexes exist, as well as special indexes for selected tables
let ensureIndexes table fields = backgroundTask {
@@ -105,27 +112,27 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink { withTable table; indexCreate field; write; withRetryOnce; ignoreResult conn }
// Post and page need index by web log ID and permalink
if [ Table.Page; Table.Post ] |> List.contains table then
let permalinkIdx = nameof Page.empty.Permalink
let permalinkIdx = nameof Page.Empty.Permalink
if not (indexes |> List.contains permalinkIdx) then
log.LogInformation $"Creating index {table}.{permalinkIdx}..."
do! rethink {
withTable table
indexCreate permalinkIdx
(fun row -> r.Array (row[nameof Page.empty.WebLogId], row[permalinkIdx].Downcase ()) :> obj)
(fun row -> r.Array(row[nameof Page.Empty.WebLogId], row[permalinkIdx].Downcase()) :> obj)
write; withRetryOnce; ignoreResult conn
}
// Prior permalinks are searched when a post or page permalink do not match the current URL
let priorIdx = nameof Post.empty.PriorPermalinks
let priorIdx = nameof Post.Empty.PriorPermalinks
if not (indexes |> List.contains priorIdx) then
log.LogInformation $"Creating index {table}.{priorIdx}..."
do! rethink {
withTable table
indexCreate priorIdx (fun row -> row[priorIdx].Downcase () :> obj) [ Multi ]
indexCreate priorIdx [ Multi ]
write; withRetryOnce; ignoreResult conn
}
// Post needs indexes by category and tag (used for counting and retrieving posts)
if Table.Post = table then
for idx in [ nameof Post.empty.CategoryIds; nameof Post.empty.Tags ] do
for idx in [ nameof Post.Empty.CategoryIds; nameof Post.Empty.Tags ] do
if not (List.contains idx indexes) then
log.LogInformation $"Creating index {table}.{idx}..."
do! rethink {
@@ -140,7 +147,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink {
withTable table
indexCreate Index.WebLogAndTag (fun row ->
[| row[nameof TagMap.empty.WebLogId]; row[nameof TagMap.empty.Tag] |] :> obj)
[| row[nameof TagMap.Empty.WebLogId]; row[nameof TagMap.Empty.Tag] |] :> obj)
write; withRetryOnce; ignoreResult conn
}
if not (indexes |> List.contains Index.WebLogAndUrl) then
@@ -148,7 +155,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink {
withTable table
indexCreate Index.WebLogAndUrl (fun row ->
[| row[nameof TagMap.empty.WebLogId]; row[nameof TagMap.empty.UrlValue] |] :> obj)
[| row[nameof TagMap.Empty.WebLogId]; row[nameof TagMap.Empty.UrlValue] |] :> obj)
write; withRetryOnce; ignoreResult conn
}
// Uploaded files need an index by web log ID and path, as that is how they are retrieved
@@ -158,7 +165,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink {
withTable table
indexCreate Index.WebLogAndPath (fun row ->
[| row[nameof Upload.empty.WebLogId]; row[nameof Upload.empty.Path] |] :> obj)
[| row[nameof Upload.Empty.WebLogId]; row[nameof Upload.Empty.Path] |] :> obj)
write; withRetryOnce; ignoreResult conn
}
// Users log on with e-mail
@@ -168,14 +175,116 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink {
withTable table
indexCreate Index.LogOn (fun row ->
[| row[nameof WebLogUser.empty.WebLogId]; row[nameof WebLogUser.empty.Email] |] :> obj)
[| row[nameof WebLogUser.Empty.WebLogId]; row[nameof WebLogUser.Empty.Email] |] :> obj)
write; withRetryOnce; ignoreResult conn
}
do! rethink { withTable table; indexWait; result; withRetryDefault; ignoreResult conn }
}
/// The batch size for restoration methods
let restoreBatchSize = 100
/// A value to use when files need to be retrieved without their data
let emptyFile = r.Binary(Array.Empty<byte>())
/// Delete assets for the given theme ID
let deleteAssetsByTheme themeId = rethink {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
delete
write; withRetryDefault; ignoreResult conn
}
/// Set a specific database version
let setDbVersion (version: string) = backgroundTask {
do! rethink {
withTable Table.DbVersion
delete
write; withRetryOnce; ignoreResult conn
}
do! rethink {
withTable Table.DbVersion
insert {| Id = version |}
write; withRetryOnce; ignoreResult conn
}
}
/// Migrate from v2-rc1 to v2-rc2
let migrateV2Rc1ToV2Rc2 () = backgroundTask {
let logStep = Utils.Migration.logStep log "v2-rc1 to v2-rc2"
logStep "**IMPORTANT**"
logStep "See release notes about required backup/restoration for RethinkDB."
logStep "If there is an error immediately below this message, this is why."
logStep "Setting database version to v2-rc2"
do! setDbVersion "v2-rc2"
}
/// Migrate from v2-rc2 to v2
let migrateV2Rc2ToV2 () = backgroundTask {
Utils.Migration.logStep log "v2-rc2 to v2" "Setting database version; no migration required"
do! setDbVersion "v2"
}
/// Migrate from v2 to v2.1
let migrateV2ToV2point1 () = backgroundTask {
Utils.Migration.logStep log "v2 to v2.1" "Adding empty redirect rule set to all weblogs"
do! rethink {
withTable Table.WebLog
update [ nameof WebLog.Empty.RedirectRules, [] :> obj ]
write; withRetryOnce; ignoreResult conn
}
Utils.Migration.logStep log "v2 to v2.1" "Setting database version to v2.1"
do! setDbVersion "v2.1"
}
/// Migrate from v2.1 to v2.1.1
let migrateV2point1ToV2point1point1 () = backgroundTask {
Utils.Migration.logStep log "v2.1 to v2.1.1" "Setting database version; no migration required"
do! setDbVersion "v2.1.1"
}
/// Migrate from v2.1.1 to v2.2
let migrateV2point1point1ToV2point2 () = backgroundTask {
Utils.Migration.logStep log "v2.1.1 to v2.2" "Setting e-mail to lowercase"
do! rethink {
withTable Table.WebLogUser
update (fun row -> {| Email = row[nameof WebLogUser.Empty.Email].Downcase() |})
write; withRetryOnce; ignoreResult conn
}
Utils.Migration.logStep log "v2.1.1 to v2.2" "Setting database version to v2.2"
do! setDbVersion "v2.2"
}
/// Migrate data between versions
let migrate version = backgroundTask {
let mutable v = defaultArg version ""
if v = "v2-rc1" then
do! migrateV2Rc1ToV2Rc2 ()
v <- "v2-rc2"
if v = "v2-rc2" then
do! migrateV2Rc2ToV2 ()
v <- "v2"
if v = "v2" then
do! migrateV2ToV2point1 ()
v <- "v2.1"
if v = "v2.1" then
do! migrateV2point1ToV2point1point1 ()
v <- "v2.1.1"
if v = "v2.1.1" then
do! migrateV2point1point1ToV2point2 ()
v <- "v2.2"
if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
do! setDbVersion Utils.Migration.currentDbVersion
}
/// The connection for this instance
member _.Conn = conn
@@ -192,15 +301,15 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.CountAll webLogId = rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof Category.empty.WebLogId)
getAll [ webLogId ] (nameof Category.Empty.WebLogId)
count
result; withRetryDefault conn
}
member _.CountTopLevel webLogId = rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof Category.empty.WebLogId)
filter (nameof Category.empty.ParentId) None
getAll [ webLogId ] (nameof Category.Empty.WebLogId)
filter (nameof Category.Empty.ParentId) None (Default FilterDefaultHandling.Return)
count
result; withRetryDefault conn
}
@@ -208,8 +317,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindAllForView webLogId = backgroundTask {
let! cats = rethink<Category list> {
withTable Table.Category
getAll [ webLogId ] (nameof Category.empty.WebLogId)
orderByFunc (fun it -> it[nameof Category.empty.Name].Downcase () :> obj)
getAll [ webLogId ] (nameof Category.Empty.WebLogId)
orderByFunc (fun it -> it[nameof Category.Empty.Name].Downcase() :> obj)
result; withRetryDefault conn
}
let ordered = Utils.orderByHierarchy cats None None []
@@ -225,8 +334,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
|> List.ofSeq
let! count = rethink<int> {
withTable Table.Post
getAll catIds (nameof Post.empty.CategoryIds)
filter (nameof Post.empty.Status) Published
getAll catIds (nameof Post.Empty.CategoryIds)
filter (nameof Post.Empty.Status) Published
distinct
count
result; withRetryDefault conn
@@ -241,8 +350,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
PostCount = counts
|> Array.tryFind (fun c -> fst c = cat.Id)
|> Option.map snd
|> Option.defaultValue 0
})
|> Option.defaultValue 0 })
|> Array.ofSeq
}
@@ -252,24 +360,40 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get catId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun c -> c.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindByWebLog webLogId = rethink<Category list> {
withTable Table.Category
getAll [ webLogId ] (nameof Category.empty.WebLogId)
getAll [ webLogId ] (nameof Category.Empty.WebLogId)
result; withRetryDefault conn
}
member this.Delete catId webLogId = backgroundTask {
match! this.FindById catId webLogId with
| Some _ ->
| Some cat ->
// Reassign any children to the category's parent category
let! children = rethink<int> {
withTable Table.Category
filter (nameof Category.Empty.ParentId) catId
count
result; withRetryDefault conn
}
if children > 0 then
do! rethink {
withTable Table.Category
filter (nameof Category.Empty.ParentId) catId
update [ nameof Category.Empty.ParentId, cat.ParentId :> obj ]
write; withRetryDefault; ignoreResult conn
}
// Delete the category off all posts where it is assigned
do! rethink {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
filter (fun row -> row[nameof Post.empty.CategoryIds].Contains catId :> obj)
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
filter (fun row -> row[nameof Post.Empty.CategoryIds].Contains catId :> obj)
update (fun row ->
{| CategoryIds = r.Array(row[nameof Post.empty.CategoryIds]).Remove catId |} :> obj)
{| CategoryIds =
row[nameof Post.Empty.CategoryIds].CoerceTo("array")
.SetDifference(r.Array(catId)) |} :> obj)
write; withRetryDefault; ignoreResult conn
}
// Delete the category itself
@@ -279,8 +403,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
delete
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
return if children = 0 then CategoryDeleted else ReassignedChildCategories
| None -> return CategoryNotFound
}
member _.Restore cats = backgroundTask {
@@ -315,26 +439,26 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.All webLogId = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
without [ nameof Page.empty.Text
nameof Page.empty.Metadata
nameof Page.empty.Revisions
nameof Page.empty.PriorPermalinks ]
orderByFunc (fun row -> row[nameof Page.empty.Title].Downcase () :> obj)
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
merge (r.HashMap(nameof Page.Empty.Text, "")
.With(nameof Page.Empty.Metadata, [||])
.With(nameof Page.Empty.Revisions, [||])
.With(nameof Page.Empty.PriorPermalinks, [||]))
orderByFunc (fun row -> row[nameof Page.Empty.Title].Downcase() :> obj)
result; withRetryDefault conn
}
member _.CountAll webLogId = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
count
result; withRetryDefault conn
}
member _.CountListed webLogId = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
filter (nameof Page.empty.IsInPageList) true
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
filter (nameof Page.Empty.IsInPageList) true
count
result; withRetryDefault conn
}
@@ -343,7 +467,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
let! result = rethink<Model.Result> {
withTable Table.Page
getAll [ pageId ]
filter (fun row -> row[nameof Page.empty.WebLogId].Eq webLogId :> obj)
filter (fun row -> row[nameof Page.Empty.WebLogId].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
@@ -351,19 +475,22 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
}
member _.FindById pageId webLogId =
rethink<Page> {
rethink<Page list> {
withTable Table.Page
get pageId
without [ nameof Page.empty.PriorPermalinks; nameof Page.empty.Revisions ]
resultOption; withRetryOptionDefault
getAll [ pageId ]
filter (nameof Page.Empty.WebLogId) webLogId
merge (r.HashMap(nameof Page.Empty.PriorPermalinks, [||])
.With(nameof Page.Empty.Revisions, [||]))
result; withRetryDefault
}
|> verifyWebLog webLogId (fun it -> it.WebLogId) <| conn
|> tryFirst <| conn
member _.FindByPermalink permalink webLogId =
rethink<Page list> {
withTable Table.Page
getAll [ [| webLogId :> obj; permalink |] ] (nameof Page.empty.Permalink)
without [ nameof Page.empty.PriorPermalinks; nameof Page.empty.Revisions ]
getAll [ [| webLogId :> obj; permalink |] ] (nameof Page.Empty.Permalink)
merge (r.HashMap(nameof Page.Empty.PriorPermalinks, [||])
.With(nameof Page.Empty.Revisions, [||]))
limit 1
result; withRetryDefault
}
@@ -373,14 +500,14 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
let! result =
(rethink<Page list> {
withTable Table.Page
getAll (objList permalinks) (nameof Page.empty.PriorPermalinks)
filter (nameof Page.empty.WebLogId) webLogId
without [ nameof Page.empty.Revisions; nameof Page.empty.Text ]
getAll (objList permalinks) (nameof Page.Empty.PriorPermalinks)
filter (nameof Page.Empty.WebLogId) webLogId
without [ nameof Page.Empty.Revisions; nameof Page.Empty.Text ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun pg -> pg.Permalink)
return result |> Option.map _.Permalink
}
member _.FindFullById pageId webLogId =
@@ -389,30 +516,32 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get pageId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun it -> it.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindFullByWebLog webLogId = rethink<Page> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.FindListed webLogId = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
filter [ nameof Page.empty.IsInPageList, true :> obj ]
without [ nameof Page.empty.Text; nameof Page.empty.PriorPermalinks; nameof Page.empty.Revisions ]
orderBy (nameof Page.empty.Title)
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
filter [ nameof Page.Empty.IsInPageList, true :> obj ]
merge (r.HashMap(nameof Page.Empty.Text, "")
.With(nameof Page.Empty.PriorPermalinks, [||])
.With(nameof Page.Empty.Revisions, [||]))
orderBy (nameof Page.Empty.Title)
result; withRetryDefault conn
}
member _.FindPageOfPages webLogId pageNbr = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
without [ nameof Page.empty.Metadata
nameof Page.empty.PriorPermalinks
nameof Page.empty.Revisions ]
orderByFunc (fun row -> row[nameof Page.empty.Title].Downcase ())
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
merge (r.HashMap(nameof Page.Empty.Metadata, [||])
.With(nameof Page.Empty.PriorPermalinks, [||])
.With(nameof Page.Empty.Revisions, [||]))
orderByFunc (fun row -> row[nameof Page.Empty.Title].Downcase())
skip ((pageNbr - 1) * 25)
limit 25
result; withRetryDefault conn
@@ -450,7 +579,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink {
withTable Table.Page
get pageId
update [ nameof Page.empty.PriorPermalinks, permalinks :> obj ]
update [ nameof Page.Empty.PriorPermalinks, permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
@@ -469,8 +598,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.CountByStatus status webLogId = rethink<int> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
filter (nameof Post.empty.Status) status
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
filter (nameof Post.Empty.Status) status
count
result; withRetryDefault conn
}
@@ -479,7 +608,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
let! result = rethink<Model.Result> {
withTable Table.Post
getAll [ postId ]
filter (fun row -> row[nameof Post.empty.WebLogId].Eq webLogId :> obj)
filter (fun row -> row[nameof Post.Empty.WebLogId].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
@@ -487,19 +616,22 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
}
member _.FindById postId webLogId =
rethink<Post> {
rethink<Post list> {
withTable Table.Post
get postId
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
resultOption; withRetryOptionDefault
getAll [ postId ]
filter (nameof Post.Empty.WebLogId) webLogId
merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
result; withRetryDefault
}
|> verifyWebLog webLogId (fun p -> p.WebLogId) <| conn
|> tryFirst <| conn
member _.FindByPermalink permalink webLogId =
rethink<Post list> {
withTable Table.Post
getAll [ [| webLogId :> obj; permalink |] ] (nameof Post.empty.Permalink)
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
getAll [ [| webLogId :> obj; permalink |] ] (nameof Post.Empty.Permalink)
merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
limit 1
result; withRetryDefault
}
@@ -511,36 +643,37 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get postId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
(rethink<Post list> {
withTable Table.Post
getAll (objList permalinks) (nameof Post.empty.PriorPermalinks)
filter (nameof Post.empty.WebLogId) webLogId
without [ nameof Post.empty.Revisions; nameof Post.empty.Text ]
getAll (objList permalinks) (nameof Post.Empty.PriorPermalinks)
filter (nameof Post.Empty.WebLogId) webLogId
without [ nameof Post.Empty.Revisions; nameof Post.Empty.Text ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun post -> post.Permalink)
return result |> Option.map _.Permalink
}
member _.FindFullByWebLog webLogId = rethink<Post> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.FindPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll (objList categoryIds) (nameof Post.empty.CategoryIds)
filter [ nameof Post.empty.WebLogId, webLogId :> obj
nameof Post.empty.Status, Published ]
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
getAll (objList categoryIds) (nameof Post.Empty.CategoryIds)
filter [ nameof Post.Empty.WebLogId, webLogId :> obj
nameof Post.Empty.Status, Published ]
merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
distinct
orderByDescending (nameof Post.empty.PublishedOn)
orderByDescending (nameof Post.Empty.PublishedOn)
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
@@ -548,10 +681,12 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindPageOfPosts webLogId pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
merge (r.HashMap(nameof Post.Empty.Text, "")
.With(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
orderByFuncDescending (fun row ->
row[nameof Post.empty.PublishedOn].Default_ (nameof Post.empty.UpdatedOn) :> obj)
row[nameof Post.Empty.PublishedOn].Default_(nameof Post.Empty.UpdatedOn) :> obj)
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
@@ -559,10 +694,11 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindPageOfPublishedPosts webLogId pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
filter (nameof Post.empty.Status) Published
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
orderByDescending (nameof Post.empty.PublishedOn)
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
filter (nameof Post.Empty.Status) Published
merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
orderByDescending (nameof Post.Empty.PublishedOn)
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
@@ -570,11 +706,12 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindPageOfTaggedPosts webLogId tag pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ tag ] (nameof Post.empty.Tags)
filter [ nameof Post.empty.WebLogId, webLogId :> obj
nameof Post.empty.Status, Published ]
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
orderByDescending (nameof Post.empty.PublishedOn)
getAll [ tag ] (nameof Post.Empty.Tags)
filter [ nameof Post.Empty.WebLogId, webLogId :> obj
nameof Post.Empty.Status, Published ]
merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
orderByDescending (nameof Post.Empty.PublishedOn)
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
@@ -584,10 +721,11 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
let! older =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
filter (fun row -> row[nameof Post.empty.PublishedOn].Lt publishedOn :> obj)
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
orderByDescending (nameof Post.empty.PublishedOn)
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
filter (fun row -> row[nameof Post.Empty.PublishedOn].Lt publishedOn :> obj)
merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
orderByDescending (nameof Post.Empty.PublishedOn)
limit 1
result; withRetryDefault
}
@@ -595,10 +733,11 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
let! newer =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
filter (fun row -> row[nameof Post.empty.PublishedOn].Gt publishedOn :> obj)
without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ]
orderBy (nameof Post.empty.PublishedOn)
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
filter (fun row -> row[nameof Post.Empty.PublishedOn].Gt publishedOn :> obj)
merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||])
.With(nameof Post.Empty.Revisions, [||]))
orderBy (nameof Post.Empty.PublishedOn)
limit 1
result; withRetryDefault
}
@@ -615,27 +754,25 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
}
}
member _.Update post = rethink {
member this.Update post = backgroundTask {
match! this.FindById post.Id post.WebLogId with
| Some _ ->
do! rethink {
withTable Table.Post
get post.Id
replace post
write; withRetryDefault; ignoreResult conn
}
member _.UpdatePriorPermalinks postId webLogId permalinks = backgroundTask {
match! (
rethink<Post> {
withTable Table.Post
get postId
without [ nameof Post.empty.Revisions; nameof Post.empty.PriorPermalinks ]
resultOption; withRetryOptionDefault
| None -> ()
}
|> verifyWebLog webLogId (fun p -> p.WebLogId)) conn with
member this.UpdatePriorPermalinks postId webLogId permalinks = backgroundTask {
match! this.FindById postId webLogId with
| Some _ ->
do! rethink {
withTable Table.Post
get postId
update [ nameof Post.empty.PriorPermalinks, permalinks :> obj ]
update [ nameof Post.Empty.PriorPermalinks, permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
@@ -650,7 +787,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
let! result = rethink<Model.Result> {
withTable Table.TagMap
getAll [ tagMapId ]
filter (fun row -> row[nameof TagMap.empty.WebLogId].Eq webLogId :> obj)
filter (fun row -> row[nameof TagMap.Empty.WebLogId].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
@@ -663,7 +800,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get tagMapId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun tm -> tm.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindByUrlValue urlValue webLogId =
rethink<TagMap list> {
@@ -678,7 +815,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
withTable Table.TagMap
between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |]
[ Index Index.WebLogAndTag ]
orderBy (nameof TagMap.empty.Tag)
orderBy (nameof TagMap.Empty.Tag)
result; withRetryDefault conn
}
@@ -710,25 +847,49 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.All () = rethink<Theme list> {
withTable Table.Theme
filter (fun row -> row[nameof Theme.empty.Id].Ne "admin" :> obj)
without [ nameof Theme.empty.Templates ]
orderBy (nameof Theme.empty.Id)
filter (fun row -> row[nameof Theme.Empty.Id].Ne "admin" :> obj)
merge withoutTemplateText
orderBy (nameof Theme.Empty.Id)
result; withRetryDefault conn
}
member _.Exists themeId = backgroundTask {
let! count = rethink<int> {
withTable Table.Theme
filter (nameof Theme.Empty.Id) themeId
count
result; withRetryDefault conn
}
return count > 0
}
member _.FindById themeId = rethink<Theme> {
withTable Table.Theme
get themeId
resultOption; withRetryOptionDefault conn
}
member _.FindByIdWithoutText themeId = rethink<Theme> {
member _.FindByIdWithoutText themeId =
rethink<Theme list> {
withTable Table.Theme
getAll [ themeId ]
merge withoutTemplateText
result; withRetryDefault
}
|> tryFirst <| conn
member this.Delete themeId = backgroundTask {
match! this.FindByIdWithoutText themeId with
| Some _ ->
do! deleteAssetsByTheme themeId
do! rethink {
withTable Table.Theme
get themeId
merge (fun row ->
{| Templates = row[nameof Theme.empty.Templates].Without [| nameof ThemeTemplate.empty.Text |]
|})
resultOption; withRetryOptionDefault conn
delete
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
member _.Save theme = rethink {
@@ -744,16 +905,11 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.All () = rethink<ThemeAsset list> {
withTable Table.ThemeAsset
without [ nameof ThemeAsset.empty.Data ]
merge (r.HashMap(nameof ThemeAsset.Empty.Data, emptyFile))
result; withRetryDefault conn
}
member _.DeleteByTheme themeId = rethink {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
delete
write; withRetryDefault; ignoreResult conn
}
member _.DeleteByTheme themeId = deleteAssetsByTheme themeId
member _.FindById assetId = rethink<ThemeAsset> {
withTable Table.ThemeAsset
@@ -764,7 +920,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindByTheme themeId = rethink<ThemeAsset list> {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
without [ nameof ThemeAsset.empty.Data ]
merge (r.HashMap(nameof ThemeAsset.Empty.Data, emptyFile))
result; withRetryDefault conn
}
@@ -798,7 +954,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get uploadId
resultOption; withRetryOptionDefault
}
|> verifyWebLog<Upload> webLogId (fun u -> u.WebLogId) <| conn
|> verifyWebLog<Upload> webLogId _.WebLogId <| conn
match upload with
| Some up ->
do! rethink {
@@ -807,8 +963,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
delete
write; withRetryDefault; ignoreResult conn
}
return Ok (Permalink.toString up.Path)
| None -> return Result.Error $"Upload ID {UploadId.toString uploadId} not found"
return Ok (string up.Path)
| None -> return Result.Error $"Upload ID {uploadId} not found"
}
member _.FindByPath path webLogId =
@@ -823,7 +979,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
withTable Table.Upload
between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |]
[ Index Index.WebLogAndPath ]
without [ nameof Upload.empty.Data ]
merge (r.HashMap(nameof Upload.Empty.Data, emptyFile))
resultCursor; withRetryCursorDefault; toList conn
}
@@ -838,7 +994,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
// Files can be large; we'll do 5 at a time
for batch in uploads |> List.chunkBySize 5 do
do! rethink {
withTable Table.TagMap
withTable Table.Upload
insert batch
write; withRetryOnce; ignoreResult conn
}
@@ -863,15 +1019,15 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
// Comments should be deleted by post IDs
let! thePostIds = rethink<{| Id: string |} list> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
pluck [ nameof Post.empty.Id ]
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
pluck [ nameof Post.Empty.Id ]
result; withRetryOnce conn
}
if not (List.isEmpty thePostIds) then
let postIds = thePostIds |> List.map (fun it -> it.Id :> obj)
do! rethink {
withTable Table.Comment
getAll postIds (nameof Comment.empty.PostId)
getAll postIds (nameof Comment.Empty.PostId)
delete
write; withRetryOnce; ignoreResult conn
}
@@ -894,7 +1050,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
for table in [ Table.Post; Table.Category; Table.Page; Table.WebLogUser ] do
do! rethink {
withTable table
getAll [ webLogId ] (nameof Post.empty.WebLogId)
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
delete
write; withRetryOnce; ignoreResult conn
}
@@ -909,7 +1065,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindByHost url =
rethink<WebLog list> {
withTable Table.WebLog
getAll [ url ] (nameof WebLog.empty.UrlBase)
getAll [ url ] (nameof WebLog.Empty.UrlBase)
limit 1
result; withRetryDefault
}
@@ -921,10 +1077,17 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
resultOption; withRetryOptionDefault conn
}
member _.UpdateRedirectRules webLog = rethink {
withTable Table.WebLog
get webLog.Id
update [ nameof WebLog.Empty.RedirectRules, webLog.RedirectRules :> obj ]
write; withRetryDefault; ignoreResult conn
}
member _.UpdateRssOptions webLog = rethink {
withTable Table.WebLog
get webLog.Id
update [ nameof WebLog.empty.Rss, webLog.Rss :> obj ]
update [ nameof WebLog.Empty.Rss, webLog.Rss :> obj ]
write; withRetryDefault; ignoreResult conn
}
@@ -961,22 +1124,22 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get userId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun u -> u.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member this.Delete userId webLogId = backgroundTask {
match! this.FindById userId webLogId with
| Some _ ->
let! pageCount = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
filter (nameof Page.empty.AuthorId) userId
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
filter (nameof Page.Empty.AuthorId) userId
count
result; withRetryDefault conn
}
let! postCount = rethink<int> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
filter (nameof Post.empty.AuthorId) userId
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
filter (nameof Post.Empty.AuthorId) userId
count
result; withRetryDefault conn
}
@@ -1004,8 +1167,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindByWebLog webLogId = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll [ webLogId ] (nameof WebLogUser.empty.WebLogId)
orderByFunc (fun row -> row[nameof WebLogUser.empty.PreferredName].Downcase ())
getAll [ webLogId ] (nameof WebLogUser.Empty.WebLogId)
orderByFunc (fun row -> row[nameof WebLogUser.Empty.PreferredName].Downcase())
result; withRetryDefault conn
}
@@ -1013,12 +1176,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
let! users = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll (objList userIds)
filter (nameof WebLogUser.empty.WebLogId) webLogId
filter (nameof WebLogUser.Empty.WebLogId) webLogId
result; withRetryDefault conn
}
return
users
|> List.map (fun u -> { Name = WebLogUserId.toString u.Id; Value = WebLogUser.displayName u })
return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName })
}
member _.Restore users = backgroundTask {
@@ -1036,7 +1197,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink {
withTable Table.WebLogUser
get userId
update [ nameof WebLogUser.empty.LastSeenOn, DateTime.UtcNow :> obj ]
update [ nameof WebLogUser.Empty.LastSeenOn, Noda.now () :> obj ]
write; withRetryOnce; ignoreResult conn
}
| None -> ()
@@ -1051,7 +1212,6 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
nameof user.LastName, user.LastName
nameof user.PreferredName, user.PreferredName
nameof user.PasswordHash, user.PasswordHash
nameof user.Salt, user.Salt
nameof user.Url, user.Url
nameof user.AccessLevel, user.AccessLevel
]
@@ -1059,6 +1219,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
}
}
member _.Serializer =
Net.Converter.Serializer
member _.StartUp () = backgroundTask {
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
if not (dbs |> List.contains config.Database) then
@@ -1071,12 +1234,27 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
log.LogInformation $"Creating table {tbl}..."
do! rethink { tableCreate tbl [ PrimaryKey "Id" ]; write; withRetryOnce; ignoreResult conn }
do! ensureIndexes Table.Category [ nameof Category.empty.WebLogId ]
do! ensureIndexes Table.Comment [ nameof Comment.empty.PostId ]
do! ensureIndexes Table.Page [ nameof Page.empty.WebLogId; nameof Page.empty.AuthorId ]
do! ensureIndexes Table.Post [ nameof Post.empty.WebLogId; nameof Post.empty.AuthorId ]
if not (List.contains Table.DbVersion tables) then
// Version table added in v2-rc2; this will flag that migration to be run
do! rethink {
withTable Table.DbVersion
insert {| Id = "v2-rc1" |}
write; withRetryOnce; ignoreResult conn
}
do! ensureIndexes Table.Category [ nameof Category.Empty.WebLogId ]
do! ensureIndexes Table.Comment [ nameof Comment.Empty.PostId ]
do! ensureIndexes Table.Page [ nameof Page.Empty.WebLogId; nameof Page.Empty.AuthorId ]
do! ensureIndexes Table.Post [ nameof Post.Empty.WebLogId; nameof Post.Empty.AuthorId ]
do! ensureIndexes Table.TagMap []
do! ensureIndexes Table.Upload []
do! ensureIndexes Table.WebLog [ nameof WebLog.empty.UrlBase ]
do! ensureIndexes Table.WebLogUser [ nameof WebLogUser.empty.WebLogId ]
do! ensureIndexes Table.WebLog [ nameof WebLog.Empty.UrlBase ]
do! ensureIndexes Table.WebLogUser [ nameof WebLogUser.Empty.WebLogId ]
let! version = rethink<{| Id: string |} list> {
withTable Table.DbVersion
limit 1
result; withRetryOnce conn
}
do! migrate (List.tryHead version |> Option.map _.Id)
}

View File

@@ -1,312 +0,0 @@
/// Helper functions for the SQLite data implementation
[<AutoOpen>]
module MyWebLog.Data.SQLite.Helpers
open System
open Microsoft.Data.Sqlite
open MyWebLog
/// Run a command that returns a count
let count (cmd : SqliteCommand) = backgroundTask {
let! it = cmd.ExecuteScalarAsync ()
return int (it :?> int64)
}
/// Get lists of items removed from and added to the given lists
let diffLists<'T, 'U when 'U : equality> oldItems newItems (f : 'T -> 'U) =
let diff compList = fun item -> not (compList |> List.exists (fun other -> f item = f other))
List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems
/// Find meta items added and removed
let diffMetaItems (oldItems : MetaItem list) newItems =
diffLists oldItems newItems (fun item -> $"{item.Name}|{item.Value}")
/// Find the permalinks added and removed
let diffPermalinks oldLinks newLinks =
diffLists oldLinks newLinks Permalink.toString
/// Find the revisions added and removed
let diffRevisions oldRevs newRevs =
diffLists oldRevs newRevs (fun (rev : Revision) -> $"{rev.AsOf.Ticks}|{MarkupText.toString rev.Text}")
/// Create a list of items from the given data reader
let toList<'T> (it : SqliteDataReader -> 'T) (rdr : SqliteDataReader) =
seq { while rdr.Read () do it rdr }
|> List.ofSeq
/// Verify that the web log ID matches before returning an item
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (it : SqliteDataReader -> 'T) (rdr : SqliteDataReader) =
if rdr.Read () then
let item = it rdr
if prop item = webLogId then Some item else None
else None
/// Execute a command that returns no data
let write (cmd : SqliteCommand) = backgroundTask {
let! _ = cmd.ExecuteNonQueryAsync ()
()
}
/// Functions to map domain items from a data reader
module Map =
open System.IO
/// Get a boolean value from a data reader
let getBoolean col (rdr : SqliteDataReader) = rdr.GetBoolean (rdr.GetOrdinal col)
/// Get a date/time value from a data reader
let getDateTime col (rdr : SqliteDataReader) = rdr.GetDateTime (rdr.GetOrdinal col)
/// Get a Guid value from a data reader
let getGuid col (rdr : SqliteDataReader) = rdr.GetGuid (rdr.GetOrdinal col)
/// Get an int value from a data reader
let getInt col (rdr : SqliteDataReader) = rdr.GetInt32 (rdr.GetOrdinal col)
/// Get a long (64-bit int) value from a data reader
let getLong col (rdr : SqliteDataReader) = rdr.GetInt64 (rdr.GetOrdinal col)
/// Get a BLOB stream value from a data reader
let getStream col (rdr : SqliteDataReader) = rdr.GetStream (rdr.GetOrdinal col)
/// Get a string value from a data reader
let getString col (rdr : SqliteDataReader) = rdr.GetString (rdr.GetOrdinal col)
/// Get a timespan value from a data reader
let getTimeSpan col (rdr : SqliteDataReader) = rdr.GetTimeSpan (rdr.GetOrdinal col)
/// Get a possibly null boolean value from a data reader
let tryBoolean col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getBoolean col rdr)
/// Get a possibly null date/time value from a data reader
let tryDateTime col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getDateTime col rdr)
/// Get a possibly null Guid value from a data reader
let tryGuid col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getGuid col rdr)
/// Get a possibly null int value from a data reader
let tryInt col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getInt col rdr)
/// Get a possibly null string value from a data reader
let tryString col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getString col rdr)
/// Get a possibly null timespan value from a data reader
let tryTimeSpan col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getTimeSpan col rdr)
/// Map an id field to a category ID
let toCategoryId rdr = getString "id" rdr |> CategoryId
/// Create a category from the current row in the given data reader
let toCategory rdr : Category =
{ Id = toCategoryId rdr
WebLogId = getString "web_log_id" rdr |> WebLogId
Name = getString "name" rdr
Slug = getString "slug" rdr
Description = tryString "description" rdr
ParentId = tryString "parent_id" rdr |> Option.map CategoryId
}
/// Create a custom feed from the current row in the given data reader
let toCustomFeed rdr : CustomFeed =
{ Id = getString "id" rdr |> CustomFeedId
Source = getString "source" rdr |> CustomFeedSource.parse
Path = getString "path" rdr |> Permalink
Podcast =
if rdr.IsDBNull (rdr.GetOrdinal "title") then
None
else
Some {
Title = getString "title" rdr
Subtitle = tryString "subtitle" rdr
ItemsInFeed = getInt "items_in_feed" rdr
Summary = getString "summary" rdr
DisplayedAuthor = getString "displayed_author" rdr
Email = getString "email" rdr
ImageUrl = getString "image_url" rdr |> Permalink
AppleCategory = getString "apple_category" rdr
AppleSubcategory = tryString "apple_subcategory" rdr
Explicit = getString "explicit" rdr |> ExplicitRating.parse
DefaultMediaType = tryString "default_media_type" rdr
MediaBaseUrl = tryString "media_base_url" rdr
PodcastGuid = tryGuid "podcast_guid" rdr
FundingUrl = tryString "funding_url" rdr
FundingText = tryString "funding_text" rdr
Medium = tryString "medium" rdr |> Option.map PodcastMedium.parse
}
}
/// Create a meta item from the current row in the given data reader
let toMetaItem rdr : MetaItem =
{ Name = getString "name" rdr
Value = getString "value" rdr
}
/// Create a permalink from the current row in the given data reader
let toPermalink rdr = getString "permalink" rdr |> Permalink
/// Create a page from the current row in the given data reader
let toPage rdr : Page =
{ Page.empty with
Id = getString "id" rdr |> PageId
WebLogId = getString "web_log_id" rdr |> WebLogId
AuthorId = getString "author_id" rdr |> WebLogUserId
Title = getString "title" rdr
Permalink = toPermalink rdr
PublishedOn = getDateTime "published_on" rdr
UpdatedOn = getDateTime "updated_on" rdr
IsInPageList = getBoolean "is_in_page_list" rdr
Template = tryString "template" rdr
Text = getString "page_text" rdr
}
/// Create a post from the current row in the given data reader
let toPost rdr : Post =
{ Post.empty with
Id = getString "id" rdr |> PostId
WebLogId = getString "web_log_id" rdr |> WebLogId
AuthorId = getString "author_id" rdr |> WebLogUserId
Status = getString "status" rdr |> PostStatus.parse
Title = getString "title" rdr
Permalink = toPermalink rdr
PublishedOn = tryDateTime "published_on" rdr
UpdatedOn = getDateTime "updated_on" rdr
Template = tryString "template" rdr
Text = getString "post_text" rdr
Episode =
match tryString "media" rdr with
| Some media ->
Some {
Media = media
Length = getLong "length" rdr
Duration = tryTimeSpan "duration" rdr
MediaType = tryString "media_type" rdr
ImageUrl = tryString "image_url" rdr
Subtitle = tryString "subtitle" rdr
Explicit = tryString "explicit" rdr |> Option.map ExplicitRating.parse
ChapterFile = tryString "chapter_file" rdr
ChapterType = tryString "chapter_type" rdr
TranscriptUrl = tryString "transcript_url" rdr
TranscriptType = tryString "transcript_type" rdr
TranscriptLang = tryString "transcript_lang" rdr
TranscriptCaptions = tryBoolean "transcript_captions" rdr
SeasonNumber = tryInt "season_number" rdr
SeasonDescription = tryString "season_description" rdr
EpisodeNumber = tryString "episode_number" rdr |> Option.map Double.Parse
EpisodeDescription = tryString "episode_description" rdr
}
| None -> None
}
/// Create a revision from the current row in the given data reader
let toRevision rdr : Revision =
{ AsOf = getDateTime "as_of" rdr
Text = getString "revision_text" rdr |> MarkupText.parse
}
/// Create a tag mapping from the current row in the given data reader
let toTagMap rdr : TagMap =
{ Id = getString "id" rdr |> TagMapId
WebLogId = getString "web_log_id" rdr |> WebLogId
Tag = getString "tag" rdr
UrlValue = getString "url_value" rdr
}
/// Create a theme from the current row in the given data reader (excludes templates)
let toTheme rdr : Theme =
{ Theme.empty with
Id = getString "id" rdr |> ThemeId
Name = getString "name" rdr
Version = getString "version" rdr
}
/// Create a theme asset from the current row in the given data reader
let toThemeAsset includeData rdr : ThemeAsset =
let assetData =
if includeData then
use dataStream = new MemoryStream ()
use blobStream = getStream "data" rdr
blobStream.CopyTo dataStream
dataStream.ToArray ()
else
[||]
{ Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr)
UpdatedOn = getDateTime "updated_on" rdr
Data = assetData
}
/// Create a theme template from the current row in the given data reader
let toThemeTemplate rdr : ThemeTemplate =
{ Name = getString "name" rdr
Text = getString "template" rdr
}
/// Create an uploaded file from the current row in the given data reader
let toUpload includeData rdr : Upload =
let data =
if includeData then
use dataStream = new MemoryStream ()
use blobStream = getStream "data" rdr
blobStream.CopyTo dataStream
dataStream.ToArray ()
else
[||]
{ Id = getString "id" rdr |> UploadId
WebLogId = getString "web_log_id" rdr |> WebLogId
Path = getString "path" rdr |> Permalink
UpdatedOn = getDateTime "updated_on" rdr
Data = data
}
/// Create a web log from the current row in the given data reader
let toWebLog rdr : WebLog =
{ Id = getString "id" rdr |> WebLogId
Name = getString "name" rdr
Slug = getString "slug" rdr
Subtitle = tryString "subtitle" rdr
DefaultPage = getString "default_page" rdr
PostsPerPage = getInt "posts_per_page" rdr
ThemeId = getString "theme_id" rdr |> ThemeId
UrlBase = getString "url_base" rdr
TimeZone = getString "time_zone" rdr
AutoHtmx = getBoolean "auto_htmx" rdr
Uploads = getString "uploads" rdr |> UploadDestination.parse
Rss = {
IsFeedEnabled = getBoolean "is_feed_enabled" rdr
FeedName = getString "feed_name" rdr
ItemsInFeed = tryInt "items_in_feed" rdr
IsCategoryEnabled = getBoolean "is_category_enabled" rdr
IsTagEnabled = getBoolean "is_tag_enabled" rdr
Copyright = tryString "copyright" rdr
CustomFeeds = []
}
}
/// Create a web log user from the current row in the given data reader
let toWebLogUser rdr : WebLogUser =
{ Id = getString "id" rdr |> WebLogUserId
WebLogId = getString "web_log_id" rdr |> WebLogId
Email = getString "email" rdr
FirstName = getString "first_name" rdr
LastName = getString "last_name" rdr
PreferredName = getString "preferred_name" rdr
PasswordHash = getString "password_hash" rdr
Salt = getGuid "salt" rdr
Url = tryString "url" rdr
AccessLevel = getString "access_level" rdr |> AccessLevel.parse
CreatedOn = getDateTime "created_on" rdr
LastSeenOn = tryDateTime "last_seen_on" rdr
}
/// Add a possibly-missing parameter, substituting null for None
let maybe<'T> (it : 'T option) : obj = match it with Some x -> x :> obj | None -> DBNull.Value
/// Add a web log ID parameter
let addWebLogId (cmd : SqliteCommand) webLogId =
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore

View File

@@ -1,169 +1,124 @@
namespace MyWebLog.Data.SQLite
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
/// SQLite myWebLog category data implementation
type SQLiteCategoryData (conn : SqliteConnection) =
type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) =
/// Add parameters for category INSERT or UPDATE statements
let addCategoryParameters (cmd : SqliteCommand) (cat : Category) =
[ cmd.Parameters.AddWithValue ("@id", CategoryId.toString cat.Id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString cat.WebLogId)
cmd.Parameters.AddWithValue ("@name", cat.Name)
cmd.Parameters.AddWithValue ("@slug", cat.Slug)
cmd.Parameters.AddWithValue ("@description", maybe cat.Description)
cmd.Parameters.AddWithValue ("@parentId", maybe (cat.ParentId |> Option.map CategoryId.toString))
] |> ignore
/// Add a category
let add cat = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO category (
id, web_log_id, name, slug, description, parent_id
) VALUES (
@id, @webLogId, @name, @slug, @description, @parentId
)"""
addCategoryParameters cmd cat
let! _ = cmd.ExecuteNonQueryAsync ()
()
}
/// The name of the parent ID field
let parentIdField = nameof Category.Empty.ParentId
/// Count all categories for the given web log
let countAll webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(id) FROM category WHERE web_log_id = @webLogId"
addWebLogId cmd webLogId
return! count cmd
}
let countAll webLogId =
log.LogTrace "Category.countAll"
Document.countByWebLog Table.Category webLogId conn
/// Count all top-level categories for the given web log
let countTopLevel webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <-
"SELECT COUNT(id) FROM category WHERE web_log_id = @webLogId AND parent_id IS NULL"
addWebLogId cmd webLogId
return! count cmd
}
let countTopLevel webLogId =
log.LogTrace "Category.countTopLevel"
conn.customScalar
$"{Document.Query.countByWebLog Table.Category} AND data ->> '{parentIdField}' IS NULL"
[ webLogParam webLogId ]
(toCount >> int)
/// Find all categories for the given web log
let findByWebLog webLogId =
log.LogTrace "Category.findByWebLog"
Document.findByWebLog<Category> Table.Category webLogId conn
/// Retrieve all categories for the given web log in a DotLiquid-friendly format
let findAllForView webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM category WHERE web_log_id = @webLogId"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
let cats =
seq {
while rdr.Read () do
Map.toCategory rdr
}
|> Seq.sortBy (fun cat -> cat.Name.ToLowerInvariant ())
|> List.ofSeq
do! rdr.CloseAsync ()
let ordered = Utils.orderByHierarchy cats None None []
log.LogTrace "Category.findAllForView"
let! cats = findByWebLog webLogId
let ordered = Utils.orderByHierarchy (cats |> List.sortBy _.Name.ToLowerInvariant()) None None []
let! counts =
ordered
|> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories
cmd.Parameters.Clear ()
addWebLogId cmd webLogId
cmd.CommandText <- """
SELECT COUNT(DISTINCT p.id)
FROM post p
INNER JOIN post_category pc ON pc.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = 'Published'
AND pc.category_id IN ("""
let catSql, catParams =
ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map (fun cat -> cat.Id)
|> Seq.map _.Id
|> Seq.append (Seq.singleton it.Id)
|> Seq.iteri (fun idx item ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@catId{idx}"
cmd.Parameters.AddWithValue ($"@catId{idx}", item) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
let! postCount = count cmd
return it.Id, postCount
|> List.ofSeq
|> inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId"
let query = $"""
SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}')
FROM {Table.Post}
WHERE {Document.Query.whereByWebLog}
AND {Query.whereByField (Field.EQ (nameof Post.Empty.Status) "") $"'{string Published}'"}
AND {catSql}"""
let! postCount = conn.customScalar query (webLogParam webLogId :: catParams) toCount
return it.Id, int postCount
})
|> Task.WhenAll
return
ordered
|> Seq.map (fun cat ->
{ cat with
PostCount = counts
|> Array.tryFind (fun c -> fst c = cat.Id)
|> Option.map snd
|> Option.defaultValue 0
PostCount = defaultArg (counts |> Array.tryFind (fun c -> fst c = cat.Id) |> Option.map snd) 0
})
|> Array.ofSeq
}
/// Find a category by its ID for the given web log
let findById catId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM category WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return Helpers.verifyWebLog<Category> webLogId (fun c -> c.WebLogId) Map.toCategory rdr
}
/// Find all categories for the given web log
let findByWebLog webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM category WHERE web_log_id = @webLogId"
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toCategory rdr
}
/// Find a category by its ID for the given web log
let findById catId webLogId =
log.LogTrace "Category.findById"
Document.findByIdAndWebLog<CategoryId, Category> Table.Category catId webLogId conn
/// Delete a category
let delete catId webLogId = backgroundTask {
log.LogTrace "Category.delete"
match! findById catId webLogId with
| Some _ ->
use cmd = conn.CreateCommand ()
// Delete the category off all posts where it is assigned
cmd.CommandText <- """
DELETE FROM post_category
WHERE category_id = @id
AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId)"""
let catIdParameter = cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore
do! write cmd
// Delete the category itself
cmd.CommandText <- "DELETE FROM category WHERE id = @id"
cmd.Parameters.Clear ()
cmd.Parameters.Add catIdParameter |> ignore
do! write cmd
return true
| None -> return false
| Some cat ->
// Reassign any children to the category's parent category
let! children = conn.countByField Table.Category (Field.EQ parentIdField (string catId))
if children > 0L then
let parent = Field.EQ parentIdField (string catId)
match cat.ParentId with
| Some _ -> do! conn.patchByField Table.Category parent {| ParentId = cat.ParentId |}
| None -> do! conn.removeFieldsByField Table.Category parent [ parentIdField ]
// Delete the category off all posts where it is assigned, and the category itself
let catIdField = nameof Post.Empty.CategoryIds
let! posts =
conn.customList
$"SELECT data ->> '{nameof Post.Empty.Id}', data -> '{catIdField}'
FROM {Table.Post}
WHERE {Document.Query.whereByWebLog}
AND EXISTS
(SELECT 1
FROM json_each({Table.Post}.data -> '{catIdField}')
WHERE json_each.value = @id)"
[ idParam catId; webLogParam webLogId ]
(fun rdr -> rdr.GetString 0, Utils.deserialize<string list> ser (rdr.GetString 1))
for postId, cats in posts do
do! conn.patchById
Table.Post postId {| CategoryIds = cats |> List.filter (fun it -> it <> string catId) |}
do! conn.deleteById Table.Category catId
return if children = 0L then CategoryDeleted else ReassignedChildCategories
| None -> return CategoryNotFound
}
/// Save a category
let save cat =
log.LogTrace "Category.save"
conn.save<Category> Table.Category cat
/// Restore categories from a backup
let restore cats = backgroundTask {
for cat in cats do
do! add cat
}
/// Update a category
let update cat = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE category
SET name = @name,
slug = @slug,
description = @description,
parent_id = @parentId
WHERE id = @id
AND web_log_id = @webLogId"""
addCategoryParameters cmd cat
do! write cmd
log.LogTrace "Category.restore"
for cat in cats do do! save cat
}
interface ICategoryData with
member _.Add cat = add cat
member _.Add cat = save cat
member _.CountAll webLogId = countAll webLogId
member _.CountTopLevel webLogId = countTopLevel webLogId
member _.FindAllForView webLogId = findAllForView webLogId
@@ -171,4 +126,4 @@ type SQLiteCategoryData (conn : SqliteConnection) =
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.Delete catId webLogId = delete catId webLogId
member _.Restore cats = restore cats
member _.Update cat = update cat
member _.Update cat = save cat

View File

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

View File

@@ -1,349 +1,171 @@
namespace MyWebLog.Data.SQLite
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
/// SQLite myWebLog page data implementation
type SQLitePageData (conn : SqliteConnection) =
type SQLitePageData(conn: SqliteConnection, log: ILogger) =
/// The JSON field name for the permalink
let linkName = nameof Page.Empty.Permalink
/// The JSON field name for the "is in page list" flag
let pgListName = nameof Page.Empty.IsInPageList
/// The JSON field for the title of the page
let titleField = $"data ->> '{nameof Page.Empty.Title}'"
// SUPPORT FUNCTIONS
/// Add parameters for page INSERT or UPDATE statements
let addPageParameters (cmd : SqliteCommand) (page : Page) =
[ cmd.Parameters.AddWithValue ("@id", PageId.toString page.Id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString page.WebLogId)
cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString page.AuthorId)
cmd.Parameters.AddWithValue ("@title", page.Title)
cmd.Parameters.AddWithValue ("@permalink", Permalink.toString page.Permalink)
cmd.Parameters.AddWithValue ("@publishedOn", page.PublishedOn)
cmd.Parameters.AddWithValue ("@updatedOn", page.UpdatedOn)
cmd.Parameters.AddWithValue ("@isInPageList", page.IsInPageList)
cmd.Parameters.AddWithValue ("@template", maybe page.Template)
cmd.Parameters.AddWithValue ("@text", page.Text)
] |> ignore
/// Append meta items to a page
let appendPageMeta (page : Page) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT name, value FROM page_meta WHERE page_id = @id"
cmd.Parameters.AddWithValue ("@id", PageId.toString page.Id) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return { page with Metadata = toList Map.toMetaItem rdr }
/// Append revisions to a page
let appendPageRevisions (page : Page) = backgroundTask {
log.LogTrace "Page.appendPageRevisions"
let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id conn
return { page with Revisions = revisions }
}
/// Append revisions and permalinks to a page
let appendPageRevisionsAndPermalinks (page : Page) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@pageId", PageId.toString page.Id) |> ignore
cmd.CommandText <- "SELECT permalink FROM page_permalink WHERE page_id = @pageId"
use! rdr = cmd.ExecuteReaderAsync ()
let page = { page with PriorPermalinks = toList Map.toPermalink rdr }
do! rdr.CloseAsync ()
cmd.CommandText <- "SELECT as_of, revision_text FROM page_revision WHERE page_id = @pageId ORDER BY as_of DESC"
use! rdr = cmd.ExecuteReaderAsync ()
return { page with Revisions = toList Map.toRevision rdr }
}
/// Return a page with no text (or meta items, prior permalinks, or revisions)
let pageWithoutTextOrMeta rdr =
{ Map.toPage rdr with Text = "" }
/// Update a page's metadata items
let updatePageMeta pageId oldItems newItems = backgroundTask {
let toDelete, toAdd = diffMetaItems oldItems newItems
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId)
cmd.Parameters.Add ("@name", SqliteType.Text)
cmd.Parameters.Add ("@value", SqliteType.Text)
] |> ignore
let runCmd (item : MetaItem) = backgroundTask {
cmd.Parameters["@name" ].Value <- item.Name
cmd.Parameters["@value"].Value <- item.Value
do! write cmd
}
cmd.CommandText <- "DELETE FROM page_meta WHERE page_id = @pageId AND name = @name AND value = @value"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO page_meta VALUES (@pageId, @name, @value)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// Update a page's prior permalinks
let updatePagePermalinks pageId oldLinks newLinks = backgroundTask {
let toDelete, toAdd = diffPermalinks oldLinks newLinks
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId)
cmd.Parameters.Add ("@link", SqliteType.Text)
] |> ignore
let runCmd link = backgroundTask {
cmd.Parameters["@link"].Value <- Permalink.toString link
do! write cmd
}
cmd.CommandText <- "DELETE FROM page_permalink WHERE page_id = @pageId AND permalink = @link"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO page_permalink VALUES (@pageId, @link)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// Create a page with no prior permalinks
let pageWithoutLinks rdr =
{ fromData<Page> rdr with PriorPermalinks = [] }
/// Update a page's revisions
let updatePageRevisions pageId oldRevs newRevs = backgroundTask {
let toDelete, toAdd = diffRevisions oldRevs newRevs
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
let runCmd withText rev = backgroundTask {
cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId)
cmd.Parameters.AddWithValue ("@asOf", rev.AsOf)
] |> ignore
if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore
do! write cmd
}
cmd.CommandText <- "DELETE FROM page_revision WHERE page_id = @pageId AND as_of = @asOf"
toDelete
|> List.map (runCmd false)
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO page_revision VALUES (@pageId, @asOf, @text)"
toAdd
|> List.map (runCmd true)
|> Task.WhenAll
|> ignore
}
let updatePageRevisions (pageId: PageId) oldRevs newRevs =
log.LogTrace "Page.updatePageRevisions"
Revisions.update Table.PageRevision Table.Page pageId oldRevs newRevs conn
// IMPLEMENTATION FUNCTIONS
/// Add a page
let add page = backgroundTask {
use cmd = conn.CreateCommand ()
// The page itself
cmd.CommandText <- """
INSERT INTO page (
id, web_log_id, author_id, title, permalink, published_on, updated_on, is_in_page_list, template,
page_text
) VALUES (
@id, @webLogId, @authorId, @title, @permalink, @publishedOn, @updatedOn, @isInPageList, @template,
@text
)"""
addPageParameters cmd page
do! write cmd
do! updatePageMeta page.Id [] page.Metadata
do! updatePagePermalinks page.Id [] page.PriorPermalinks
let add (page: Page) = backgroundTask {
log.LogTrace "Page.add"
do! conn.insert Table.Page { page with Revisions = [] }
do! updatePageRevisions page.Id [] page.Revisions
}
/// Get all pages for a web log (without text, revisions, prior permalinks, or metadata)
let all webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM page WHERE web_log_id = @webLogId ORDER BY LOWER(title)"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return toList pageWithoutTextOrMeta rdr
}
/// Get all pages for a web log (without text, metadata, revisions, or prior permalinks)
let all webLogId =
log.LogTrace "Page.all"
conn.customList
$"{Query.selectFromTable Table.Page} WHERE {Document.Query.whereByWebLog} ORDER BY LOWER({titleField})"
[ webLogParam webLogId ]
(fun rdr -> { fromData<Page> rdr with Text = ""; Metadata = []; PriorPermalinks = [] })
/// Count all pages for the given web log
let countAll webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(id) FROM page WHERE web_log_id = @webLogId"
addWebLogId cmd webLogId
return! count cmd
}
let countAll webLogId =
log.LogTrace "Page.countAll"
Document.countByWebLog Table.Page webLogId conn
/// Count all pages shown in the page list for the given web log
let countListed webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT COUNT(id)
FROM page
WHERE web_log_id = @webLogId
AND is_in_page_list = @isInPageList"""
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore
return! count cmd
}
let countListed webLogId =
log.LogTrace "Page.countListed"
conn.customScalar
$"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"}"""
[ webLogParam webLogId ]
(toCount >> int)
/// Find a page by its ID (without revisions and prior permalinks)
let findById pageId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM page WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
match Helpers.verifyWebLog<Page> webLogId (fun it -> it.WebLogId) Map.toPage rdr with
| Some page ->
let! page = appendPageMeta page
return Some page
log.LogTrace "Page.findById"
match! Document.findByIdAndWebLog<PageId, Page> Table.Page pageId webLogId conn with
| Some page -> return Some { page with PriorPermalinks = [] }
| None -> return None
}
/// Find a complete page by its ID
let findFullById pageId webLogId = backgroundTask {
match! findById pageId webLogId with
log.LogTrace "Page.findFullById"
match! Document.findByIdAndWebLog<PageId, Page> Table.Page pageId webLogId conn with
| Some page ->
let! page = appendPageRevisionsAndPermalinks page
let! page = appendPageRevisions page
return Some page
| None -> return None
}
// TODO: need to handle when the page being deleted is the home page
/// Delete a page by its ID
let delete pageId webLogId = backgroundTask {
log.LogTrace "Page.delete"
match! findById pageId webLogId with
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore
cmd.CommandText <- """
DELETE FROM page_revision WHERE page_id = @id;
DELETE FROM page_permalink WHERE page_id = @id;
DELETE FROM page_meta WHERE page_id = @id;
DELETE FROM page WHERE id = @id"""
do! write cmd
do! conn.customNonQuery
$"DELETE FROM {Table.PageRevision} WHERE page_id = @id; {Query.Delete.byId Table.Page}"
[ idParam pageId ]
return true
| None -> return false
}
/// Find a page by its permalink for the given web log
let findByPermalink permalink webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM page WHERE web_log_id = @webLogId AND permalink = @link"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then
let! page = appendPageMeta (Map.toPage rdr)
return Some page
else
return None
}
let findByPermalink (permalink: Permalink) webLogId =
log.LogTrace "Page.findByPermalink"
let linkParam = Field.EQ linkName (string permalink)
conn.customSingle
$"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkParam "@link"}"""
(addFieldParam "@link" linkParam [ webLogParam webLogId ])
pageWithoutLinks
/// Find the current permalink within a set of potential prior permalinks for the given web log
let findCurrentPermalink permalinks webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT p.permalink
FROM page p
INNER JOIN page_permalink pp ON pp.page_id = p.id
WHERE p.web_log_id = @webLogId
AND pp.permalink IN ("""
permalinks
|> List.iteri (fun idx link ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@link{idx}"
cmd.Parameters.AddWithValue ($"@link{idx}", Permalink.toString link) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toPermalink rdr) else None
}
let findCurrentPermalink (permalinks: Permalink list) webLogId =
log.LogTrace "Page.findCurrentPermalink"
let linkSql, linkParams = inJsonArray Table.Page (nameof Page.Empty.PriorPermalinks) "link" permalinks
conn.customSingle
$"SELECT data ->> '{linkName}' AS permalink
FROM {Table.Page}
WHERE {Document.Query.whereByWebLog} AND {linkSql}"
(webLogParam webLogId :: linkParams)
Map.toPermalink
/// Get all complete pages for the given web log
let findFullByWebLog webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM page WHERE web_log_id = @webLogId"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
let! pages =
toList Map.toPage rdr
|> List.map (fun page -> backgroundTask {
let! page = appendPageMeta page
return! appendPageRevisionsAndPermalinks page
})
|> Task.WhenAll
return List.ofArray pages
log.LogTrace "Page.findFullByWebLog"
let! pages = Document.findByWebLog<Page> Table.Page webLogId conn
let! withRevs = pages |> List.map appendPageRevisions |> Task.WhenAll
return List.ofArray withRevs
}
/// Get all listed pages for the given web log (without revisions, prior permalinks, or text)
let findListed webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT *
FROM page
WHERE web_log_id = @webLogId
AND is_in_page_list = @isInPageList
ORDER BY LOWER(title)"""
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! pages =
toList pageWithoutTextOrMeta rdr
|> List.map (fun page -> backgroundTask { return! appendPageMeta page })
|> Task.WhenAll
return List.ofArray pages
}
/// Get all listed pages for the given web log (without revisions or text)
let findListed webLogId =
log.LogTrace "Page.findListed"
conn.customList
$"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"}
ORDER BY LOWER({titleField})"""
[ webLogParam webLogId ]
(fun rdr -> { fromData<Page> rdr with Text = "" })
/// Get a page of pages for the given web log (without revisions, prior permalinks, or metadata)
let findPageOfPages webLogId pageNbr = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT *
FROM page
WHERE web_log_id = @webLogId
ORDER BY LOWER(title)
LIMIT @pageSize OFFSET @toSkip"""
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@pageSize", 26)
cmd.Parameters.AddWithValue ("@toSkip", (pageNbr - 1) * 25)
] |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toPage rdr
/// Get a page of pages for the given web log (without revisions)
let findPageOfPages webLogId pageNbr =
log.LogTrace "Page.findPageOfPages"
conn.customList
$"{Document.Query.selectByWebLog Table.Page} ORDER BY LOWER({titleField}) LIMIT @pageSize OFFSET @toSkip"
[ webLogParam webLogId; SqliteParameter("@pageSize", 26); SqliteParameter("@toSkip", (pageNbr - 1) * 25) ]
(fun rdr -> { pageWithoutLinks rdr with Metadata = [] })
/// Update a page
let update (page: Page) = backgroundTask {
log.LogTrace "Page.update"
match! findFullById page.Id page.WebLogId with
| Some oldPage ->
do! conn.updateById Table.Page page.Id { page with Revisions = [] }
do! updatePageRevisions page.Id oldPage.Revisions page.Revisions
| None -> ()
}
/// Restore pages from a backup
let restore pages = backgroundTask {
for page in pages do
do! add page
}
/// Update a page
let update (page : Page) = backgroundTask {
match! findFullById page.Id page.WebLogId with
| Some oldPage ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE page
SET author_id = @authorId,
title = @title,
permalink = @permalink,
published_on = @publishedOn,
updated_on = @updatedOn,
is_in_page_list = @isInPageList,
template = @template,
page_text = @text
WHERE id = @pageId
AND web_log_id = @webLogId"""
addPageParameters cmd page
do! write cmd
do! updatePageMeta page.Id oldPage.Metadata page.Metadata
do! updatePagePermalinks page.Id oldPage.PriorPermalinks page.PriorPermalinks
do! updatePageRevisions page.Id oldPage.Revisions page.Revisions
return ()
| None -> return ()
log.LogTrace "Page.restore"
for page in pages do do! add page
}
/// Update a page's prior permalinks
let updatePriorPermalinks pageId webLogId permalinks = backgroundTask {
match! findFullById pageId webLogId with
| Some page ->
do! updatePagePermalinks pageId page.PriorPermalinks permalinks
let updatePriorPermalinks pageId webLogId (permalinks: Permalink list) = backgroundTask {
log.LogTrace "Page.updatePriorPermalinks"
match! findById pageId webLogId with
| Some _ ->
do! conn.patchById Table.Page pageId {| PriorPermalinks = permalinks |}
return true
| None -> return false
}

View File

@@ -1,571 +1,213 @@
namespace MyWebLog.Data.SQLite
open System
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
open NodaTime
/// SQLite myWebLog post data implementation
type SQLitePostData (conn : SqliteConnection) =
type SQLitePostData(conn: SqliteConnection, log: ILogger) =
/// The name of the JSON field for the post's permalink
let linkName = nameof Post.Empty.Permalink
/// The JSON field for when the post was published
let publishField = $"data ->> '{nameof Post.Empty.PublishedOn}'"
/// The name of the JSON field for the post's status
let statName = nameof Post.Empty.Status
// SUPPORT FUNCTIONS
/// Add parameters for post INSERT or UPDATE statements
let addPostParameters (cmd : SqliteCommand) (post : Post) =
[ cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString post.WebLogId)
cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString post.AuthorId)
cmd.Parameters.AddWithValue ("@status", PostStatus.toString post.Status)
cmd.Parameters.AddWithValue ("@title", post.Title)
cmd.Parameters.AddWithValue ("@permalink", Permalink.toString post.Permalink)
cmd.Parameters.AddWithValue ("@publishedOn", maybe post.PublishedOn)
cmd.Parameters.AddWithValue ("@updatedOn", post.UpdatedOn)
cmd.Parameters.AddWithValue ("@template", maybe post.Template)
cmd.Parameters.AddWithValue ("@text", post.Text)
] |> ignore
/// Add parameters for episode INSERT or UPDATE statements
let addEpisodeParameters (cmd : SqliteCommand) (ep : Episode) =
[ cmd.Parameters.AddWithValue ("@media", ep.Media)
cmd.Parameters.AddWithValue ("@length", ep.Length)
cmd.Parameters.AddWithValue ("@duration", maybe ep.Duration)
cmd.Parameters.AddWithValue ("@mediaType", maybe ep.MediaType)
cmd.Parameters.AddWithValue ("@imageUrl", maybe ep.ImageUrl)
cmd.Parameters.AddWithValue ("@subtitle", maybe ep.Subtitle)
cmd.Parameters.AddWithValue ("@explicit", maybe (ep.Explicit |> Option.map ExplicitRating.toString))
cmd.Parameters.AddWithValue ("@chapterFile", maybe ep.ChapterFile)
cmd.Parameters.AddWithValue ("@chapterType", maybe ep.ChapterType)
cmd.Parameters.AddWithValue ("@transcriptUrl", maybe ep.TranscriptUrl)
cmd.Parameters.AddWithValue ("@transcriptType", maybe ep.TranscriptType)
cmd.Parameters.AddWithValue ("@transcriptLang", maybe ep.TranscriptLang)
cmd.Parameters.AddWithValue ("@transcriptCaptions", maybe ep.TranscriptCaptions)
cmd.Parameters.AddWithValue ("@seasonNumber", maybe ep.SeasonNumber)
cmd.Parameters.AddWithValue ("@seasonDescription", maybe ep.SeasonDescription)
cmd.Parameters.AddWithValue ("@episodeNumber", maybe (ep.EpisodeNumber |> Option.map string))
cmd.Parameters.AddWithValue ("@episodeDescription", maybe ep.EpisodeDescription)
] |> ignore
/// Append category IDs, tags, and meta items to a post
let appendPostCategoryTagAndMeta (post : Post) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) |> ignore
cmd.CommandText <- "SELECT category_id AS id FROM post_category WHERE post_id = @id"
use! rdr = cmd.ExecuteReaderAsync ()
let post = { post with CategoryIds = toList Map.toCategoryId rdr }
do! rdr.CloseAsync ()
cmd.CommandText <- "SELECT tag FROM post_tag WHERE post_id = @id"
use! rdr = cmd.ExecuteReaderAsync ()
let post = { post with Tags = toList (Map.getString "tag") rdr }
do! rdr.CloseAsync ()
cmd.CommandText <- "SELECT name, value FROM post_meta WHERE post_id = @id"
use! rdr = cmd.ExecuteReaderAsync ()
return { post with Metadata = toList Map.toMetaItem rdr }
/// Append revisions to a post
let appendPostRevisions (post: Post) = backgroundTask {
log.LogTrace "Post.appendPostRevisions"
let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id conn
return { post with Revisions = revisions }
}
/// Append revisions and permalinks to a post
let appendPostRevisionsAndPermalinks (post : Post) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@postId", PostId.toString post.Id) |> ignore
/// The SELECT statement to retrieve posts with a web log ID parameter
let postByWebLog = Document.Query.selectByWebLog Table.Post
cmd.CommandText <- "SELECT permalink FROM post_permalink WHERE post_id = @postId"
use! rdr = cmd.ExecuteReaderAsync ()
let post = { post with PriorPermalinks = toList Map.toPermalink rdr }
do! rdr.CloseAsync ()
cmd.CommandText <- "SELECT as_of, revision_text FROM post_revision WHERE post_id = @postId ORDER BY as_of DESC"
use! rdr = cmd.ExecuteReaderAsync ()
return { post with Revisions = toList Map.toRevision rdr }
}
/// The SELECT statement for a post that will include episode data, if it exists
let selectPost = "SELECT p.*, e.* FROM post p LEFT JOIN post_episode e ON e.post_id = p.id"
/// Find just-the-post by its ID for the given web log (excludes category, tag, meta, revisions, and permalinks)
let findPostById postId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"{selectPost} WHERE p.id = @id"
cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return Helpers.verifyWebLog<Post> webLogId (fun p -> p.WebLogId) Map.toPost rdr
}
/// Return a post with no revisions or prior permalinks
let postWithoutLinks rdr =
{ fromData<Post> rdr with PriorPermalinks = [] }
/// Return a post with no revisions, prior permalinks, or text
let postWithoutText rdr =
{ Map.toPost rdr with Text = "" }
{ postWithoutLinks rdr with Text = "" }
/// Update a post's assigned categories
let updatePostCategories postId oldCats newCats = backgroundTask {
let toDelete, toAdd = diffLists oldCats newCats CategoryId.toString
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.Add ("@categoryId", SqliteType.Text)
] |> ignore
let runCmd catId = backgroundTask {
cmd.Parameters["@categoryId"].Value <- CategoryId.toString catId
do! write cmd
}
cmd.CommandText <- "DELETE FROM post_category WHERE post_id = @postId AND category_id = @categoryId"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO post_category VALUES (@postId, @categoryId)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// Update a post's assigned categories
let updatePostTags postId (oldTags : string list) newTags = backgroundTask {
let toDelete, toAdd = diffLists oldTags newTags id
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.Add ("@tag", SqliteType.Text)
] |> ignore
let runCmd (tag : string) = backgroundTask {
cmd.Parameters["@tag"].Value <- tag
do! write cmd
}
cmd.CommandText <- "DELETE FROM post_tag WHERE post_id = @postId AND tag = @tag"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO post_tag VALUES (@postId, @tag)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// Update an episode
let updatePostEpisode (post : Post) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(post_id) FROM post_episode WHERE post_id = @postId"
cmd.Parameters.AddWithValue ("@postId", PostId.toString post.Id) |> ignore
let! count = count cmd
if count = 1 then
match post.Episode with
| Some ep ->
cmd.CommandText <- """
UPDATE post_episode
SET media = @media,
length = @length,
duration = @duration,
media_type = @mediaType,
image_url = @imageUrl,
subtitle = @subtitle,
explicit = @explicit,
chapter_file = @chapterFile,
chapter_type = @chapterType,
transcript_url = @transcriptUrl,
transcript_type = @transcriptType,
transcript_lang = @transcriptLang,
transcript_captions = @transcriptCaptions,
season_number = @seasonNumber,
season_description = @seasonDescription,
episode_number = @episodeNumber,
episode_description = @episodeDescription
WHERE post_id = @postId"""
addEpisodeParameters cmd ep
do! write cmd
| None ->
cmd.CommandText <- "DELETE FROM post_episode WHERE post_id = @postId"
do! write cmd
else
match post.Episode with
| Some ep ->
cmd.CommandText <- """
INSERT INTO post_episode (
post_id, media, length, duration, media_type, image_url, subtitle, explicit, chapter_file,
chapter_type, transcript_url, transcript_type, transcript_lang, transcript_captions,
season_number, season_description, episode_number, episode_description
) VALUES (
@postId, @media, @length, @duration, @mediaType, @imageUrl, @subtitle, @explicit, @chapterFile,
@chapterType, @transcriptUrl, @transcriptType, @transcriptLang, @transcriptCaptions,
@seasonNumber, @seasonDescription, @episodeNumber, @episodeDescription
)"""
addEpisodeParameters cmd ep
do! write cmd
| None -> ()
}
/// Update a post's metadata items
let updatePostMeta postId oldItems newItems = backgroundTask {
let toDelete, toAdd = diffMetaItems oldItems newItems
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.Add ("@name", SqliteType.Text)
cmd.Parameters.Add ("@value", SqliteType.Text)
] |> ignore
let runCmd (item : MetaItem) = backgroundTask {
cmd.Parameters["@name" ].Value <- item.Name
cmd.Parameters["@value"].Value <- item.Value
do! write cmd
}
cmd.CommandText <- "DELETE FROM post_meta WHERE post_id = @postId AND name = @name AND value = @value"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO post_meta VALUES (@postId, @name, @value)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// Update a post's prior permalinks
let updatePostPermalinks postId oldLinks newLinks = backgroundTask {
let toDelete, toAdd = diffPermalinks oldLinks newLinks
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.Add ("@link", SqliteType.Text)
] |> ignore
let runCmd link = backgroundTask {
cmd.Parameters["@link"].Value <- Permalink.toString link
do! write cmd
}
cmd.CommandText <- "DELETE FROM post_permalink WHERE post_id = @postId AND permalink = @link"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO post_permalink VALUES (@postId, @link)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// The SELECT statement to retrieve published posts with a web log ID parameter
let publishedPostByWebLog =
$"""{postByWebLog} AND {Query.whereByField (Field.EQ statName "") $"'{string Published}'"}"""
/// Update a post's revisions
let updatePostRevisions postId oldRevs newRevs = backgroundTask {
let toDelete, toAdd = diffRevisions oldRevs newRevs
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
let runCmd withText rev = backgroundTask {
cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.AddWithValue ("@asOf", rev.AsOf)
] |> ignore
if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore
do! write cmd
}
cmd.CommandText <- "DELETE FROM post_revision WHERE post_id = @postId AND as_of = @asOf"
toDelete
|> List.map (runCmd false)
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO post_revision VALUES (@postId, @asOf, @text)"
toAdd
|> List.map (runCmd true)
|> Task.WhenAll
|> ignore
}
let updatePostRevisions (postId: PostId) oldRevs newRevs =
log.LogTrace "Post.updatePostRevisions"
Revisions.update Table.PostRevision Table.Post postId oldRevs newRevs conn
// IMPLEMENTATION FUNCTIONS
/// Add a post
let add post = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO post (
id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text
) VALUES (
@id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, @template, @text
)"""
addPostParameters cmd post
do! write cmd
do! updatePostCategories post.Id [] post.CategoryIds
do! updatePostTags post.Id [] post.Tags
do! updatePostEpisode post
do! updatePostMeta post.Id [] post.Metadata
do! updatePostPermalinks post.Id [] post.PriorPermalinks
let add (post: Post) = backgroundTask {
log.LogTrace "Post.add"
do! conn.insert Table.Post { post with Revisions = [] }
do! updatePostRevisions post.Id [] post.Revisions
}
/// Count posts in a status for the given web log
let countByStatus status webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(id) FROM post WHERE web_log_id = @webLogId AND status = @status"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@status", PostStatus.toString status) |> ignore
return! count cmd
}
let countByStatus (status: PostStatus) webLogId =
log.LogTrace "Post.countByStatus"
let statParam = Field.EQ statName (string status)
conn.customScalar
$"""{Document.Query.countByWebLog Table.Post} AND {Query.whereByField statParam "@status"}"""
(addFieldParam "@status" statParam [ webLogParam webLogId ])
(toCount >> int)
/// Find a post by its ID for the given web log (excluding revisions and prior permalinks
/// Find a post by its ID for the given web log (excluding revisions)
let findById postId webLogId = backgroundTask {
match! findPostById postId webLogId with
| Some post ->
let! post = appendPostCategoryTagAndMeta post
return Some post
log.LogTrace "Post.findById"
match! Document.findByIdAndWebLog<PostId, Post> Table.Post postId webLogId conn with
| Some post -> return Some { post with PriorPermalinks = [] }
| None -> return None
}
/// Find a post by its permalink for the given web log (excluding revisions and prior permalinks)
let findByPermalink permalink webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"{selectPost} WHERE p.web_log_id = @webLogId AND p.permalink = @link"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (Map.toPost rdr)
return Some post
else
return None
}
/// Find a post by its permalink for the given web log (excluding revisions)
let findByPermalink (permalink: Permalink) webLogId =
log.LogTrace "Post.findByPermalink"
let linkParam = Field.EQ linkName (string permalink)
conn.customSingle
$"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkParam "@link"}"""
(addFieldParam "@link" linkParam [ webLogParam webLogId ])
postWithoutLinks
/// Find a complete post by its ID for the given web log
let findFullById postId webLogId = backgroundTask {
match! findById postId webLogId with
log.LogTrace "Post.findFullById"
match! Document.findByIdAndWebLog<PostId, Post> Table.Post postId webLogId conn with
| Some post ->
let! post = appendPostRevisionsAndPermalinks post
let! post = appendPostRevisions post
return Some post
| None -> return None
}
/// Delete a post by its ID for the given web log
let delete postId webLogId = backgroundTask {
match! findFullById postId webLogId with
log.LogTrace "Post.delete"
match! findById postId webLogId with
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore
cmd.CommandText <- """
DELETE FROM post_revision WHERE post_id = @id;
DELETE FROM post_permalink WHERE post_id = @id;
DELETE FROM post_meta WHERE post_id = @id;
DELETE FROM post_episode WHERE post_id = @id;
DELETE FROM post_tag WHERE post_id = @id;
DELETE FROM post_category WHERE post_id = @id;
DELETE FROM post WHERE id = @id"""
do! write cmd
do! conn.customNonQuery
$"""DELETE FROM {Table.PostRevision} WHERE post_id = @id;
DELETE FROM {Table.PostComment}
WHERE {Query.whereByField (Field.EQ (nameof Comment.Empty.PostId) "") "@id"};
{Query.Delete.byId Table.Post}"""
[ idParam postId ]
return true
| None -> return false
}
/// Find the current permalink from a list of potential prior permalinks for the given web log
let findCurrentPermalink permalinks webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT p.permalink
FROM post p
INNER JOIN post_permalink pp ON pp.post_id = p.id
WHERE p.web_log_id = @webLogId
AND pp.permalink IN ("""
permalinks
|> List.iteri (fun idx link ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@link{idx}"
cmd.Parameters.AddWithValue ($"@link{idx}", Permalink.toString link) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toPermalink rdr) else None
}
let findCurrentPermalink (permalinks: Permalink list) webLogId =
log.LogTrace "Post.findCurrentPermalink"
let linkSql, linkParams = inJsonArray Table.Post (nameof Post.Empty.PriorPermalinks) "link" permalinks
conn.customSingle
$"SELECT data ->> '{linkName}' AS permalink
FROM {Table.Post}
WHERE {Document.Query.whereByWebLog} AND {linkSql}"
(webLogParam webLogId :: linkParams)
Map.toPermalink
/// Get all complete posts for the given web log
let findFullByWebLog webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"{selectPost} WHERE p.web_log_id = @webLogId"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
|> List.map (fun post -> backgroundTask {
let! post = appendPostCategoryTagAndMeta post
return! appendPostRevisionsAndPermalinks post
})
|> Task.WhenAll
return List.ofArray posts
log.LogTrace "Post.findFullByWebLog"
let! posts = Document.findByWebLog<Post> Table.Post webLogId conn
let! withRevs = posts |> List.map appendPostRevisions |> Task.WhenAll
return List.ofArray withRevs
}
/// Get a page of categorized posts for the given web log (excludes revisions and prior permalinks)
let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
{selectPost}
INNER JOIN post_category pc ON pc.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND pc.category_id IN ("""
categoryIds
|> List.iteri (fun idx catId ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@catId{idx}"
cmd.Parameters.AddWithValue ($"@catId{idx}", CategoryId.toString catId) |> ignore)
cmd.CommandText <-
$"""{cmd.CommandText})
ORDER BY published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
|> Task.WhenAll
return List.ofArray posts
}
/// Get a page of categorized posts for the given web log (excludes revisions)
let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfCategorizedPosts"
let catSql, catParams = inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId" categoryIds
conn.customList
$"{publishedPostByWebLog} AND {catSql}
ORDER BY {publishField} DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
(webLogParam webLogId :: catParams)
postWithoutLinks
/// Get a page of posts for the given web log (excludes text, revisions, and prior permalinks)
let findPageOfPosts webLogId pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
{selectPost}
WHERE p.web_log_id = @webLogId
ORDER BY p.published_on DESC NULLS FIRST, p.updated_on
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList postWithoutText rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
|> Task.WhenAll
return List.ofArray posts
}
/// Get a page of posts for the given web log (excludes text and revisions)
let findPageOfPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPosts"
conn.customList
$"{postByWebLog}
ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}'
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ webLogParam webLogId ]
postWithoutText
/// Get a page of published posts for the given web log (excludes revisions and prior permalinks)
let findPageOfPublishedPosts webLogId pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
{selectPost}
WHERE p.web_log_id = @webLogId
AND p.status = @status
ORDER BY p.published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
|> Task.WhenAll
return List.ofArray posts
}
/// Get a page of published posts for the given web log (excludes revisions)
let findPageOfPublishedPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPublishedPosts"
conn.customList
$"{publishedPostByWebLog}
ORDER BY {publishField} DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ webLogParam webLogId ]
postWithoutLinks
/// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks)
let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
{selectPost}
INNER JOIN post_tag pt ON pt.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND pt.tag = @tag
ORDER BY p.published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published)
cmd.Parameters.AddWithValue ("@tag", tag)
] |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
|> Task.WhenAll
return List.ofArray posts
}
/// Get a page of tagged posts for the given web log (excludes revisions)
let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfTaggedPosts"
let tagSql, tagParams = inJsonArray Table.Post (nameof Post.Empty.Tags) "tag" [ tag ]
conn.customList
$"{publishedPostByWebLog} AND {tagSql}
ORDER BY {publishField} DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
(webLogParam webLogId :: tagParams)
postWithoutLinks
/// Find the next newest and oldest post from a publish date for the given web log
let findSurroundingPosts webLogId (publishedOn : DateTime) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
{selectPost}
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND p.published_on < @publishedOn
ORDER BY p.published_on DESC
LIMIT 1"""
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published)
cmd.Parameters.AddWithValue ("@publishedOn", publishedOn)
] |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! older = backgroundTask {
if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (postWithoutText rdr)
return Some post
else
return None
}
do! rdr.CloseAsync ()
cmd.CommandText <- $"""
{selectPost}
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND p.published_on > @publishedOn
ORDER BY p.published_on
LIMIT 1"""
use! rdr = cmd.ExecuteReaderAsync ()
let! newer = backgroundTask {
if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (postWithoutText rdr)
return Some post
else
return None
}
let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask {
log.LogTrace "Post.findSurroundingPosts"
let! older =
conn.customSingle
$"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1"
[ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ]
postWithoutLinks
let! newer =
conn.customSingle
$"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1"
[ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ]
postWithoutLinks
return older, newer
}
/// Restore posts from a backup
let restore posts = backgroundTask {
for post in posts do
do! add post
}
/// Update a post
let update (post: Post) = backgroundTask {
log.LogTrace "Post.update"
match! findFullById post.Id post.WebLogId with
| Some oldPost ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE post
SET author_id = @authorId,
status = @status,
title = @title,
permalink = @permalink,
published_on = @publishedOn,
updated_on = @updatedOn,
template = @template,
post_text = @text
WHERE id = @id
AND web_log_id = @webLogId"""
addPostParameters cmd post
do! write cmd
do! updatePostCategories post.Id oldPost.CategoryIds post.CategoryIds
do! updatePostTags post.Id oldPost.Tags post.Tags
do! updatePostEpisode post
do! updatePostMeta post.Id oldPost.Metadata post.Metadata
do! updatePostPermalinks post.Id oldPost.PriorPermalinks post.PriorPermalinks
do! conn.updateById Table.Post post.Id { post with Revisions = [] }
do! updatePostRevisions post.Id oldPost.Revisions post.Revisions
| None -> return ()
| None -> ()
}
/// Restore posts from a backup
let restore posts = backgroundTask {
log.LogTrace "Post.restore"
for post in posts do do! add post
}
/// Update prior permalinks for a post
let updatePriorPermalinks postId webLogId permalinks = backgroundTask {
match! findFullById postId webLogId with
| Some post ->
do! updatePostPermalinks postId post.PriorPermalinks permalinks
let updatePriorPermalinks postId webLogId (permalinks: Permalink list) = backgroundTask {
match! findById postId webLogId with
| Some _ ->
do! conn.patchById Table.Post postId {| PriorPermalinks = permalinks |}
return true
| None -> return false
}

View File

@@ -1,101 +1,62 @@
namespace MyWebLog.Data.SQLite
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
/// SQLite myWebLog tag mapping data implementation
type SQLiteTagMapData (conn : SqliteConnection) =
type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) =
/// Find a tag mapping by its ID for the given web log
let findById tagMapId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM tag_map WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMapId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return Helpers.verifyWebLog<TagMap> webLogId (fun tm -> tm.WebLogId) Map.toTagMap rdr
}
let findById tagMapId webLogId =
log.LogTrace "TagMap.findById"
Document.findByIdAndWebLog<TagMapId, TagMap> Table.TagMap tagMapId webLogId conn
/// Delete a tag mapping for the given web log
let delete tagMapId webLogId = backgroundTask {
log.LogTrace "TagMap.delete"
match! findById tagMapId webLogId with
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- "DELETE FROM tag_map WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMapId) |> ignore
do! write cmd
do! conn.deleteById Table.TagMap tagMapId
return true
| None -> return false
}
/// Find a tag mapping by its URL value for the given web log
let findByUrlValue (urlValue : string) webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM tag_map WHERE web_log_id = @webLogId AND url_value = @urlValue"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@urlValue", urlValue) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toTagMap rdr) else None
}
let findByUrlValue (urlValue: string) webLogId =
log.LogTrace "TagMap.findByUrlValue"
let urlParam = Field.EQ (nameof TagMap.Empty.UrlValue) urlValue
conn.customSingle
$"""{Document.Query.selectByWebLog Table.TagMap} AND {Query.whereByField urlParam "@urlValue"}"""
(addFieldParam "@urlValue" urlParam [ webLogParam webLogId ])
fromData<TagMap>
/// Get all tag mappings for the given web log
let findByWebLog webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM tag_map WHERE web_log_id = @webLogId ORDER BY tag"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toTagMap rdr
}
let findByWebLog webLogId =
log.LogTrace "TagMap.findByWebLog"
Document.findByWebLog<TagMap> Table.TagMap webLogId conn
/// Find any tag mappings in a list of tags for the given web log
let findMappingForTags (tags : string list) webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT *
FROM tag_map
WHERE web_log_id = @webLogId
AND tag IN ("""
tags
|> List.iteri (fun idx tag ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@tag{idx}"
cmd.Parameters.AddWithValue ($"@tag{idx}", tag) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toTagMap rdr
}
let findMappingForTags (tags: string list) webLogId =
log.LogTrace "TagMap.findMappingForTags"
let mapSql, mapParams = inClause $"AND data ->> '{nameof TagMap.Empty.Tag}'" "tag" id tags
conn.customList
$"{Document.Query.selectByWebLog Table.TagMap} {mapSql}"
(webLogParam webLogId :: mapParams)
fromData<TagMap>
/// Save a tag mapping
let save (tagMap : TagMap) = backgroundTask {
use cmd = conn.CreateCommand ()
match! findById tagMap.Id tagMap.WebLogId with
| Some _ ->
cmd.CommandText <- """
UPDATE tag_map
SET tag = @tag,
url_value = @urlValue
WHERE id = @id
AND web_log_id = @webLogId"""
| None ->
cmd.CommandText <- """
INSERT INTO tag_map (
id, web_log_id, tag, url_value
) VALUES (
@id, @webLogId, @tag, @urlValue
)"""
addWebLogId cmd tagMap.WebLogId
[ cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMap.Id)
cmd.Parameters.AddWithValue ("@tag", tagMap.Tag)
cmd.Parameters.AddWithValue ("@urlValue", tagMap.UrlValue)
] |> ignore
do! write cmd
}
let save (tagMap: TagMap) =
log.LogTrace "TagMap.save"
conn.save Table.TagMap tagMap
/// Restore tag mappings from a backup
let restore tagMaps = backgroundTask {
for tagMap in tagMaps do
do! save tagMap
log.LogTrace "TagMap.restore"
for tagMap in tagMaps do do! save tagMap
}
interface ITagMapData with

View File

@@ -1,107 +1,71 @@
namespace MyWebLog.Data.SQLite
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
/// SQLite myWebLog theme data implementation
type SQLiteThemeData (conn : SqliteConnection) =
type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
/// Retrieve all themes (except 'admin'; excludes templates)
let all () = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM theme WHERE id <> 'admin' ORDER BY id"
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toTheme rdr
}
/// The JSON field for the theme ID
let idField = $"data ->> '{nameof Theme.Empty.Id}'"
/// Convert a document to a theme with no template text
let withoutTemplateText (rdr: SqliteDataReader) =
let theme = fromData<Theme> rdr
{ theme with Templates = theme.Templates |> List.map (fun t -> { t with Text = "" })}
/// Remove the template text from a theme
let withoutTemplateText' (it: Theme) =
{ it with Templates = it.Templates |> List.map (fun t -> { t with Text = "" }) }
/// Retrieve all themes (except 'admin'; excludes template text)
let all () =
log.LogTrace "Theme.all"
conn.customList
$"{Query.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}"
[]
withoutTemplateText
/// Does a given theme exist?
let exists (themeId: ThemeId) =
log.LogTrace "Theme.exists"
conn.existsById Table.Theme themeId
/// Find a theme by its ID
let findById themeId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM theme WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then
let theme = Map.toTheme rdr
let templateCmd = conn.CreateCommand ()
templateCmd.CommandText <- "SELECT * FROM theme_template WHERE theme_id = @id"
templateCmd.Parameters.Add cmd.Parameters["@id"] |> ignore
use! templateRdr = templateCmd.ExecuteReaderAsync ()
return Some { theme with Templates = toList Map.toThemeTemplate templateRdr }
else
return None
}
let findById themeId =
log.LogTrace "Theme.findById"
conn.findById<ThemeId, Theme> Table.Theme themeId
/// Find a theme by its ID (excludes the text of templates)
let findByIdWithoutText themeId = backgroundTask {
match! findById themeId with
| Some theme ->
return Some {
theme with Templates = theme.Templates |> List.map (fun t -> { t with Text = "" })
}
| None -> return None
let findByIdWithoutText (themeId: ThemeId) =
log.LogTrace "Theme.findByIdWithoutText"
conn.customSingle (Query.Find.byId Table.Theme) [ idParam themeId ] withoutTemplateText
/// Delete a theme by its ID
let delete themeId = backgroundTask {
log.LogTrace "Theme.delete"
match! findByIdWithoutText themeId with
| Some _ ->
do! conn.customNonQuery
$"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; {Query.Delete.byId Table.Theme}"
[ idParam themeId ]
return true
| None -> return false
}
/// Save a theme
let save (theme : Theme) = backgroundTask {
use cmd = conn.CreateCommand ()
let! oldTheme = findById theme.Id
cmd.CommandText <-
match oldTheme with
| Some _ -> "UPDATE theme SET name = @name, version = @version WHERE id = @id"
| None -> "INSERT INTO theme VALUES (@id, @name, @version)"
[ cmd.Parameters.AddWithValue ("@id", ThemeId.toString theme.Id)
cmd.Parameters.AddWithValue ("@name", theme.Name)
cmd.Parameters.AddWithValue ("@version", theme.Version)
] |> ignore
do! write cmd
let toDelete, toAdd =
diffLists (oldTheme |> Option.map (fun t -> t.Templates) |> Option.defaultValue [])
theme.Templates (fun t -> t.Name)
let toUpdate =
theme.Templates
|> List.filter (fun t ->
not (toDelete |> List.exists (fun d -> d.Name = t.Name))
&& not (toAdd |> List.exists (fun a -> a.Name = t.Name)))
cmd.CommandText <-
"UPDATE theme_template SET template = @template WHERE theme_id = @themeId AND name = @name"
cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString theme.Id)
cmd.Parameters.Add ("@name", SqliteType.Text)
cmd.Parameters.Add ("@template", SqliteType.Text)
] |> ignore
toUpdate
|> List.map (fun template -> backgroundTask {
cmd.Parameters["@name" ].Value <- template.Name
cmd.Parameters["@template"].Value <- template.Text
do! write cmd
})
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO theme_template VALUES (@themeId, @name, @template)"
toAdd
|> List.map (fun template -> backgroundTask {
cmd.Parameters["@name" ].Value <- template.Name
cmd.Parameters["@template"].Value <- template.Text
do! write cmd
})
|> Task.WhenAll
|> ignore
cmd.CommandText <- "DELETE FROM theme_template WHERE theme_id = @themeId AND name = @name"
cmd.Parameters.Remove cmd.Parameters["@template"]
toDelete
|> List.map (fun template -> backgroundTask {
cmd.Parameters["@name"].Value <- template.Name
do! write cmd
})
|> Task.WhenAll
|> ignore
}
let save (theme: Theme) =
log.LogTrace "Theme.save"
conn.save Table.Theme theme
interface IThemeData with
member _.All() = all ()
member _.Delete themeId = delete themeId
member _.Exists themeId = exists themeId
member _.FindById themeId = findById themeId
member _.FindByIdWithoutText themeId = findByIdWithoutText themeId
member _.Save theme = save theme
@@ -110,91 +74,69 @@ type SQLiteThemeData (conn : SqliteConnection) =
open System.IO
/// SQLite myWebLog theme data implementation
type SQLiteThemeAssetData (conn : SqliteConnection) =
type SQLiteThemeAssetData(conn : SqliteConnection, log: ILogger) =
/// Create parameters for a theme asset ID
let assetIdParams assetId =
let (ThemeAssetId (ThemeId themeId, path)) = assetId
[ idParam themeId; sqlParam "@path" path ]
/// Get all theme assets (excludes data)
let all () = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT theme_id, path, updated_on FROM theme_asset"
use! rdr = cmd.ExecuteReaderAsync ()
return toList (Map.toThemeAsset false) rdr
}
let all () =
log.LogTrace "ThemeAsset.all"
conn.customList $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset}" [] (Map.toThemeAsset false)
/// Delete all assets for the given theme
let deleteByTheme themeId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "DELETE FROM theme_asset WHERE theme_id = @themeId"
cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString themeId) |> ignore
do! write cmd
}
let deleteByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.deleteByTheme"
conn.customNonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ]
/// Find a theme asset by its ID
let findById assetId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT *, ROWID FROM theme_asset WHERE theme_id = @themeId AND path = @path"
let (ThemeAssetId (ThemeId themeId, path)) = assetId
[ cmd.Parameters.AddWithValue ("@themeId", themeId)
cmd.Parameters.AddWithValue ("@path", path)
] |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toThemeAsset true rdr) else None
}
let findById assetId =
log.LogTrace "ThemeAsset.findById"
conn.customSingle
$"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id AND path = @path"
(assetIdParams assetId)
(Map.toThemeAsset true)
/// Get theme assets for the given theme (excludes data)
let findByTheme themeId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT theme_id, path, updated_on FROM theme_asset WHERE theme_id = @themeId"
cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString themeId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return toList (Map.toThemeAsset false) rdr
}
let findByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.findByTheme"
conn.customList
$"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @id"
[ idParam themeId ]
(Map.toThemeAsset false)
/// Get theme assets for the given theme
let findByThemeWithData themeId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT *, ROWID FROM theme_asset WHERE theme_id = @themeId"
cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString themeId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return toList (Map.toThemeAsset true) rdr
}
let findByThemeWithData (themeId: ThemeId) =
log.LogTrace "ThemeAsset.findByThemeWithData"
conn.customList
$"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id"
[ idParam themeId ]
(Map.toThemeAsset true)
/// Save a theme asset
let save (asset: ThemeAsset) = backgroundTask {
use sideCmd = conn.CreateCommand ()
sideCmd.CommandText <-
"SELECT COUNT(path) FROM theme_asset WHERE theme_id = @themeId AND path = @path"
let (ThemeAssetId (ThemeId themeId, path)) = asset.Id
[ sideCmd.Parameters.AddWithValue ("@themeId", themeId)
sideCmd.Parameters.AddWithValue ("@path", path)
] |> ignore
let! exists = count sideCmd
use cmd = conn.CreateCommand ()
cmd.CommandText <-
if exists = 1 then
"""UPDATE theme_asset
SET updated_on = @updatedOn,
data = ZEROBLOB(@dataLength)
WHERE theme_id = @themeId
AND path = @path"""
else
"""INSERT INTO theme_asset (
log.LogTrace "ThemeAsset.save"
do! conn.customNonQuery
$"INSERT INTO {Table.ThemeAsset} (
theme_id, path, updated_on, data
) VALUES (
@themeId, @path, @updatedOn, ZEROBLOB(@dataLength)
)"""
[ cmd.Parameters.AddWithValue ("@themeId", themeId)
cmd.Parameters.AddWithValue ("@path", path)
cmd.Parameters.AddWithValue ("@updatedOn", asset.UpdatedOn)
cmd.Parameters.AddWithValue ("@dataLength", asset.Data.Length)
] |> ignore
do! write cmd
sideCmd.CommandText <- "SELECT ROWID FROM theme_asset WHERE theme_id = @themeId AND path = @path"
let! rowId = sideCmd.ExecuteScalarAsync ()
@id, @path, @updatedOn, ZEROBLOB(@dataLength)
) ON CONFLICT (theme_id, path) DO UPDATE
SET updated_on = @updatedOn,
data = ZEROBLOB(@dataLength)"
[ sqlParam "@updatedOn" (instantParam asset.UpdatedOn)
sqlParam "@dataLength" asset.Data.Length
yield! (assetIdParams asset.Id) ]
let! rowId =
conn.customScalar
$"SELECT ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id AND path = @path"
(assetIdParams asset.Id)
_.GetInt64(0)
use dataStream = new MemoryStream(asset.Data)
use blobStream = new SqliteBlob (conn, "theme_asset", "data", rowId :?> int64)
use blobStream = new SqliteBlob(conn, Table.ThemeAsset, "data", rowId)
do! dataStream.CopyToAsync blobStream
}

View File

@@ -1,93 +1,78 @@
namespace MyWebLog.Data.SQLite
open System.IO
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
/// SQLite myWebLog web log data implementation
type SQLiteUploadData (conn : SqliteConnection) =
/// Add parameters for uploaded file INSERT and UPDATE statements
let addUploadParameters (cmd : SqliteCommand) (upload : Upload) =
[ cmd.Parameters.AddWithValue ("@id", UploadId.toString upload.Id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString upload.WebLogId)
cmd.Parameters.AddWithValue ("@path", Permalink.toString upload.Path)
cmd.Parameters.AddWithValue ("@updatedOn", upload.UpdatedOn)
cmd.Parameters.AddWithValue ("@dataLength", upload.Data.Length)
] |> ignore
type SQLiteUploadData(conn: SqliteConnection, log: ILogger) =
/// Save an uploaded file
let add upload = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO upload (
let add (upload: Upload) = backgroundTask {
log.LogTrace "Upload.add"
do! conn.customNonQuery
$"INSERT INTO {Table.Upload} (
id, web_log_id, path, updated_on, data
) VALUES (
@id, @webLogId, @path, @updatedOn, ZEROBLOB(@dataLength)
)"""
addUploadParameters cmd upload
do! write cmd
cmd.CommandText <- "SELECT ROWID FROM upload WHERE id = @id"
let! rowId = cmd.ExecuteScalarAsync ()
)"
[ idParam upload.Id
webLogParam upload.WebLogId
sqlParam "@path" (string upload.Path)
sqlParam "@updatedOn" (instantParam upload.UpdatedOn)
sqlParam "@dataLength" upload.Data.Length ]
let! rowId =
conn.customScalar $"SELECT ROWID FROM {Table.Upload} WHERE id = @id" [ idParam upload.Id ] _.GetInt64(0)
use dataStream = new MemoryStream(upload.Data)
use blobStream = new SqliteBlob (conn, "upload", "data", rowId :?> int64)
use blobStream = new SqliteBlob(conn, Table.Upload, "data", rowId)
do! dataStream.CopyToAsync blobStream
}
/// Delete an uploaded file by its ID
let delete uploadId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT id, web_log_id, path, updated_on
FROM upload
WHERE id = @id
AND web_log_id = @webLogId"""
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@id", UploadId.toString uploadId) |> ignore
let! rdr = cmd.ExecuteReaderAsync ()
if (rdr.Read ()) then
let upload = Map.toUpload false rdr
do! rdr.CloseAsync ()
cmd.CommandText <- "DELETE FROM upload WHERE id = @id AND web_log_id = @webLogId"
do! write cmd
return Ok (Permalink.toString upload.Path)
else
return Error $"""Upload ID {cmd.Parameters["@id"]} not found"""
let delete (uploadId: UploadId) webLogId = backgroundTask {
log.LogTrace "Upload.delete"
let! upload =
conn.customSingle
$"SELECT id, web_log_id, path, updated_on FROM {Table.Upload} WHERE id = @id AND web_log_id = @webLogId"
[ idParam uploadId; webLogParam webLogId ]
(Map.toUpload false)
match upload with
| Some up ->
do! conn.customNonQuery $"DELETE FROM {Table.Upload} WHERE id = @id" [ idParam up.Id ]
return Ok (string up.Path)
| None -> return Error $"Upload ID {string uploadId} not found"
}
/// Find an uploaded file by its path for the given web log
let findByPath (path : string) webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT *, ROWID FROM upload WHERE web_log_id = @webLogId AND path = @path"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@path", path) |> ignore
let! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toUpload true rdr) else None
}
let findByPath (path: string) webLogId =
log.LogTrace "Upload.findByPath"
conn.customSingle
$"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId AND path = @path"
[ webLogParam webLogId; sqlParam "@path" path ]
(Map.toUpload true)
/// Find all uploaded files for the given web log (excludes data)
let findByWebLog webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT id, web_log_id, path, updated_on FROM upload WHERE web_log_id = @webLogId"
addWebLogId cmd webLogId
let! rdr = cmd.ExecuteReaderAsync ()
return toList (Map.toUpload false) rdr
}
let findByWebLog webLogId =
log.LogTrace "Upload.findByWebLog"
conn.customList
$"SELECT id, web_log_id, path, updated_on FROM {Table.Upload} WHERE web_log_id = @webLogId"
[ webLogParam webLogId ]
(Map.toUpload false)
/// Find all uploaded files for the given web log
let findByWebLogWithData webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT *, ROWID FROM upload WHERE web_log_id = @webLogId"
addWebLogId cmd webLogId
let! rdr = cmd.ExecuteReaderAsync ()
return toList (Map.toUpload true) rdr
}
let findByWebLogWithData webLogId =
log.LogTrace "Upload.findByWebLogWithData"
conn.customList
$"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId"
[ webLogParam webLogId ]
(Map.toUpload true)
/// Restore uploads from a backup
let restore uploads = backgroundTask {
log.LogTrace "Upload.restore"
for upload in uploads do do! add upload
}

View File

@@ -1,328 +1,67 @@
namespace MyWebLog.Data.SQLite
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
// The web log podcast insert loop is not statically compilable; this is OK
#nowarn "3511"
/// SQLite myWebLog web log data implementation
type SQLiteWebLogData (conn : SqliteConnection) =
// SUPPORT FUNCTIONS
/// Add parameters for web log INSERT or web log/RSS options UPDATE statements
let addWebLogRssParameters (cmd : SqliteCommand) (webLog : WebLog) =
[ cmd.Parameters.AddWithValue ("@isFeedEnabled", webLog.Rss.IsFeedEnabled)
cmd.Parameters.AddWithValue ("@feedName", webLog.Rss.FeedName)
cmd.Parameters.AddWithValue ("@itemsInFeed", maybe webLog.Rss.ItemsInFeed)
cmd.Parameters.AddWithValue ("@isCategoryEnabled", webLog.Rss.IsCategoryEnabled)
cmd.Parameters.AddWithValue ("@isTagEnabled", webLog.Rss.IsTagEnabled)
cmd.Parameters.AddWithValue ("@copyright", maybe webLog.Rss.Copyright)
] |> ignore
/// Add parameters for web log INSERT or UPDATE statements
let addWebLogParameters (cmd : SqliteCommand) (webLog : WebLog) =
[ cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id)
cmd.Parameters.AddWithValue ("@name", webLog.Name)
cmd.Parameters.AddWithValue ("@slug", webLog.Slug)
cmd.Parameters.AddWithValue ("@subtitle", maybe webLog.Subtitle)
cmd.Parameters.AddWithValue ("@defaultPage", webLog.DefaultPage)
cmd.Parameters.AddWithValue ("@postsPerPage", webLog.PostsPerPage)
cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString webLog.ThemeId)
cmd.Parameters.AddWithValue ("@urlBase", webLog.UrlBase)
cmd.Parameters.AddWithValue ("@timeZone", webLog.TimeZone)
cmd.Parameters.AddWithValue ("@autoHtmx", webLog.AutoHtmx)
cmd.Parameters.AddWithValue ("@uploads", UploadDestination.toString webLog.Uploads)
] |> ignore
addWebLogRssParameters cmd webLog
/// Add parameters for custom feed INSERT or UPDATE statements
let addCustomFeedParameters (cmd : SqliteCommand) webLogId (feed : CustomFeed) =
[ cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString feed.Id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId)
cmd.Parameters.AddWithValue ("@source", CustomFeedSource.toString feed.Source)
cmd.Parameters.AddWithValue ("@path", Permalink.toString feed.Path)
] |> ignore
/// Add parameters for podcast INSERT or UPDATE statements
let addPodcastParameters (cmd : SqliteCommand) feedId (podcast : PodcastOptions) =
[ cmd.Parameters.AddWithValue ("@feedId", CustomFeedId.toString feedId)
cmd.Parameters.AddWithValue ("@title", podcast.Title)
cmd.Parameters.AddWithValue ("@subtitle", maybe podcast.Subtitle)
cmd.Parameters.AddWithValue ("@itemsInFeed", podcast.ItemsInFeed)
cmd.Parameters.AddWithValue ("@summary", podcast.Summary)
cmd.Parameters.AddWithValue ("@displayedAuthor", podcast.DisplayedAuthor)
cmd.Parameters.AddWithValue ("@email", podcast.Email)
cmd.Parameters.AddWithValue ("@imageUrl", Permalink.toString podcast.ImageUrl)
cmd.Parameters.AddWithValue ("@appleCategory", podcast.AppleCategory)
cmd.Parameters.AddWithValue ("@appleSubcategory", maybe podcast.AppleSubcategory)
cmd.Parameters.AddWithValue ("@explicit", ExplicitRating.toString podcast.Explicit)
cmd.Parameters.AddWithValue ("@defaultMediaType", maybe podcast.DefaultMediaType)
cmd.Parameters.AddWithValue ("@mediaBaseUrl", maybe podcast.MediaBaseUrl)
cmd.Parameters.AddWithValue ("@podcastGuid", maybe podcast.PodcastGuid)
cmd.Parameters.AddWithValue ("@fundingUrl", maybe podcast.FundingUrl)
cmd.Parameters.AddWithValue ("@fundingText", maybe podcast.FundingText)
cmd.Parameters.AddWithValue ("@medium", maybe (podcast.Medium |> Option.map PodcastMedium.toString))
] |> ignore
/// Get the current custom feeds for a web log
let getCustomFeeds (webLog : WebLog) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT f.*, p.*
FROM web_log_feed f
LEFT JOIN web_log_feed_podcast p ON p.feed_id = f.id
WHERE f.web_log_id = @webLogId"""
addWebLogId cmd webLog.Id
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toCustomFeed rdr
}
/// Append custom feeds to a web log
let appendCustomFeeds (webLog : WebLog) = backgroundTask {
let! feeds = getCustomFeeds webLog
return { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } }
}
/// Add a podcast to a custom feed
let addPodcast feedId (podcast : PodcastOptions) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO web_log_feed_podcast (
feed_id, title, subtitle, items_in_feed, summary, displayed_author, email, image_url,
apple_category, apple_subcategory, explicit, default_media_type, media_base_url, podcast_guid,
funding_url, funding_text, medium
) VALUES (
@feedId, @title, @subtitle, @itemsInFeed, @summary, @displayedAuthor, @email, @imageUrl,
@appleCategory, @appleSubcategory, @explicit, @defaultMediaType, @mediaBaseUrl, @podcastGuid,
@fundingUrl, @fundingText, @medium
)"""
addPodcastParameters cmd feedId podcast
do! write cmd
}
/// Update the custom feeds for a web log
let updateCustomFeeds (webLog : WebLog) = backgroundTask {
let! feeds = getCustomFeeds webLog
let toDelete, toAdd = diffLists feeds webLog.Rss.CustomFeeds (fun it -> $"{CustomFeedId.toString it.Id}")
let toId (feed : CustomFeed) = feed.Id
let toUpdate =
webLog.Rss.CustomFeeds
|> List.filter (fun f ->
not (toDelete |> List.map toId |> List.append (toAdd |> List.map toId) |> List.contains f.Id))
use cmd = conn.CreateCommand ()
cmd.Parameters.Add ("@id", SqliteType.Text) |> ignore
toDelete
|> List.map (fun it -> backgroundTask {
cmd.CommandText <- """
DELETE FROM web_log_feed_podcast WHERE feed_id = @id;
DELETE FROM web_log_feed WHERE id = @id"""
cmd.Parameters["@id"].Value <- CustomFeedId.toString it.Id
do! write cmd
})
|> Task.WhenAll
|> ignore
cmd.Parameters.Clear ()
toAdd
|> List.map (fun it -> backgroundTask {
cmd.CommandText <- """
INSERT INTO web_log_feed (
id, web_log_id, source, path
) VALUES (
@id, @webLogId, @source, @path
)"""
cmd.Parameters.Clear ()
addCustomFeedParameters cmd webLog.Id it
do! write cmd
match it.Podcast with
| Some podcast -> do! addPodcast it.Id podcast
| None -> ()
})
|> Task.WhenAll
|> ignore
toUpdate
|> List.map (fun it -> backgroundTask {
cmd.CommandText <- """
UPDATE web_log_feed
SET source = @source,
path = @path
WHERE id = @id
AND web_log_id = @webLogId"""
cmd.Parameters.Clear ()
addCustomFeedParameters cmd webLog.Id it
do! write cmd
let hadPodcast = Option.isSome (feeds |> List.find (fun f -> f.Id = it.Id)).Podcast
match it.Podcast with
| Some podcast ->
if hadPodcast then
cmd.CommandText <- """
UPDATE web_log_feed_podcast
SET title = @title,
subtitle = @subtitle,
items_in_feed = @itemsInFeed,
summary = @summary,
displayed_author = @displayedAuthor,
email = @email,
image_url = @imageUrl,
apple_category = @appleCategory,
apple_subcategory = @appleSubcategory,
explicit = @explicit,
default_media_type = @defaultMediaType,
media_base_url = @mediaBaseUrl,
podcast_guid = @podcastGuid,
funding_url = @fundingUrl,
funding_text = @fundingText,
medium = @medium
WHERE feed_id = @feedId"""
cmd.Parameters.Clear ()
addPodcastParameters cmd it.Id podcast
do! write cmd
else
do! addPodcast it.Id podcast
| None ->
if hadPodcast then
cmd.CommandText <- "DELETE FROM web_log_feed_podcast WHERE feed_id = @id"
cmd.Parameters.Clear ()
cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString it.Id) |> ignore
do! write cmd
else
()
})
|> Task.WhenAll
|> ignore
}
// IMPLEMENTATION FUNCTIONS
type SQLiteWebLogData(conn: SqliteConnection, log: ILogger) =
/// Add a web log
let add webLog = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO web_log (
id, name, slug, subtitle, default_page, posts_per_page, theme_id, url_base, time_zone, auto_htmx,
uploads, is_feed_enabled, feed_name, items_in_feed, is_category_enabled, is_tag_enabled, copyright
) VALUES (
@id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx,
@uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright
)"""
addWebLogParameters cmd webLog
do! write cmd
do! updateCustomFeeds webLog
}
let add webLog =
log.LogTrace "WebLog.add"
conn.insert<WebLog> Table.WebLog webLog
/// Retrieve all web logs
let all () = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log"
use! rdr = cmd.ExecuteReaderAsync ()
let! webLogs =
toList Map.toWebLog rdr
|> List.map (fun webLog -> backgroundTask { return! appendCustomFeeds webLog })
|> Task.WhenAll
return List.ofArray webLogs
}
let all () =
log.LogTrace "WebLog.all"
conn.findAll<WebLog> Table.WebLog
/// Delete a web log by its ID
let delete webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
addWebLogId cmd webLogId
let subQuery table = $"(SELECT id FROM {table} WHERE web_log_id = @webLogId)"
let postSubQuery = subQuery "post"
let pageSubQuery = subQuery "page"
cmd.CommandText <- $"""
DELETE FROM post_comment WHERE post_id IN {postSubQuery};
DELETE FROM post_revision WHERE post_id IN {postSubQuery};
DELETE FROM post_permalink WHERE post_id IN {postSubQuery};
DELETE FROM post_episode WHERE post_id IN {postSubQuery};
DELETE FROM post_tag WHERE post_id IN {postSubQuery};
DELETE FROM post_category WHERE post_id IN {postSubQuery};
DELETE FROM post_meta WHERE post_id IN {postSubQuery};
DELETE FROM post WHERE web_log_id = @webLogId;
DELETE FROM page_revision WHERE page_id IN {pageSubQuery};
DELETE FROM page_permalink WHERE page_id IN {pageSubQuery};
DELETE FROM page_meta WHERE page_id IN {pageSubQuery};
DELETE FROM page WHERE web_log_id = @webLogId;
DELETE FROM category WHERE web_log_id = @webLogId;
DELETE FROM tag_map WHERE web_log_id = @webLogId;
DELETE FROM upload WHERE web_log_id = @webLogId;
DELETE FROM web_log_user WHERE web_log_id = @webLogId;
DELETE FROM web_log_feed_podcast WHERE feed_id IN {subQuery "web_log_feed"};
DELETE FROM web_log_feed WHERE web_log_id = @webLogId;
DELETE FROM web_log WHERE id = @webLogId"""
do! write cmd
}
let delete webLogId =
log.LogTrace "WebLog.delete"
let webLogMatches = Query.whereByField (Field.EQ "WebLogId" "") "@webLogId"
let subQuery table = $"(SELECT data ->> 'Id' FROM {table} WHERE {webLogMatches})"
Custom.nonQuery
$"""DELETE FROM {Table.PostComment} WHERE data ->> 'PostId' IN {subQuery Table.Post};
DELETE FROM {Table.PostRevision} WHERE post_id IN {subQuery Table.Post};
DELETE FROM {Table.PageRevision} WHERE page_id IN {subQuery Table.Page};
DELETE FROM {Table.Post} WHERE {webLogMatches};
DELETE FROM {Table.Page} WHERE {webLogMatches};
DELETE FROM {Table.Category} WHERE {webLogMatches};
DELETE FROM {Table.TagMap} WHERE {webLogMatches};
DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId;
DELETE FROM {Table.WebLogUser} WHERE {webLogMatches};
DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}"""
[ webLogParam webLogId ]
/// Find a web log by its host (URL base)
let findByHost (url : string) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log WHERE url_base = @urlBase"
cmd.Parameters.AddWithValue ("@urlBase", url) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then
let! webLog = appendCustomFeeds (Map.toWebLog rdr)
return Some webLog
else
return None
}
let findByHost (url: string) =
log.LogTrace "WebLog.findByHost"
conn.findFirstByField<WebLog> Table.WebLog (Field.EQ (nameof WebLog.Empty.UrlBase) url)
/// Find a web log by its ID
let findById webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log WHERE id = @webLogId"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then
let! webLog = appendCustomFeeds (Map.toWebLog rdr)
return Some webLog
else
return None
}
let findById webLogId =
log.LogTrace "WebLog.findById"
conn.findById<WebLogId, WebLog> Table.WebLog webLogId
/// Update settings for a web log
let updateSettings webLog = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log
SET name = @name,
slug = @slug,
subtitle = @subtitle,
default_page = @defaultPage,
posts_per_page = @postsPerPage,
theme_id = @themeId,
url_base = @urlBase,
time_zone = @timeZone,
auto_htmx = @autoHtmx,
uploads = @uploads,
is_feed_enabled = @isFeedEnabled,
feed_name = @feedName,
items_in_feed = @itemsInFeed,
is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled,
copyright = @copyright
WHERE id = @id"""
addWebLogParameters cmd webLog
do! write cmd
}
/// Update redirect rules for a web log
let updateRedirectRules (webLog: WebLog) =
log.LogTrace "WebLog.updateRedirectRules"
conn.patchById Table.WebLog webLog.Id {| RedirectRules = webLog.RedirectRules |}
/// Update RSS options for a web log
let updateRssOptions webLog = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log
SET is_feed_enabled = @isFeedEnabled,
feed_name = @feedName,
items_in_feed = @itemsInFeed,
is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled,
copyright = @copyright
WHERE id = @id"""
addWebLogRssParameters cmd webLog
do! write cmd
do! updateCustomFeeds webLog
}
let updateRssOptions (webLog: WebLog) =
log.LogTrace "WebLog.updateRssOptions"
conn.patchById Table.WebLog webLog.Id {| Rss = webLog.Rss |}
/// Update settings for a web log
let updateSettings (webLog: WebLog) =
log.LogTrace "WebLog.updateSettings"
conn.updateById Table.WebLog webLog.Id webLog
interface IWebLogData with
member _.Add webLog = add webLog
@@ -330,5 +69,6 @@ type SQLiteWebLogData (conn : SqliteConnection) =
member _.Delete webLogId = delete webLogId
member _.FindByHost url = findByHost url
member _.FindById webLogId = findById webLogId
member _.UpdateSettings webLog = updateSettings webLog
member _.UpdateRedirectRules webLog = updateRedirectRules webLog
member _.UpdateRssOptions webLog = updateRssOptions webLog
member _.UpdateSettings webLog = updateSettings webLog

View File

@@ -1,154 +1,86 @@
namespace MyWebLog.Data.SQLite
open System
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data
/// SQLite myWebLog user data implementation
type SQLiteWebLogUserData (conn : SqliteConnection) =
// SUPPORT FUNCTIONS
/// Add parameters for web log user INSERT or UPDATE statements
let addWebLogUserParameters (cmd : SqliteCommand) (user : WebLogUser) =
[ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString user.Id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString user.WebLogId)
cmd.Parameters.AddWithValue ("@email", user.Email)
cmd.Parameters.AddWithValue ("@firstName", user.FirstName)
cmd.Parameters.AddWithValue ("@lastName", user.LastName)
cmd.Parameters.AddWithValue ("@preferredName", user.PreferredName)
cmd.Parameters.AddWithValue ("@passwordHash", user.PasswordHash)
cmd.Parameters.AddWithValue ("@salt", user.Salt)
cmd.Parameters.AddWithValue ("@url", maybe user.Url)
cmd.Parameters.AddWithValue ("@accessLevel", AccessLevel.toString user.AccessLevel)
cmd.Parameters.AddWithValue ("@createdOn", user.CreatedOn)
cmd.Parameters.AddWithValue ("@lastSeenOn", maybe user.LastSeenOn)
] |> ignore
// IMPLEMENTATION FUNCTIONS
type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) =
/// Add a user
let add user = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO web_log_user (
id, web_log_id, email, first_name, last_name, preferred_name, password_hash, salt, url, access_level,
created_on, last_seen_on
) VALUES (
@id, @webLogId, @email, @firstName, @lastName, @preferredName, @passwordHash, @salt, @url, @accessLevel,
@createdOn, @lastSeenOn
)"""
addWebLogUserParameters cmd user
do! write cmd
}
let add user =
log.LogTrace "WebLogUser.add"
conn.insert<WebLogUser> Table.WebLogUser user
/// Find a user by their ID for the given web log
let findById userId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return Helpers.verifyWebLog<WebLogUser> webLogId (fun u -> u.WebLogId) Map.toWebLogUser rdr
}
let findById userId webLogId =
log.LogTrace "WebLogUser.findById"
Document.findByIdAndWebLog<WebLogUserId, WebLogUser> Table.WebLogUser userId webLogId conn
/// Delete a user if they have no posts or pages
let delete userId webLogId = backgroundTask {
log.LogTrace "WebLogUser.delete"
match! findById userId webLogId with
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(id) FROM page WHERE author_id = @userId"
cmd.Parameters.AddWithValue ("@userId", WebLogUserId.toString userId) |> ignore
let! pageCount = count cmd
cmd.CommandText <- "SELECT COUNT(id) FROM post WHERE author_id = @userId"
let! postCount = count cmd
let! pageCount = conn.countByField Table.Page (Field.EQ (nameof Page.Empty.AuthorId) (string userId))
let! postCount = conn.countByField Table.Post (Field.EQ (nameof Post.Empty.AuthorId) (string userId))
if pageCount + postCount > 0 then
return Error "User has pages or posts; cannot delete"
else
cmd.CommandText <- "DELETE FROM web_log_user WHERE id = @userId"
let! _ = cmd.ExecuteNonQueryAsync ()
do! conn.deleteById Table.WebLogUser userId
return Ok true
| None -> return Error "User does not exist"
}
/// Find a user by their e-mail address for the given web log
let findByEmail (email : string) webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND email = @email"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@email", email) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toWebLogUser rdr) else None
}
let findByEmail (email: string) webLogId =
log.LogTrace "WebLogUser.findByEmail"
let emailParam = Field.EQ (nameof WebLogUser.Empty.Email) email
conn.customSingle
$"""{Document.Query.selectByWebLog Table.WebLogUser}
AND {Query.whereByField emailParam "@email"}"""
(addFieldParam "@email" emailParam [ webLogParam webLogId ])
fromData<WebLogUser>
/// Get all users for the given web log
let findByWebLog webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId ORDER BY LOWER(preferred_name)"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toWebLogUser rdr
log.LogTrace "WebLogUser.findByWebLog"
let! users = Document.findByWebLog<WebLogUser> Table.WebLogUser webLogId conn
return users |> List.sortBy _.PreferredName.ToLowerInvariant()
}
/// Find the names of users by their IDs for the given web log
let findNames webLogId userIds = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND id IN ("
userIds
|> List.iteri (fun idx userId ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@id{idx}"
cmd.Parameters.AddWithValue ($"@id{idx}", WebLogUserId.toString userId) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return
toList Map.toWebLogUser rdr
|> List.map (fun u -> { Name = WebLogUserId.toString u.Id; Value = WebLogUser.displayName u })
}
let findNames webLogId (userIds: WebLogUserId list) =
log.LogTrace "WebLogUser.findNames"
let nameSql, nameParams = inClause $"AND data ->> '{nameof WebLogUser.Empty.Id}'" "id" string userIds
conn.customList
$"{Document.Query.selectByWebLog Table.WebLogUser} {nameSql}"
(webLogParam webLogId :: nameParams)
(fun rdr ->
let user = fromData<WebLogUser> rdr
{ Name = string user.Id; Value = user.DisplayName })
/// Restore users from a backup
let restore users = backgroundTask {
for user in users do
do! add user
log.LogTrace "WebLogUser.restore"
for user in users do do! add user
}
/// Set a user's last seen date/time to now
let setLastSeen userId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log_user
SET last_seen_on = @lastSeenOn
WHERE id = @id
AND web_log_id = @webLogId"""
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId)
cmd.Parameters.AddWithValue ("@lastSeenOn", DateTime.UtcNow)
] |> ignore
let! _ = cmd.ExecuteNonQueryAsync ()
()
log.LogTrace "WebLogUser.setLastSeen"
match! findById userId webLogId with
| Some _ -> do! conn.patchById Table.WebLogUser userId {| LastSeenOn = Noda.now () |}
| None -> ()
}
/// Update a user
let update user = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log_user
SET email = @email,
first_name = @firstName,
last_name = @lastName,
preferred_name = @preferredName,
password_hash = @passwordHash,
salt = @salt,
url = @url,
access_level = @accessLevel,
created_on = @createdOn,
last_seen_on = @lastSeenOn
WHERE id = @id
AND web_log_id = @webLogId"""
addWebLogUserParameters cmd user
do! write cmd
}
let update (user: WebLogUser) =
log.LogTrace "WebLogUser.update"
conn.updateById Table.WebLogUser user.Id user
interface IWebLogUserData with
member _.Add user = add user

View File

@@ -1,385 +1,497 @@
namespace MyWebLog.Data
open System
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data.SQLite
open Newtonsoft.Json
open NodaTime
/// SQLite myWebLog data implementation
type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSerializer) =
/// Determine if the given table exists
let tableExists (table : string) = backgroundTask {
/// Create tables (and their associated indexes) if they do not exist
let ensureTables () = backgroundTask {
Configuration.useSerializer (Utils.createDocumentSerializer ser)
let! tables = conn.customList "SELECT name FROM sqlite_master WHERE type = 'table'" [] _.GetString(0)
let needsTable table =
not (List.contains table tables)
let jsonTable table =
$"{Query.Definition.ensureTable table}; {Query.Definition.ensureKey table}"
let tasks =
seq {
// Theme tables
if needsTable Table.Theme then jsonTable Table.Theme
if needsTable Table.ThemeAsset then
$"CREATE TABLE {Table.ThemeAsset} (
theme_id TEXT NOT NULL,
path TEXT NOT NULL,
updated_on TEXT NOT NULL,
data BLOB NOT NULL,
PRIMARY KEY (theme_id, path))"
// Web log table
if needsTable Table.WebLog then jsonTable Table.WebLog
// Category table
if needsTable Table.Category then
$"""{jsonTable Table.Category};
{Query.Definition.ensureIndexOn Table.Category "web_log" [ nameof Category.Empty.WebLogId ]}"""
// Web log user table
if needsTable Table.WebLogUser then
$"""{jsonTable Table.WebLogUser};
{Query.Definition.ensureIndexOn
Table.WebLogUser
"email"
[ nameof WebLogUser.Empty.WebLogId; nameof WebLogUser.Empty.Email ]}"""
// Page tables
if needsTable Table.Page then
$"""{jsonTable Table.Page};
{Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ]};
{Query.Definition.ensureIndexOn
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]}"""
if needsTable Table.PageRevision then
$"CREATE TABLE {Table.PageRevision} (
page_id TEXT NOT NULL,
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))"
// Post tables
if needsTable Table.Post then
$"""{jsonTable Table.Post};
{Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ]};
{Query.Definition.ensureIndexOn
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]};
{Query.Definition.ensureIndexOn
Table.Post
"status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]}"""
// TODO: index categories by post?
if needsTable Table.PostRevision then
$"CREATE TABLE {Table.PostRevision} (
post_id TEXT NOT NULL,
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))"
if needsTable Table.PostComment then
$"""{jsonTable Table.PostComment};
{Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ]}"""
// Tag map table
if needsTable Table.TagMap then
$"""{jsonTable Table.TagMap};
{Query.Definition.ensureIndexOn
Table.TagMap "url" [ nameof TagMap.Empty.WebLogId; nameof TagMap.Empty.UrlValue ]}"""
// Uploaded file table
if needsTable Table.Upload then
$"CREATE TABLE {Table.Upload} (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL,
path TEXT NOT NULL,
updated_on TEXT NOT NULL,
data BLOB NOT NULL);
CREATE INDEX idx_{Table.Upload}_path ON {Table.Upload} (web_log_id, path)"
// Database version table
if needsTable Table.DbVersion then
$"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY);
INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')"
}
|> Seq.map (fun sql ->
log.LogInformation $"""Creating {(sql.Replace("IF NOT EXISTS ", "").Split ' ')[2]} table..."""
conn.customNonQuery sql [])
let! _ = Task.WhenAll tasks
()
}
/// Set the database version to the specified version
let setDbVersion version =
conn.customNonQuery $"DELETE FROM {Table.DbVersion}; INSERT INTO {Table.DbVersion} VALUES ('%s{version}')" []
/// Implement the changes between v2-rc1 and v2-rc2
let migrateV2Rc1ToV2Rc2 () = backgroundTask {
let logStep = Utils.Migration.logStep log "v2-rc1 to v2-rc2"
// Move meta items, podcast settings, and episode details to JSON-encoded text fields
use cmd = conn.CreateCommand()
cmd.CommandText <- "SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = @table"
cmd.Parameters.AddWithValue ("@table", table) |> ignore
let! count = count cmd
return count = 1
logStep "Adding new columns"
cmd.CommandText <-
"ALTER TABLE web_log_feed ADD COLUMN podcast TEXT;
ALTER TABLE page ADD COLUMN meta_items TEXT;
ALTER TABLE post ADD COLUMN meta_items TEXT;
ALTER TABLE post ADD COLUMN episode TEXT"
do! write cmd
logStep "Migrating meta items"
let migrateMeta entity = backgroundTask {
cmd.CommandText <- $"SELECT * FROM %s{entity}_meta"
use! metaRdr = cmd.ExecuteReaderAsync()
let allMetas =
seq {
while metaRdr.Read() do
Map.getString $"{entity}_id" metaRdr,
{ Name = Map.getString "name" metaRdr; Value = Map.getString "value" metaRdr }
} |> List.ofSeq
metaRdr.Close ()
let metas =
allMetas
|> List.map fst
|> List.distinct
|> List.map (fun it -> it, allMetas |> List.filter (fun meta -> fst meta = it))
metas
|> List.iter (fun (entityId, items) ->
cmd.CommandText <-
"UPDATE post
SET meta_items = @metaItems
WHERE id = @postId"
[ cmd.Parameters.AddWithValue("@metaItems", Utils.serialize ser items)
cmd.Parameters.AddWithValue("@id", entityId) ] |> ignore
let _ = cmd.ExecuteNonQuery()
cmd.Parameters.Clear())
}
do! migrateMeta "page"
do! migrateMeta "post"
logStep "Migrating podcasts and episodes"
cmd.CommandText <- "SELECT * FROM web_log_feed_podcast"
use! podcastRdr = cmd.ExecuteReaderAsync()
let podcasts =
seq {
while podcastRdr.Read() do
CustomFeedId (Map.getString "feed_id" podcastRdr),
{ Title = Map.getString "title" podcastRdr
Subtitle = Map.tryString "subtitle" podcastRdr
ItemsInFeed = Map.getInt "items_in_feed" podcastRdr
Summary = Map.getString "summary" podcastRdr
DisplayedAuthor = Map.getString "displayed_author" podcastRdr
Email = Map.getString "email" podcastRdr
ImageUrl = Map.getString "image_url" podcastRdr |> Permalink
AppleCategory = Map.getString "apple_category" podcastRdr
AppleSubcategory = Map.tryString "apple_subcategory" podcastRdr
Explicit = Map.getString "explicit" podcastRdr |> ExplicitRating.Parse
DefaultMediaType = Map.tryString "default_media_type" podcastRdr
MediaBaseUrl = Map.tryString "media_base_url" podcastRdr
PodcastGuid = Map.tryGuid "podcast_guid" podcastRdr
FundingUrl = Map.tryString "funding_url" podcastRdr
FundingText = Map.tryString "funding_text" podcastRdr
Medium = Map.tryString "medium" podcastRdr
|> Option.map PodcastMedium.Parse }
} |> List.ofSeq
podcastRdr.Close()
podcasts
|> List.iter (fun (feedId, podcast) ->
cmd.CommandText <- "UPDATE web_log_feed SET podcast = @podcast WHERE id = @id"
[ cmd.Parameters.AddWithValue("@podcast", Utils.serialize ser podcast)
cmd.Parameters.AddWithValue("@id", string feedId) ] |> ignore
let _ = cmd.ExecuteNonQuery()
cmd.Parameters.Clear())
cmd.CommandText <- "SELECT * FROM post_episode"
use! epRdr = cmd.ExecuteReaderAsync()
let episodes =
seq {
while epRdr.Read() do
PostId (Map.getString "post_id" epRdr),
{ Media = Map.getString "media" epRdr
Length = Map.getLong "length" epRdr
Duration = Map.tryTimeSpan "duration" epRdr
|> Option.map Duration.FromTimeSpan
MediaType = Map.tryString "media_type" epRdr
ImageUrl = Map.tryString "image_url" epRdr
Subtitle = Map.tryString "subtitle" epRdr
Explicit = Map.tryString "explicit" epRdr
|> Option.map ExplicitRating.Parse
Chapters = Map.tryString "chapters" epRdr
|> Option.map (Utils.deserialize<Chapter list> ser)
ChapterFile = Map.tryString "chapter_file" epRdr
ChapterType = Map.tryString "chapter_type" epRdr
ChapterWaypoints = None
TranscriptUrl = Map.tryString "transcript_url" epRdr
TranscriptType = Map.tryString "transcript_type" epRdr
TranscriptLang = Map.tryString "transcript_lang" epRdr
TranscriptCaptions = Map.tryBoolean "transcript_captions" epRdr
SeasonNumber = Map.tryInt "season_number" epRdr
SeasonDescription = Map.tryString "season_description" epRdr
EpisodeNumber = Map.tryString "episode_number" epRdr |> Option.map Double.Parse
EpisodeDescription = Map.tryString "episode_description" epRdr }
} |> List.ofSeq
epRdr.Close()
episodes
|> List.iter (fun (postId, episode) ->
cmd.CommandText <- "UPDATE post SET episode = @episode WHERE id = @id"
[ cmd.Parameters.AddWithValue("@episode", Utils.serialize ser episode)
cmd.Parameters.AddWithValue("@id", string postId) ] |> ignore
let _ = cmd.ExecuteNonQuery()
cmd.Parameters.Clear())
logStep "Migrating dates/times"
let inst (dt: DateTime) =
DateTime(dt.Ticks, DateTimeKind.Utc)
|> (Instant.FromDateTimeUtc >> Noda.toSecondsPrecision)
// page.updated_on, page.published_on
cmd.CommandText <- "SELECT id, updated_on, published_on FROM page"
use! pageRdr = cmd.ExecuteReaderAsync()
let toUpdate =
seq {
while pageRdr.Read() do
Map.getString "id" pageRdr,
inst (Map.getDateTime "updated_on" pageRdr),
inst (Map.getDateTime "published_on" pageRdr)
} |> List.ofSeq
pageRdr.Close()
cmd.CommandText <- "UPDATE page SET updated_on = @updatedOn, published_on = @publishedOn WHERE id = @id"
[ cmd.Parameters.Add("@id", SqliteType.Text)
cmd.Parameters.Add("@updatedOn", SqliteType.Text)
cmd.Parameters.Add("@publishedOn", SqliteType.Text) ] |> ignore
toUpdate
|> List.iter (fun (pageId, updatedOn, publishedOn) ->
cmd.Parameters["@id" ].Value <- pageId
cmd.Parameters["@updatedOn" ].Value <- instantParam updatedOn
cmd.Parameters["@publishedOn"].Value <- instantParam publishedOn
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
// page_revision.as_of
cmd.CommandText <- "SELECT * FROM page_revision"
use! pageRevRdr = cmd.ExecuteReaderAsync()
let toUpdate =
seq {
while pageRevRdr.Read() do
let asOf = Map.getDateTime "as_of" pageRevRdr
Map.getString "page_id" pageRevRdr, asOf, inst asOf, Map.getString "revision_text" pageRevRdr
} |> List.ofSeq
pageRevRdr.Close ()
cmd.CommandText <-
"DELETE FROM page_revision WHERE page_id = @pageId AND as_of = @oldAsOf;
INSERT INTO page_revision (page_id, as_of, revision_text) VALUES (@pageId, @asOf, @text)"
[ cmd.Parameters.Add("@pageId", SqliteType.Text)
cmd.Parameters.Add("@oldAsOf", SqliteType.Text)
cmd.Parameters.Add("@asOf", SqliteType.Text)
cmd.Parameters.Add("@text", SqliteType.Text) ] |> ignore
toUpdate
|> List.iter (fun (pageId, oldAsOf, asOf, text) ->
cmd.Parameters["@pageId" ].Value <- pageId
cmd.Parameters["@oldAsOf"].Value <- oldAsOf
cmd.Parameters["@asOf" ].Value <- instantParam asOf
cmd.Parameters["@text" ].Value <- text
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
// post.updated_on, post.published_on (opt)
cmd.CommandText <- "SELECT id, updated_on, published_on FROM post"
use! postRdr = cmd.ExecuteReaderAsync()
let toUpdate =
seq {
while postRdr.Read() do
Map.getString "id" postRdr,
inst (Map.getDateTime "updated_on" postRdr),
(Map.tryDateTime "published_on" postRdr |> Option.map inst)
} |> List.ofSeq
postRdr.Close()
cmd.CommandText <- "UPDATE post SET updated_on = @updatedOn, published_on = @publishedOn WHERE id = @id"
[ cmd.Parameters.Add("@id", SqliteType.Text)
cmd.Parameters.Add("@updatedOn", SqliteType.Text)
cmd.Parameters.Add("@publishedOn", SqliteType.Text) ] |> ignore
toUpdate
|> List.iter (fun (postId, updatedOn, publishedOn) ->
cmd.Parameters["@id" ].Value <- postId
cmd.Parameters["@updatedOn" ].Value <- instantParam updatedOn
cmd.Parameters["@publishedOn"].Value <- maybeInstant publishedOn
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
// post_revision.as_of
cmd.CommandText <- "SELECT * FROM post_revision"
use! postRevRdr = cmd.ExecuteReaderAsync()
let toUpdate =
seq {
while postRevRdr.Read() do
let asOf = Map.getDateTime "as_of" postRevRdr
Map.getString "post_id" postRevRdr, asOf, inst asOf, Map.getString "revision_text" postRevRdr
} |> List.ofSeq
postRevRdr.Close()
cmd.CommandText <-
"DELETE FROM post_revision WHERE post_id = @postId AND as_of = @oldAsOf;
INSERT INTO post_revision (post_id, as_of, revision_text) VALUES (@postId, @asOf, @text)"
[ cmd.Parameters.Add("@postId", SqliteType.Text)
cmd.Parameters.Add("@oldAsOf", SqliteType.Text)
cmd.Parameters.Add("@asOf", SqliteType.Text)
cmd.Parameters.Add("@text", SqliteType.Text) ] |> ignore
toUpdate
|> List.iter (fun (postId, oldAsOf, asOf, text) ->
cmd.Parameters["@postId" ].Value <- postId
cmd.Parameters["@oldAsOf"].Value <- oldAsOf
cmd.Parameters["@asOf" ].Value <- instantParam asOf
cmd.Parameters["@text" ].Value <- text
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
// theme_asset.updated_on
cmd.CommandText <- "SELECT theme_id, path, updated_on FROM theme_asset"
use! assetRdr = cmd.ExecuteReaderAsync()
let toUpdate =
seq {
while assetRdr.Read() do
Map.getString "theme_id" assetRdr, Map.getString "path" assetRdr,
inst (Map.getDateTime "updated_on" assetRdr)
} |> List.ofSeq
assetRdr.Close ()
cmd.CommandText <- "UPDATE theme_asset SET updated_on = @updatedOn WHERE theme_id = @themeId AND path = @path"
[ cmd.Parameters.Add("@updatedOn", SqliteType.Text)
cmd.Parameters.Add("@themeId", SqliteType.Text)
cmd.Parameters.Add("@path", SqliteType.Text) ] |> ignore
toUpdate
|> List.iter (fun (themeId, path, updatedOn) ->
cmd.Parameters["@themeId" ].Value <- themeId
cmd.Parameters["@path" ].Value <- path
cmd.Parameters["@updatedOn"].Value <- instantParam updatedOn
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
// upload.updated_on
cmd.CommandText <- "SELECT id, updated_on FROM upload"
use! upRdr = cmd.ExecuteReaderAsync()
let toUpdate =
seq {
while upRdr.Read() do
Map.getString "id" upRdr, inst (Map.getDateTime "updated_on" upRdr)
} |> List.ofSeq
upRdr.Close ()
cmd.CommandText <- "UPDATE upload SET updated_on = @updatedOn WHERE id = @id"
[ cmd.Parameters.Add("@updatedOn", SqliteType.Text)
cmd.Parameters.Add("@id", SqliteType.Text) ] |> ignore
toUpdate
|> List.iter (fun (upId, updatedOn) ->
cmd.Parameters["@id" ].Value <- upId
cmd.Parameters["@updatedOn"].Value <- instantParam updatedOn
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
// web_log_user.created_on, web_log_user.last_seen_on (opt)
cmd.CommandText <- "SELECT id, created_on, last_seen_on FROM web_log_user"
use! userRdr = cmd.ExecuteReaderAsync()
let toUpdate =
seq {
while userRdr.Read() do
Map.getString "id" userRdr,
inst (Map.getDateTime "created_on" userRdr),
(Map.tryDateTime "last_seen_on" userRdr |> Option.map inst)
} |> List.ofSeq
userRdr.Close()
cmd.CommandText <- "UPDATE web_log_user SET created_on = @createdOn, last_seen_on = @lastSeenOn WHERE id = @id"
[ cmd.Parameters.Add("@id", SqliteType.Text)
cmd.Parameters.Add("@createdOn", SqliteType.Text)
cmd.Parameters.Add("@lastSeenOn", SqliteType.Text) ] |> ignore
toUpdate
|> List.iter (fun (userId, createdOn, lastSeenOn) ->
cmd.Parameters["@id" ].Value <- userId
cmd.Parameters["@createdOn" ].Value <- instantParam createdOn
cmd.Parameters["@lastSeenOn"].Value <- maybeInstant lastSeenOn
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
conn.Close()
conn.Open()
logStep "Dropping old tables and columns"
cmd.CommandText <-
"ALTER TABLE web_log_user DROP COLUMN salt;
DROP TABLE post_episode;
DROP TABLE post_meta;
DROP TABLE page_meta;
DROP TABLE web_log_feed_podcast"
do! write cmd
logStep "Setting database version to v2-rc2"
do! setDbVersion "v2-rc2"
}
/// Migrate from v2-rc2 to v2
let migrateV2Rc2ToV2 () = backgroundTask {
Utils.Migration.logStep log "v2-rc2 to v2" "Setting database version; no migration required"
do! setDbVersion "v2"
}
/// Migrate from v2 to v2.1
let migrateV2ToV2point1 () = backgroundTask {
let! webLogs =
Custom.list $"SELECT url_base, slug FROM {Table.WebLog}" [] (fun rdr -> rdr.GetString(0), rdr.GetString(1))
Utils.Migration.backupAndRestoreRequired log "v2" "v2.1" webLogs
}
/// Migrate from v2.1 to v2.1.1
let migrateV2point1ToV2point1point1 () = backgroundTask {
Utils.Migration.logStep log "v2.1 to v2.1.1" "Setting database version; no migration required"
do! setDbVersion "v2.1.1"
}
/// Migrate from v2.1.1 to v2.2
let migrateV2point1point1ToV2point2 () = backgroundTask {
Utils.Migration.logStep log "v2.1.1 to v2.2" "Setting e-mail to lowercase"
do! Custom.nonQuery $"UPDATE {Table.WebLogUser} SET data = json_set(data, '$.Email', lower(data->>'Email'))" []
Utils.Migration.logStep log "v2.1.1 to v2.2" "Setting database version to v2.2"
do! setDbVersion "v2.2"
}
/// Migrate data among versions (up only)
let migrate version = backgroundTask {
let mutable v = defaultArg version ""
if v = "v2-rc1" then
do! migrateV2Rc1ToV2Rc2 ()
v <- "v2-rc2"
if v = "v2-rc2" then
do! migrateV2Rc2ToV2 ()
v <- "v2"
if v = "v2" then
do! migrateV2ToV2point1 ()
v <- "v2.1"
if v = "v2.1" then
do! migrateV2point1ToV2point1point1 ()
v <- "v2.1.1"
if v = "v2.1.1" then
do! migrateV2point1point1ToV2point2 ()
v <- "v2.2"
if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
do! setDbVersion Utils.Migration.currentDbVersion
}
/// The connection for this instance
member _.Conn = conn
/// Make a SQLite connection ready to execute commends
static member setUpConnection (conn : SqliteConnection) = backgroundTask {
do! conn.OpenAsync ()
use cmd = conn.CreateCommand ()
cmd.CommandText <- "PRAGMA foreign_keys = TRUE"
let! _ = cmd.ExecuteNonQueryAsync ()
()
}
interface IData with
member _.Category = SQLiteCategoryData conn
member _.Page = SQLitePageData conn
member _.Post = SQLitePostData conn
member _.TagMap = SQLiteTagMapData conn
member _.Theme = SQLiteThemeData conn
member _.ThemeAsset = SQLiteThemeAssetData conn
member _.Upload = SQLiteUploadData conn
member _.WebLog = SQLiteWebLogData conn
member _.WebLogUser = SQLiteWebLogUserData conn
member _.Category = SQLiteCategoryData (conn, ser, log)
member _.Page = SQLitePageData (conn, log)
member _.Post = SQLitePostData (conn, log)
member _.TagMap = SQLiteTagMapData (conn, log)
member _.Theme = SQLiteThemeData (conn, log)
member _.ThemeAsset = SQLiteThemeAssetData (conn, log)
member _.Upload = SQLiteUploadData (conn, log)
member _.WebLog = SQLiteWebLogData (conn, log)
member _.WebLogUser = SQLiteWebLogUserData (conn, log)
member _.Serializer = ser
member _.StartUp () = backgroundTask {
use cmd = conn.CreateCommand ()
// Theme tables
match! tableExists "theme" with
| true -> ()
| false ->
log.LogInformation "Creating theme table..."
cmd.CommandText <- """
CREATE TABLE theme (
id TEXT PRIMARY KEY,
name TEXT NOT NULL,
version TEXT NOT NULL)"""
do! write cmd
match! tableExists "theme_template" with
| true -> ()
| false ->
log.LogInformation "Creating theme_template table..."
cmd.CommandText <- """
CREATE TABLE theme_template (
theme_id TEXT NOT NULL REFERENCES theme (id),
name TEXT NOT NULL,
template TEXT NOT NULL,
PRIMARY KEY (theme_id, name))"""
do! write cmd
match! tableExists "theme_asset" with
| true -> ()
| false ->
log.LogInformation "Creating theme_asset table..."
cmd.CommandText <- """
CREATE TABLE theme_asset (
theme_id TEXT NOT NULL REFERENCES theme (id),
path TEXT NOT NULL,
updated_on TEXT NOT NULL,
data BLOB NOT NULL,
PRIMARY KEY (theme_id, path))"""
do! write cmd
// Web log tables
match! tableExists "web_log" with
| true -> ()
| false ->
log.LogInformation "Creating web_log table..."
cmd.CommandText <- """
CREATE TABLE web_log (
id TEXT PRIMARY KEY,
name TEXT NOT NULL,
slug TEXT NOT NULL,
subtitle TEXT,
default_page TEXT NOT NULL,
posts_per_page INTEGER NOT NULL,
theme_id TEXT NOT NULL REFERENCES theme (id),
url_base TEXT NOT NULL,
time_zone TEXT NOT NULL,
auto_htmx INTEGER NOT NULL DEFAULT 0,
uploads TEXT NOT NULL,
is_feed_enabled INTEGER NOT NULL DEFAULT 0,
feed_name TEXT NOT NULL,
items_in_feed INTEGER,
is_category_enabled INTEGER NOT NULL DEFAULT 0,
is_tag_enabled INTEGER NOT NULL DEFAULT 0,
copyright TEXT);
CREATE INDEX web_log_theme_idx ON web_log (theme_id)"""
do! write cmd
match! tableExists "web_log_feed" with
| true -> ()
| false ->
log.LogInformation "Creating web_log_feed table..."
cmd.CommandText <- """
CREATE TABLE web_log_feed (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
source TEXT NOT NULL,
path TEXT NOT NULL);
CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)"""
do! write cmd
match! tableExists "web_log_feed_podcast" with
| true -> ()
| false ->
log.LogInformation "Creating web_log_feed_podcast table..."
cmd.CommandText <- """
CREATE TABLE web_log_feed_podcast (
feed_id TEXT PRIMARY KEY REFERENCES web_log_feed (id),
title TEXT NOT NULL,
subtitle TEXT,
items_in_feed INTEGER NOT NULL,
summary TEXT NOT NULL,
displayed_author TEXT NOT NULL,
email TEXT NOT NULL,
image_url TEXT NOT NULL,
apple_category TEXT NOT NULL,
apple_subcategory TEXT,
explicit TEXT NOT NULL,
default_media_type TEXT,
media_base_url TEXT,
podcast_guid TEXT,
funding_url TEXT,
funding_text TEXT,
medium TEXT)"""
do! write cmd
// Category table
match! tableExists "category" with
| true -> ()
| false ->
log.LogInformation "Creating category table..."
cmd.CommandText <- """
CREATE TABLE category (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
name TEXT NOT NULL,
slug TEXT NOT NULL,
description TEXT,
parent_id TEXT);
CREATE INDEX category_web_log_idx ON category (web_log_id)"""
do! write cmd
// Web log user table
match! tableExists "web_log_user" with
| true -> ()
| false ->
log.LogInformation "Creating web_log_user table..."
cmd.CommandText <- """
CREATE TABLE web_log_user (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
email TEXT NOT NULL,
first_name TEXT NOT NULL,
last_name TEXT NOT NULL,
preferred_name TEXT NOT NULL,
password_hash TEXT NOT NULL,
salt TEXT NOT NULL,
url TEXT,
access_level TEXT NOT NULL,
created_on TEXT NOT NULL,
last_seen_on TEXT);
CREATE INDEX web_log_user_web_log_idx ON web_log_user (web_log_id);
CREATE INDEX web_log_user_email_idx ON web_log_user (web_log_id, email)"""
do! write cmd
// Page tables
match! tableExists "page" with
| true -> ()
| false ->
log.LogInformation "Creating page table..."
cmd.CommandText <- """
CREATE TABLE page (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (id),
title TEXT NOT NULL,
permalink TEXT NOT NULL,
published_on TEXT NOT NULL,
updated_on TEXT NOT NULL,
is_in_page_list INTEGER NOT NULL DEFAULT 0,
template TEXT,
page_text TEXT NOT NULL);
CREATE INDEX page_web_log_idx ON page (web_log_id);
CREATE INDEX page_author_idx ON page (author_id);
CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)"""
do! write cmd
match! tableExists "page_meta" with
| true -> ()
| false ->
log.LogInformation "Creating page_meta table..."
cmd.CommandText <- """
CREATE TABLE page_meta (
page_id TEXT NOT NULL REFERENCES page (id),
name TEXT NOT NULL,
value TEXT NOT NULL,
PRIMARY KEY (page_id, name, value))"""
do! write cmd
match! tableExists "page_permalink" with
| true -> ()
| false ->
log.LogInformation "Creating page_permalink table..."
cmd.CommandText <- """
CREATE TABLE page_permalink (
page_id TEXT NOT NULL REFERENCES page (id),
permalink TEXT NOT NULL,
PRIMARY KEY (page_id, permalink))"""
do! write cmd
match! tableExists "page_revision" with
| true -> ()
| false ->
log.LogInformation "Creating page_revision table..."
cmd.CommandText <- """
CREATE TABLE page_revision (
page_id TEXT NOT NULL REFERENCES page (id),
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))"""
do! write cmd
// Post tables
match! tableExists "post" with
| true -> ()
| false ->
log.LogInformation "Creating post table..."
cmd.CommandText <- """
CREATE TABLE post (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (id),
status TEXT NOT NULL,
title TEXT NOT NULL,
permalink TEXT NOT NULL,
published_on TEXT,
updated_on TEXT NOT NULL,
template TEXT,
post_text TEXT NOT NULL);
CREATE INDEX post_web_log_idx ON post (web_log_id);
CREATE INDEX post_author_idx ON post (author_id);
CREATE INDEX post_status_idx ON post (web_log_id, status, updated_on);
CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)"""
do! write cmd
match! tableExists "post_category" with
| true -> ()
| false ->
log.LogInformation "Creating post_category table..."
cmd.CommandText <- """
CREATE TABLE post_category (
post_id TEXT NOT NULL REFERENCES post (id),
category_id TEXT NOT NULL REFERENCES category (id),
PRIMARY KEY (post_id, category_id));
CREATE INDEX post_category_category_idx ON post_category (category_id)"""
do! write cmd
match! tableExists "post_episode" with
| true -> ()
| false ->
log.LogInformation "Creating post_episode table..."
cmd.CommandText <- """
CREATE TABLE post_episode (
post_id TEXT PRIMARY KEY REFERENCES post(id),
media TEXT NOT NULL,
length INTEGER NOT NULL,
duration TEXT,
media_type TEXT,
image_url TEXT,
subtitle TEXT,
explicit TEXT,
chapter_file TEXT,
chapter_type TEXT,
transcript_url TEXT,
transcript_type TEXT,
transcript_lang TEXT,
transcript_captions INTEGER,
season_number INTEGER,
season_description TEXT,
episode_number TEXT,
episode_description TEXT)"""
do! write cmd
match! tableExists "post_tag" with
| true -> ()
| false ->
log.LogInformation "Creating post_tag table..."
cmd.CommandText <- """
CREATE TABLE post_tag (
post_id TEXT NOT NULL REFERENCES post (id),
tag TEXT NOT NULL,
PRIMARY KEY (post_id, tag))"""
do! write cmd
match! tableExists "post_meta" with
| true -> ()
| false ->
log.LogInformation "Creating post_meta table..."
cmd.CommandText <- """
CREATE TABLE post_meta (
post_id TEXT NOT NULL REFERENCES post (id),
name TEXT NOT NULL,
value TEXT NOT NULL,
PRIMARY KEY (post_id, name, value))"""
do! write cmd
match! tableExists "post_permalink" with
| true -> ()
| false ->
log.LogInformation "Creating post_permalink table..."
cmd.CommandText <- """
CREATE TABLE post_permalink (
post_id TEXT NOT NULL REFERENCES post (id),
permalink TEXT NOT NULL,
PRIMARY KEY (post_id, permalink))"""
do! write cmd
match! tableExists "post_revision" with
| true -> ()
| false ->
log.LogInformation "Creating post_revision table..."
cmd.CommandText <- """
CREATE TABLE post_revision (
post_id TEXT NOT NULL REFERENCES post (id),
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))"""
do! write cmd
match! tableExists "post_comment" with
| true -> ()
| false ->
log.LogInformation "Creating post_comment table..."
cmd.CommandText <- """
CREATE TABLE post_comment (
id TEXT PRIMARY KEY,
post_id TEXT NOT NULL REFERENCES post(id),
in_reply_to_id TEXT,
name TEXT NOT NULL,
email TEXT NOT NULL,
url TEXT,
status TEXT NOT NULL,
posted_on TEXT NOT NULL,
comment_text TEXT NOT NULL);
CREATE INDEX post_comment_post_idx ON post_comment (post_id)"""
do! write cmd
// Tag map table
match! tableExists "tag_map" with
| true -> ()
| false ->
log.LogInformation "Creating tag_map table..."
cmd.CommandText <- """
CREATE TABLE tag_map (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
tag TEXT NOT NULL,
url_value TEXT NOT NULL);
CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)"""
do! write cmd
// Uploaded file table
match! tableExists "upload" with
| true -> ()
| false ->
log.LogInformation "Creating upload table..."
cmd.CommandText <- """
CREATE TABLE upload (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
path TEXT NOT NULL,
updated_on TEXT NOT NULL,
data BLOB NOT NULL);
CREATE INDEX upload_web_log_idx ON upload (web_log_id);
CREATE INDEX upload_path_idx ON upload (web_log_id, path)"""
do! write cmd
do! ensureTables ()
let! version = conn.customSingle<string> $"SELECT id FROM {Table.DbVersion}" [] _.GetString(0)
do! migrate version
}

View File

@@ -9,14 +9,72 @@ open MyWebLog.ViewModels
let rec orderByHierarchy (cats: Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.Slug
{ Id = CategoryId.toString cat.Id
{ Id = string cat.Id
Slug = fullSlug
Name = cat.Name
Description = cat.Description
ParentNames = Array.ofList parentNames
// Post counts are filled on a second pass
PostCount = 0
}
PostCount = 0 }
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
let diffLists<'T, 'U when 'U: equality> oldItems newItems (f: 'T -> 'U) =
let diff compList = fun item -> not (compList |> List.exists (fun other -> f item = f other))
List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems
/// Find the revisions added and removed
let diffRevisions (oldRevs: Revision list) newRevs =
diffLists oldRevs newRevs (fun rev -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text}")
open MyWebLog.Converters
open Newtonsoft.Json
/// Serialize an object to JSON
let serialize<'T> ser (item: 'T) =
JsonConvert.SerializeObject(item, Json.settings ser)
/// Deserialize a JSON string
let deserialize<'T> (ser: JsonSerializer) value =
JsonConvert.DeserializeObject<'T>(value, Json.settings ser)
open BitBadger.Documents
/// Create a document serializer using the given JsonSerializer
let createDocumentSerializer ser =
{ new IDocumentSerializer with
member _.Serialize<'T>(it: 'T) : string = serialize ser it
member _.Deserialize<'T>(it: string) : 'T = deserialize ser it
}
/// Data migration utilities
module Migration =
open Microsoft.Extensions.Logging
/// The current database version
let currentDbVersion = "v2.2"
/// Log a migration step
let logStep<'T> (log: ILogger<'T>) migration message =
log.LogInformation $"Migrating %s{migration}: %s{message}"
/// Notify the user that a backup/restore
let backupAndRestoreRequired log oldVersion newVersion webLogs =
logStep log $"%s{oldVersion} to %s{newVersion}" "Requires Using Action"
[ "** MANUAL DATABASE UPGRADE REQUIRED **"; ""
$"The data structure changed between {oldVersion} and {newVersion}."
"To migrate your data:"
$" - Use a {oldVersion} executable to back up each web log"
" - Drop all tables from the database"
" - Use this executable to restore each backup"; ""
"Commands to back up all web logs:"
yield! webLogs |> List.map (fun (url, slug) -> $"./myWebLog backup %s{url} {oldVersion}.%s{slug}.json") ]
|> String.concat "\n"
|> log.LogWarning
log.LogCritical "myWebLog will now exit"
exit 1 |> ignore

View File

@@ -1,12 +1,12 @@
namespace MyWebLog
open System
open MyWebLog
open NodaTime
/// A category under which a post may be identified
[<CLIMutable; NoComparison; NoEquality>]
type Category =
{ /// The ID of the category
type Category = {
/// The ID of the category
Id: CategoryId
/// The ID of the web log to which the category belongs
@@ -23,26 +23,22 @@ type Category =
/// The parent ID of this category (if a subcategory)
ParentId: CategoryId option
}
/// Functions to support categories
module Category =
} with
/// An empty category
let empty =
{ Id = CategoryId.empty
WebLogId = WebLogId.empty
static member Empty =
{ Id = CategoryId.Empty
WebLogId = WebLogId.Empty
Name = ""
Slug = ""
Description = None
ParentId = None
}
ParentId = None }
/// A comment on a post
[<CLIMutable; NoComparison; NoEquality>]
type Comment =
{ /// The ID of the comment
type Comment = {
/// The ID of the comment
Id: CommentId
/// The ID of the post to which this comment applies
@@ -64,33 +60,29 @@ type Comment =
Status: CommentStatus
/// When the comment was posted
PostedOn : DateTime
PostedOn: Instant
/// The text of the comment
Text: string
}
/// Functions to support comments
module Comment =
} with
/// An empty comment
let empty =
{ Id = CommentId.empty
PostId = PostId.empty
static member Empty =
{ Id = CommentId.Empty
PostId = PostId.Empty
InReplyToId = None
Name = ""
Email = ""
Url = None
Status = Pending
PostedOn = DateTime.UtcNow
Text = ""
}
PostedOn = Noda.epoch
Text = "" }
/// A page (text not associated with a date/time)
[<CLIMutable; NoComparison; NoEquality>]
type Page =
{ /// The ID of this page
type Page = {
/// The ID of this page
Id: PageId
/// The ID of the web log to which this page belongs
@@ -106,10 +98,10 @@ type Page =
Permalink: Permalink
/// When this page was published
PublishedOn : DateTime
PublishedOn: Instant
/// When this page was last updated
UpdatedOn : DateTime
UpdatedOn: Instant
/// Whether this page shows as part of the web log's navigation
IsInPageList: bool
@@ -128,33 +120,29 @@ type Page =
/// Revisions of this page
Revisions: Revision list
}
/// Functions to support pages
module Page =
} with
/// An empty page
let empty =
{ Id = PageId.empty
WebLogId = WebLogId.empty
AuthorId = WebLogUserId.empty
static member Empty =
{ Id = PageId.Empty
WebLogId = WebLogId.Empty
AuthorId = WebLogUserId.Empty
Title = ""
Permalink = Permalink.empty
PublishedOn = DateTime.MinValue
UpdatedOn = DateTime.MinValue
Permalink = Permalink.Empty
PublishedOn = Noda.epoch
UpdatedOn = Noda.epoch
IsInPageList = false
Template = None
Text = ""
Metadata = []
PriorPermalinks = []
Revisions = []
}
Revisions = [] }
/// A web log post
[<CLIMutable; NoComparison; NoEquality>]
type Post =
{ /// The ID of this post
type Post = {
/// The ID of this post
Id: PostId
/// The ID of the web log to which this post belongs
@@ -173,10 +161,10 @@ type Post =
Permalink: Permalink
/// The instant on which the post was originally published
PublishedOn : DateTime option
PublishedOn: Instant option
/// The instant on which the post was last updated
UpdatedOn : DateTime
UpdatedOn: Instant
/// The template to use in displaying the post
Template: string option
@@ -201,21 +189,18 @@ type Post =
/// The revisions for this post
Revisions: Revision list
}
/// Functions to support posts
module Post =
} with
/// An empty post
let empty =
{ Id = PostId.empty
WebLogId = WebLogId.empty
AuthorId = WebLogUserId.empty
static member Empty =
{ Id = PostId.Empty
WebLogId = WebLogId.Empty
AuthorId = WebLogUserId.Empty
Status = Draft
Title = ""
Permalink = Permalink.empty
Permalink = Permalink.Empty
PublishedOn = None
UpdatedOn = DateTime.MinValue
UpdatedOn = Noda.epoch
Text = ""
Template = None
CategoryIds = []
@@ -223,13 +208,13 @@ module Post =
Episode = None
Metadata = []
PriorPermalinks = []
Revisions = []
}
Revisions = [] }
/// A mapping between a tag and its URL value, used to translate restricted characters (ex. "#1" -> "number-1")
type TagMap =
{ /// The ID of this tag mapping
[<CLIMutable; NoComparison; NoEquality>]
type TagMap = {
/// The ID of this tag mapping
Id: TagMapId
/// The ID of the web log to which this tag mapping belongs
@@ -240,23 +225,17 @@ type TagMap =
/// The value by which the tag should be linked
UrlValue: string
}
/// Functions to support tag mappings
module TagMap =
} with
/// An empty tag mapping
let empty =
{ Id = TagMapId.empty
WebLogId = WebLogId.empty
Tag = ""
UrlValue = ""
}
static member Empty =
{ Id = TagMapId.Empty; WebLogId = WebLogId.Empty; Tag = ""; UrlValue = "" }
/// A theme
type Theme =
{ /// The ID / path of the theme
[<CLIMutable; NoComparison; NoEquality>]
type Theme = {
/// The ID / path of the theme
Id: ThemeId
/// A long name of the theme
@@ -267,47 +246,35 @@ type Theme =
/// The templates for this theme
Templates: ThemeTemplate list
}
/// Functions to support themes
module Theme =
} with
/// An empty theme
let empty =
{ Id = ThemeId ""
Name = ""
Version = ""
Templates = []
}
static member Empty =
{ Id = ThemeId.Empty; Name = ""; Version = ""; Templates = [] }
/// A theme asset (a file served as part of a theme, at /themes/[theme]/[asset-path])
type ThemeAsset =
{
[<CLIMutable; NoComparison; NoEquality>]
type ThemeAsset = {
/// The ID of the asset (consists of theme and path)
Id: ThemeAssetId
/// The updated date (set from the file date from the ZIP archive)
UpdatedOn : DateTime
UpdatedOn: Instant
/// The data for the asset
Data : byte[]
}
/// Functions to support theme assets
module ThemeAsset =
Data: byte array
} with
/// An empty theme asset
let empty =
{ Id = ThemeAssetId (ThemeId "", "")
UpdatedOn = DateTime.MinValue
Data = [||]
}
static member Empty =
{ Id = ThemeAssetId.Empty; UpdatedOn = Noda.epoch; Data = [||] }
/// An uploaded file
type Upload =
{ /// The ID of the upload
[<CLIMutable; NoComparison; NoEquality>]
type Upload = {
/// The ID of the upload
Id: UploadId
/// The ID of the web log to which this upload belongs
@@ -317,29 +284,23 @@ type Upload =
Path: Permalink
/// The updated date/time for this upload
UpdatedOn : DateTime
UpdatedOn: Instant
/// The data for the upload
Data : byte[]
}
/// Functions to support uploaded files
module Upload =
Data: byte array
} with
/// An empty upload
let empty =
{ Id = UploadId.empty
WebLogId = WebLogId.empty
Path = Permalink.empty
UpdatedOn = DateTime.MinValue
Data = [||]
}
static member Empty =
{ Id = UploadId.Empty; WebLogId = WebLogId.Empty; Path = Permalink.Empty; UpdatedOn = Noda.epoch; Data = [||] }
open Newtonsoft.Json
/// A web log
[<CLIMutable; NoComparison; NoEquality>]
type WebLog =
{ /// The ID of the web log
type WebLog = {
/// The ID of the web log
Id: WebLogId
/// The name of the web log
@@ -374,14 +335,14 @@ type WebLog =
/// Where uploads are placed
Uploads: UploadDestination
}
/// Functions to support web logs
module WebLog =
/// Redirect rules for this weblog
RedirectRules: RedirectRule list
} with
/// An empty web log
let empty =
{ Id = WebLogId.empty
static member Empty =
{ Id = WebLogId.Empty
Name = ""
Slug = ""
Subtitle = None
@@ -390,36 +351,41 @@ module WebLog =
ThemeId = ThemeId "default"
UrlBase = ""
TimeZone = ""
Rss = RssOptions.empty
Rss = RssOptions.Empty
AutoHtmx = false
Uploads = Database
}
RedirectRules = [] }
/// Get the host (including scheme) and extra path from the URL base
let hostAndPath webLog =
let scheme = webLog.UrlBase.Split "://"
let host = scheme[1].Split "/"
$"{scheme[0]}://{host[0]}", if host.Length > 1 then $"""/{String.Join ("/", host |> Array.skip 1)}""" else ""
/// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain)
[<JsonIgnore>]
member this.ExtraPath =
let pathParts = this.UrlBase.Split "://"
if pathParts.Length < 2 then
""
else
let path = pathParts[1].Split "/"
if path.Length > 1 then $"""/{path |> Array.skip 1 |> String.concat "/"}""" else ""
/// Generate an absolute URL for the given link
let absoluteUrl webLog permalink =
$"{webLog.UrlBase}/{Permalink.toString permalink}"
member this.AbsoluteUrl(permalink: Permalink) =
$"{this.UrlBase}/{permalink}"
/// Generate a relative URL for the given link
let relativeUrl webLog permalink =
let _, leadPath = hostAndPath webLog
$"{leadPath}/{Permalink.toString permalink}"
member this.RelativeUrl(permalink: Permalink) =
$"{this.ExtraPath}/{permalink}"
/// Convert a UTC date/time to the web log's local date/time
let localTime webLog (date : DateTime) =
TimeZoneInfo.ConvertTimeFromUtc
(DateTime (date.Ticks, DateTimeKind.Utc), TimeZoneInfo.FindSystemTimeZoneById webLog.TimeZone)
/// Convert an Instant (UTC reference) to the web log's local date/time
member this.LocalTime(date: Instant) =
DateTimeZoneProviders.Tzdb.GetZoneOrNull this.TimeZone
|> Option.ofObj
|> Option.map (fun tz -> date.InZone(tz).ToDateTimeUnspecified())
|> Option.defaultValue (date.ToDateTimeUtc())
/// A user of the web log
[<CLIMutable; NoComparison; NoEquality>]
type WebLogUser =
{ /// The ID of the user
type WebLogUser = {
/// The ID of the user
Id: WebLogUserId
/// The ID of the web log to which this user belongs
@@ -440,9 +406,6 @@ type WebLogUser =
/// The hash of the user's password
PasswordHash: string
/// Salt used to calculate the user's password hash
Salt : Guid
/// The URL of the user's personal site
Url: string option
@@ -450,38 +413,28 @@ type WebLogUser =
AccessLevel: AccessLevel
/// When the user was created
CreatedOn : DateTime
CreatedOn: Instant
/// When the user last logged on
LastSeenOn : DateTime option
}
/// Functions to support web log users
module WebLogUser =
LastSeenOn: Instant option
} with
/// An empty web log user
let empty =
{ Id = WebLogUserId.empty
WebLogId = WebLogId.empty
static member Empty =
{ Id = WebLogUserId.Empty
WebLogId = WebLogId.Empty
Email = ""
FirstName = ""
LastName = ""
PreferredName = ""
PasswordHash = ""
Salt = Guid.Empty
Url = None
AccessLevel = Author
CreatedOn = DateTime.UnixEpoch
LastSeenOn = None
}
CreatedOn = Noda.epoch
LastSeenOn = None }
/// Get the user's displayed name
let displayName user =
let name =
seq { match user.PreferredName with "" -> user.FirstName | n -> n; " "; user.LastName }
|> Seq.reduce (+)
name.Trim ()
/// Does a user have the required access level?
let hasAccess level user =
AccessLevel.hasAccess level user.AccessLevel
[<JsonIgnore>]
member this.DisplayName =
(seq { (match this.PreferredName with "" -> this.FirstName | n -> n); " "; this.LastName }
|> Seq.reduce (+)).Trim()

View File

@@ -1,11 +1,5 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net6.0</TargetFramework>
<GenerateDocumentationFile>true</GenerateDocumentationFile>
<DebugType>embedded</DebugType>
</PropertyGroup>
<ItemGroup>
<Compile Include="SupportTypes.fs" />
<Compile Include="DataTypes.fs" />
@@ -13,9 +7,11 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="Markdig" Version="0.30.2" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
<PackageReference Include="Markdown.ColorCode" Version="1.0.1" />
<PackageReference Include="Markdig" Version="0.37.0" />
<PackageReference Include="Markdown.ColorCode" Version="2.2.2" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.3" />
<PackageReference Include="NodaTime" Version="3.1.11" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
</ItemGroup>
</Project>

View File

@@ -1,18 +1,48 @@
namespace MyWebLog
open System
open Markdig
open NodaTime
/// Support functions for domain definition
[<AutoOpen>]
module private Helpers =
open Markdown.ColorCode
/// Create a new ID (short GUID)
// https://www.madskristensen.net/blog/A-shorter-and-URL-friendly-GUID
let newId () =
Convert.ToBase64String(Guid.NewGuid().ToByteArray ()).Replace('/', '_').Replace('+', '-').Substring (0, 22)
Convert.ToBase64String(Guid.NewGuid().ToByteArray()).Replace('/', '_').Replace('+', '-')[..21]
/// Pipeline with most extensions enabled
let markdownPipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build()
/// Functions to support NodaTime manipulation
module Noda =
/// The clock to use when getting "now" (will make mutable for testing)
let clock: IClock = SystemClock.Instance
/// The Unix epoch
let epoch = Instant.FromUnixTimeSeconds 0L
/// Truncate an instant to remove fractional seconds
let toSecondsPrecision (value: Instant) =
Instant.FromUnixTimeSeconds(value.ToUnixTimeSeconds())
/// The current Instant, with fractional seconds truncated
let now =
clock.GetCurrentInstant >> toSecondsPrecision
/// Convert a date/time to an Instant with whole seconds
let fromDateTime (dt: DateTime) =
Instant.FromDateTimeUtc(DateTime(dt.Ticks, DateTimeKind.Utc)) |> toSecondsPrecision
/// A user's access level
[<Struct>]
type AccessLevel =
/// The user may create and publish posts and edit the ones they have created
| Author
@@ -23,73 +53,70 @@ type AccessLevel =
/// The user may manage themes (which affects all web logs for an installation)
| Administrator
/// Functions to support access levels
module AccessLevel =
/// Parse an access level from its string representation
static member Parse level =
match level with
| "Author" -> Author
| "Editor" -> Editor
| "WebLogAdmin" -> WebLogAdmin
| "Administrator" -> Administrator
| _ -> invalidArg (nameof level) $"{level} is not a valid access level"
/// Weightings for access levels
let private weights =
[ Author, 10
Editor, 20
WebLogAdmin, 30
Administrator, 40
]
|> Map.ofList
/// Convert an access level to its string representation
let toString =
function
/// The string representation of this access level
override this.ToString() =
match this with
| Author -> "Author"
| Editor -> "Editor"
| WebLogAdmin -> "WebLogAdmin"
| Administrator -> "Administrator"
/// Parse an access level from its string representation
let parse it =
match it with
| "Author" -> Author
| "Editor" -> Editor
| "WebLogAdmin" -> WebLogAdmin
| "Administrator" -> Administrator
| _ -> invalidOp $"{it} is not a valid access level"
/// Does a given access level allow an action that requires a certain access level?
let hasAccess needed held =
weights[needed] <= weights[held]
member this.HasAccess(needed: AccessLevel) =
let weights =
[ Author, 10
Editor, 20
WebLogAdmin, 30
Administrator, 40 ]
|> Map.ofList
weights[needed] <= weights[this]
/// An identifier for a category
type CategoryId = CategoryId of string
/// Functions to support category IDs
module CategoryId =
[<Struct>]
type CategoryId =
| CategoryId of string
/// An empty category ID
let empty = CategoryId ""
/// Convert a category ID to a string
let toString = function CategoryId ci -> ci
static member Empty = CategoryId ""
/// Create a new category ID
let create () = CategoryId (newId ())
static member Create =
newId >> CategoryId
/// The string representation of this category ID
override this.ToString() =
match this with CategoryId it -> it
/// An identifier for a comment
type CommentId = CommentId of string
/// Functions to support comment IDs
module CommentId =
[<Struct>]
type CommentId =
| CommentId of string
/// An empty comment ID
let empty = CommentId ""
/// Convert a comment ID to a string
let toString = function CommentId ci -> ci
static member Empty = CommentId ""
/// Create a new comment ID
let create () = CommentId (newId ())
static member Create =
newId >> CommentId
/// The string representation of this comment ID
override this.ToString() =
match this with CommentId it -> it
/// Statuses for post comments
[<Struct>]
type CommentStatus =
/// The comment is approved
| Approved
@@ -98,55 +125,99 @@ type CommentStatus =
/// The comment was unsolicited and unwelcome
| Spam
/// Functions to support post comment statuses
module CommentStatus =
/// Convert a comment status to a string
let toString = function Approved -> "Approved" | Pending -> "Pending" | Spam -> "Spam"
/// Parse a string into a comment status
let parse value =
match value with
static member Parse status =
match status with
| "Approved" -> Approved
| "Pending" -> Pending
| "Spam" -> Spam
| it -> invalidOp $"{it} is not a valid post status"
| _ -> invalidArg (nameof status) $"{status} is not a valid comment status"
/// Convert a comment status to a string
override this.ToString() =
match this with Approved -> "Approved" | Pending -> "Pending" | Spam -> "Spam"
/// Valid values for the iTunes explicit rating
[<Struct>]
type ExplicitRating =
| Yes
| No
| Clean
/// Functions to support iTunes explicit ratings
module ExplicitRating =
/// Convert an explicit rating to a string
let toString : ExplicitRating -> string =
function
| Yes -> "yes"
| No -> "no"
| Clean -> "clean"
/// Parse a string into an explicit rating
let parse : string -> ExplicitRating =
function
static member Parse rating =
match rating with
| "yes" -> Yes
| "no" -> No
| "clean" -> Clean
| x -> raise (invalidArg "rating" $"{x} is not a valid explicit rating")
| _ -> invalidArg (nameof rating) $"{rating} is not a valid explicit rating"
/// The string value of this rating
override this.ToString() =
match this with Yes -> "yes" | No -> "no" | Clean -> "clean"
/// A location (specified by Podcast Index)
type Location = {
/// The name of the location (free-form text)
Name: string
/// A geographic coordinate string (RFC 5870)
Geo: string
/// An OpenStreetMap query
Osm: string option
}
/// A chapter in a podcast episode
type Chapter = {
/// The start time for the chapter
StartTime: Duration
/// The title for this chapter
Title: string option
/// A URL for an image for this chapter
ImageUrl: string option
/// A URL with information pertaining to this chapter
Url: string option
/// Whether this chapter is hidden
IsHidden: bool option
/// The episode end time for the chapter
EndTime: Duration option
/// A location that applies to a chapter
Location: Location option
} with
/// An empty chapter
static member Empty =
{ StartTime = Duration.Zero
Title = None
ImageUrl = None
Url = None
IsHidden = None
EndTime = None
Location = None }
open NodaTime.Text
/// A podcast episode
type Episode =
{ /// The URL to the media file for the episode (may be permalink)
type Episode = {
/// The URL to the media file for the episode (may be permalink)
Media: string
/// The length of the media file, in bytes
Length: int64
/// The duration of the episode
Duration : TimeSpan option
Duration: Duration option
/// The media type of the file (overrides podcast default if present)
MediaType: string option
@@ -160,12 +231,18 @@ type Episode =
/// This episode's explicit rating (overrides podcast rating if present)
Explicit: ExplicitRating option
/// Chapters for this episode
Chapters: Chapter list option
/// A link to a chapter file
ChapterFile: string option
/// The MIME type for the chapter file
ChapterType: string option
/// Whether the chapters have locations that should be displayed as waypoints
ChapterWaypoints: bool option
/// The URL for the transcript of the episode (may be permalink)
TranscriptUrl: string option
@@ -189,13 +266,10 @@ type Episode =
/// A description of the episode
EpisodeDescription: string option
}
/// Functions to support episodes
module Episode =
} with
/// An empty episode
let empty =
static member Empty =
{ Media = ""
Length = 0L
Duration = None
@@ -203,8 +277,10 @@ module Episode =
ImageUrl = None
Subtitle = None
Explicit = None
Chapters = None
ChapterFile = None
ChapterType = None
ChapterWaypoints = None
TranscriptUrl = None
TranscriptType = None
TranscriptLang = None
@@ -212,12 +288,12 @@ module Episode =
SeasonNumber = None
SeasonDescription = None
EpisodeNumber = None
EpisodeDescription = None
}
EpisodeDescription = None }
/// Format a duration for an episode
member this.FormatDuration() =
this.Duration |> Option.map (DurationPattern.CreateWithInvariantCulture("H:mm:ss").Format)
open Markdig
open Markdown.ColorCode
/// Types of markup text
type MarkupText =
@@ -226,100 +302,92 @@ type MarkupText =
/// HTML text
| Html of string
/// Functions to support markup text
module MarkupText =
/// Pipeline with most extensions enabled
let private _pipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build ()
/// Get the source type for the markup text
let sourceType = function Markdown _ -> "Markdown" | Html _ -> "HTML"
/// Get the raw text, regardless of type
let text = function Markdown text -> text | Html text -> text
/// Get the string representation of the markup text
let toString it = $"{sourceType it}: {text it}"
/// Get the HTML representation of the markup text
let toHtml = function Markdown text -> Markdown.ToHtml (text, _pipeline) | Html text -> text
/// Parse a string into a MarkupText instance
let parse (it : string) =
match it with
| text when text.StartsWith "Markdown: " -> Markdown (text.Substring 10)
| text when text.StartsWith "HTML: " -> Html (text.Substring 6)
| text -> invalidOp $"Cannot derive type of text ({text})"
static member Parse(text: string) =
match text with
| _ when text.StartsWith "Markdown: " -> Markdown text[10..]
| _ when text.StartsWith "HTML: " -> Html text[6..]
| _ -> invalidArg (nameof text) $"Cannot derive type of text ({text})"
/// The source type for the markup text
member this.SourceType =
match this with Markdown _ -> "Markdown" | Html _ -> "HTML"
/// The raw text, regardless of type
member this.Text =
match this with Markdown text -> text | Html text -> text
/// The string representation of the markup text
override this.ToString() =
$"{this.SourceType}: {this.Text}"
/// The HTML representation of the markup text
member this.AsHtml() =
match this with Markdown text -> Markdown.ToHtml(text, markdownPipeline) | Html text -> text
/// An item of metadata
[<CLIMutable; NoComparison; NoEquality>]
type MetaItem =
{ /// The name of the metadata value
[<CLIMutable>]
type MetaItem = {
/// The name of the metadata value
Name: string
/// The metadata value
Value: string
}
/// Functions to support metadata items
module MetaItem =
} with
/// An empty metadata item
let empty =
static member Empty =
{ Name = ""; Value = "" }
/// A revision of a page or post
[<CLIMutable; NoComparison; NoEquality>]
type Revision =
{ /// When this revision was saved
AsOf : DateTime
[<CLIMutable>]
type Revision = {
/// When this revision was saved
AsOf: Instant
/// The text of the revision
Text: MarkupText
}
/// Functions to support revisions
module Revision =
} with
/// An empty revision
let empty =
{ AsOf = DateTime.UtcNow
Text = Html ""
}
static member Empty =
{ AsOf = Noda.epoch; Text = Html "" }
/// A permanent link
type Permalink = Permalink of string
/// Functions to support permalinks
module Permalink =
[<Struct>]
type Permalink =
| Permalink of string
/// An empty permalink
let empty = Permalink ""
static member Empty = Permalink ""
/// Convert a permalink to a string
let toString = function Permalink p -> p
/// The string value of this permalink
override this.ToString() =
match this with Permalink it -> it
/// An identifier for a page
type PageId = PageId of string
/// Functions to support page IDs
module PageId =
[<Struct>]
type PageId =
| PageId of string
/// An empty page ID
let empty = PageId ""
/// Convert a page ID to a string
let toString = function PageId pi -> pi
static member Empty = PageId ""
/// Create a new page ID
let create () = PageId (newId ())
static member Create =
newId >> PageId
/// The string value of this page ID
override this.ToString() =
match this with PageId it -> it
/// PodcastIndex.org podcast:medium allowed values
[<Struct>]
type PodcastMedium =
| Podcast
| Music
@@ -329,12 +397,21 @@ type PodcastMedium =
| Newsletter
| Blog
/// Functions to support podcast medium
module PodcastMedium =
/// Parse a string into a podcast medium
static member Parse medium =
match medium with
| "podcast" -> Podcast
| "music" -> Music
| "video" -> Video
| "film" -> Film
| "audiobook" -> Audiobook
| "newsletter" -> Newsletter
| "blog" -> Blog
| _ -> invalidArg (nameof medium) $"{medium} is not a valid podcast medium"
/// Convert a podcast medium to a string
let toString =
function
/// The string value of this podcast medium
override this.ToString() =
match this with
| Podcast -> "podcast"
| Music -> "music"
| Video -> "video"
@@ -343,70 +420,77 @@ module PodcastMedium =
| Newsletter -> "newsletter"
| Blog -> "blog"
/// Parse a string into a podcast medium
let parse value =
match value with
| "podcast" -> Podcast
| "music" -> Music
| "video" -> Video
| "film" -> Film
| "audiobook" -> Audiobook
| "newsletter" -> Newsletter
| "blog" -> Blog
| it -> invalidOp $"{it} is not a valid podcast medium"
/// Statuses for posts
[<Struct>]
type PostStatus =
/// The post should not be publicly available
| Draft
/// The post is publicly viewable
| Published
/// Functions to support post statuses
module PostStatus =
/// Convert a post status to a string
let toString = function Draft -> "Draft" | Published -> "Published"
/// Parse a string into a post status
let parse value =
match value with
static member Parse status =
match status with
| "Draft" -> Draft
| "Published" -> Published
| it -> invalidOp $"{it} is not a valid post status"
| _ -> invalidArg (nameof status) $"{status} is not a valid post status"
/// The string representation of this post status
override this.ToString() =
match this with Draft -> "Draft" | Published -> "Published"
/// An identifier for a post
type PostId = PostId of string
/// Functions to support post IDs
module PostId =
[<Struct>]
type PostId =
| PostId of string
/// An empty post ID
let empty = PostId ""
/// Convert a post ID to a string
let toString = function PostId pi -> pi
static member Empty = PostId ""
/// Create a new post ID
let create () = PostId (newId ())
static member Create =
newId >> PostId
/// Convert a post ID to a string
override this.ToString() =
match this with PostId it -> it
/// A redirection for a previously valid URL
[<CLIMutable>]
type RedirectRule = {
/// The From string or pattern
From: string
/// The To string or pattern
To: string
/// Whether to use regular expressions on this rule
IsRegex: bool
} with
/// An empty redirect rule
static member Empty =
{ From = ""; To = ""; IsRegex = false }
/// An identifier for a custom feed
type CustomFeedId = CustomFeedId of string
/// Functions to support custom feed IDs
module CustomFeedId =
[<Struct>]
type CustomFeedId =
| CustomFeedId of string
/// An empty custom feed ID
let empty = CustomFeedId ""
/// Convert a custom feed ID to a string
let toString = function CustomFeedId pi -> pi
static member Empty = CustomFeedId ""
/// Create a new custom feed ID
let create () = CustomFeedId (newId ())
static member Create =
newId >> CustomFeedId
/// Convert a custom feed ID to a string
override this.ToString() =
match this with CustomFeedId it -> it
/// The source for a custom feed
@@ -416,26 +500,23 @@ type CustomFeedSource =
/// A feed based on a particular tag
| Tag of string
/// Functions to support feed sources
module CustomFeedSource =
/// Create a string version of a feed source
let toString : CustomFeedSource -> string =
function
| Category (CategoryId catId) -> $"category:{catId}"
| Tag tag -> $"tag:{tag}"
/// Parse a feed source from its string version
let parse : string -> CustomFeedSource =
static member Parse(source: string) =
let value (it : string) = it.Split(":").[1]
function
| source when source.StartsWith "category:" -> (value >> CategoryId >> Category) source
| source when source.StartsWith "tag:" -> (value >> Tag) source
| source -> invalidArg "feedSource" $"{source} is not a valid feed source"
match source with
| _ when source.StartsWith "category:" -> (value >> CategoryId >> Category) source
| _ when source.StartsWith "tag:" -> (value >> Tag) source
| _ -> invalidArg (nameof source) $"{source} is not a valid feed source"
/// Create a string version of a feed source
override this.ToString() =
match this with | Category (CategoryId catId) -> $"category:{catId}" | Tag tag -> $"tag:{tag}"
/// Options for a feed that describes a podcast
type PodcastOptions =
{ /// The title of the podcast
[<CLIMutable; NoComparison; NoEquality>]
type PodcastOptions = {
/// The title of the podcast
Title: string
/// A subtitle for the podcast
@@ -482,12 +563,32 @@ type PodcastOptions =
/// The medium (what the podcast IS, not what it is ABOUT)
Medium: PodcastMedium option
}
} with
/// A default set of podcast options
static member Empty =
{ Title = ""
Subtitle = None
ItemsInFeed = 0
Summary = ""
DisplayedAuthor = ""
Email = ""
ImageUrl = Permalink.Empty
AppleCategory = ""
AppleSubcategory = None
Explicit = No
DefaultMediaType = None
MediaBaseUrl = None
PodcastGuid = None
FundingUrl = None
FundingText = None
Medium = None }
/// A custom feed
type CustomFeed =
{ /// The ID of the custom feed
[<CLIMutable; NoComparison; NoEquality>]
type CustomFeed = {
/// The ID of the custom feed
Id: CustomFeedId
/// The source for the custom feed
@@ -498,24 +599,20 @@ type CustomFeed =
/// Podcast options, if the feed defines a podcast
Podcast: PodcastOptions option
}
/// Functions to support custom feeds
module CustomFeed =
} with
/// An empty custom feed
let empty =
{ Id = CustomFeedId ""
Source = Category (CategoryId "")
Path = Permalink ""
Podcast = None
}
static member Empty =
{ Id = CustomFeedId.Empty
Source = Category CategoryId.Empty
Path = Permalink.Empty
Podcast = None }
/// Really Simple Syndication (RSS) options for this web log
[<CLIMutable; NoComparison; NoEquality>]
type RssOptions =
{ /// Whether the site feed of posts is enabled
type RssOptions = {
/// Whether the site feed of posts is enabled
IsFeedEnabled: bool
/// The name of the file generated for the site feed
@@ -535,146 +632,149 @@ type RssOptions =
/// Custom feeds for this web log
CustomFeeds: CustomFeed list
}
/// Functions to support RSS options
module RssOptions =
} with
/// An empty set of RSS options
let empty =
static member Empty =
{ IsFeedEnabled = true
FeedName = "feed.xml"
ItemsInFeed = None
IsCategoryEnabled = true
IsTagEnabled = true
Copyright = None
CustomFeeds = []
}
CustomFeeds = [] }
/// An identifier for a tag mapping
type TagMapId = TagMapId of string
/// Functions to support tag mapping IDs
module TagMapId =
[<Struct>]
type TagMapId =
| TagMapId of string
/// An empty tag mapping ID
let empty = TagMapId ""
/// Convert a tag mapping ID to a string
let toString = function TagMapId tmi -> tmi
static member Empty = TagMapId ""
/// Create a new tag mapping ID
let create () = TagMapId (newId ())
static member Create =
newId >> TagMapId
/// Convert a tag mapping ID to a string
override this.ToString() =
match this with TagMapId it -> it
/// An identifier for a theme (represents its path)
type ThemeId = ThemeId of string
[<Struct>]
type ThemeId =
| ThemeId of string
/// Functions to support theme IDs
module ThemeId =
let toString = function ThemeId ti -> ti
/// An empty theme ID
static member Empty = ThemeId ""
/// The string representation of a theme ID
override this.ToString() =
match this with ThemeId it -> it
/// An identifier for a theme asset
type ThemeAssetId = ThemeAssetId of ThemeId * string
[<Struct>]
type ThemeAssetId =
| ThemeAssetId of ThemeId * string
/// Functions to support theme asset IDs
module ThemeAssetId =
/// Convert a theme asset ID into a path string
let toString = function ThemeAssetId (ThemeId theme, asset) -> $"{theme}/{asset}"
/// An empty theme asset ID
static member Empty = ThemeAssetId(ThemeId.Empty, "")
/// Convert a string into a theme asset ID
let ofString (it : string) =
static member Parse(it : string) =
let themeIdx = it.IndexOf "/"
if themeIdx < 0 then
invalidArg "id" $"Invalid format; expected [theme_id]/[asset_id] (received {it})"
else
ThemeAssetId(ThemeId it[..(themeIdx - 1)], it[(themeIdx + 1)..])
/// Convert a theme asset ID into a path string
override this.ToString() =
match this with ThemeAssetId (ThemeId theme, asset) -> $"{theme}/{asset}"
/// A template for a theme
type ThemeTemplate =
{ /// The name of the template
[<CLIMutable; NoComparison; NoEquality>]
type ThemeTemplate = {
/// The name of the template
Name: string
/// The text of the template
Text: string
}
/// Functions to support theme templates
module ThemeTemplate =
} with
/// An empty theme template
let empty =
{ Name = ""
Text = ""
}
static member Empty =
{ Name = ""; Text = "" }
/// Where uploads should be placed
[<Struct>]
type UploadDestination =
| Database
| Disk
/// Functions to support upload destinations
module UploadDestination =
/// Convert an upload destination to its string representation
let toString = function Database -> "Database" | Disk -> "Disk"
/// Parse an upload destination from its string representation
let parse value =
match value with
static member Parse destination =
match destination with
| "Database" -> Database
| "Disk" -> Disk
| it -> invalidOp $"{it} is not a valid upload destination"
| _ -> invalidArg (nameof destination) $"{destination} is not a valid upload destination"
/// The string representation of an upload destination
override this.ToString() =
match this with Database -> "Database" | Disk -> "Disk"
/// An identifier for an upload
type UploadId = UploadId of string
/// Functions to support upload IDs
module UploadId =
[<Struct>]
type UploadId =
| UploadId of string
/// An empty upload ID
let empty = UploadId ""
/// Convert an upload ID to a string
let toString = function UploadId ui -> ui
static member Empty = UploadId ""
/// Create a new upload ID
let create () = UploadId (newId ())
static member Create =
newId >> UploadId
/// The string representation of an upload ID
override this.ToString() =
match this with UploadId it -> it
/// An identifier for a web log
type WebLogId = WebLogId of string
/// Functions to support web log IDs
module WebLogId =
[<Struct>]
type WebLogId =
| WebLogId of string
/// An empty web log ID
let empty = WebLogId ""
/// Convert a web log ID to a string
let toString = function WebLogId wli -> wli
static member Empty = WebLogId ""
/// Create a new web log ID
let create () = WebLogId (newId ())
static member Create =
newId >> WebLogId
/// Convert a web log ID to a string
override this.ToString() =
match this with WebLogId it -> it
/// An identifier for a web log user
type WebLogUserId = WebLogUserId of string
/// Functions to support web log user IDs
module WebLogUserId =
[<Struct>]
type WebLogUserId =
| WebLogUserId of string
/// An empty web log user ID
let empty = WebLogUserId ""
/// Convert a web log user ID to a string
let toString = function WebLogUserId wli -> wli
static member Empty = WebLogUserId ""
/// Create a new web log user ID
let create () = WebLogUserId (newId ())
static member Create =
newId >> WebLogUserId
/// The string representation of a web log user ID
override this.ToString() =
match this with WebLogUserId it -> it

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,150 @@
/// <summary>
/// Integration tests for <see cref="ICategoryData" /> implementations
/// </summary>
module CategoryDataTests
open Expecto
open MyWebLog
open MyWebLog.Data
/// The ID of the root web log
let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g"
/// The ID of the Favorites category
let private favoritesId = CategoryId "S5JflPsJ9EG7gA2LD4m92A"
let ``Add succeeds`` (data: IData) = task {
let category =
{ Category.Empty with Id = CategoryId "added-cat"; WebLogId = WebLogId "test"; Name = "Added"; Slug = "added" }
do! data.Category.Add category
let! stored = data.Category.FindById (CategoryId "added-cat") (WebLogId "test")
Expect.isSome stored "The category should have been added"
}
let ``CountAll succeeds when categories exist`` (data: IData) = task {
let! count = data.Category.CountAll rootId
Expect.equal count 3 "There should have been 3 categories"
}
let ``CountAll succeeds when categories do not exist`` (data: IData) = task {
let! count = data.Category.CountAll WebLogId.Empty
Expect.equal count 0 "There should have been no categories"
}
let ``CountTopLevel succeeds when top-level categories exist`` (data: IData) = task {
let! count = data.Category.CountTopLevel rootId
Expect.equal count 2 "There should have been 2 top-level categories"
}
let ``CountTopLevel succeeds when no top-level categories exist`` (data: IData) = task {
let! count = data.Category.CountTopLevel WebLogId.Empty
Expect.equal count 0 "There should have been no top-level categories"
}
let ``FindAllForView succeeds`` (data: IData) = task {
let! all = data.Category.FindAllForView rootId
Expect.equal all.Length 3 "There should have been 3 categories returned"
Expect.equal all[0].Name "Favorites" "The first category is incorrect"
Expect.equal all[0].PostCount 1 "There should be one post in this category"
Expect.equal all[1].Name "Spitball" "The second category is incorrect"
Expect.equal all[1].PostCount 2 "There should be two posts in this category"
Expect.equal all[2].Name "Moonshot" "The third category is incorrect"
Expect.equal all[2].PostCount 1 "There should be one post in this category"
}
let ``FindById succeeds when a category is found`` (data: IData) = task {
let! cat = data.Category.FindById favoritesId rootId
Expect.isSome cat "There should have been a category returned"
Expect.equal cat.Value.Name "Favorites" "The category retrieved is incorrect"
Expect.equal cat.Value.Slug "favorites" "The slug is incorrect"
Expect.equal cat.Value.Description (Some "Favorite posts") "The description is incorrect"
Expect.isNone cat.Value.ParentId "There should have been no parent ID"
}
let ``FindById succeeds when a category is not found`` (data: IData) = task {
let! cat = data.Category.FindById CategoryId.Empty rootId
Expect.isNone cat "There should not have been a category returned"
}
let ``FindByWebLog succeeds when categories exist`` (data: IData) = task {
let! cats = data.Category.FindByWebLog rootId
Expect.equal cats.Length 3 "There should be 3 categories"
Expect.exists cats (fun it -> it.Name = "Favorites") "Favorites category not found"
Expect.exists cats (fun it -> it.Name = "Spitball") "Spitball category not found"
Expect.exists cats (fun it -> it.Name = "Moonshot") "Moonshot category not found"
}
let ``FindByWebLog succeeds when no categories exist`` (data: IData) = task {
let! cats = data.Category.FindByWebLog WebLogId.Empty
Expect.isEmpty cats "There should have been no categories returned"
}
let ``Update succeeds`` (data: IData) = task {
match! data.Category.FindById favoritesId rootId with
| Some cat ->
do! data.Category.Update { cat with Name = "My Favorites"; Slug = "my-favorites"; Description = None }
match! data.Category.FindById favoritesId rootId with
| Some updated ->
Expect.equal updated.Name "My Favorites" "Name not updated properly"
Expect.equal updated.Slug "my-favorites" "Slug not updated properly"
Expect.isNone updated.Description "Description should have been removed"
| None -> Expect.isTrue false "The updated favorites category could not be retrieved"
| None -> Expect.isTrue false "The favorites category could not be retrieved"
}
let ``Delete succeeds when the category is deleted (no posts)`` (data: IData) = task {
let! result = data.Category.Delete (CategoryId "added-cat") (WebLogId "test")
Expect.equal result CategoryDeleted "The category should have been deleted"
let! cat = data.Category.FindById (CategoryId "added-cat") (WebLogId "test")
Expect.isNone cat "The deleted category should not still exist"
}
let ``Delete succeeds when the category does not exist`` (data: IData) = task {
let! result = data.Category.Delete CategoryId.Empty (WebLogId "none")
Expect.equal result CategoryNotFound "The category should not have been found"
}
let ``Delete succeeds when reassigning parent category to None`` (data: IData) = task {
let moonshotId = CategoryId "ScVpyu1e7UiP7bDdge3ZEw"
let spitballId = CategoryId "jw6N69YtTEWVHAO33jHU-w"
let! result = data.Category.Delete spitballId rootId
Expect.equal result ReassignedChildCategories "Child categories should have been reassigned"
match! data.Category.FindById moonshotId rootId with
| Some cat -> Expect.isNone cat.ParentId "Parent ID should have been cleared"
| None -> Expect.isTrue false "Unable to find former child category"
}
let ``Delete succeeds when reassigning parent category to Some`` (data: IData) = task {
do! data.Category.Add { Category.Empty with Id = CategoryId "a"; WebLogId = WebLogId "test"; Name = "A" }
do! data.Category.Add
{ Category.Empty with
Id = CategoryId "b"
WebLogId = WebLogId "test"
Name = "B"
ParentId = Some (CategoryId "a") }
do! data.Category.Add
{ Category.Empty with
Id = CategoryId "c"
WebLogId = WebLogId "test"
Name = "C"
ParentId = Some (CategoryId "b") }
let! result = data.Category.Delete (CategoryId "b") (WebLogId "test")
Expect.equal result ReassignedChildCategories "Child categories should have been reassigned"
match! data.Category.FindById (CategoryId "c") (WebLogId "test") with
| Some cat -> Expect.equal cat.ParentId (Some (CategoryId "a")) "Parent category ID not reassigned properly"
| None -> Expect.isTrue false "Expected former child category not found"
}
let ``Delete succeeds and removes category from posts`` (data: IData) = task {
let moonshotId = CategoryId "ScVpyu1e7UiP7bDdge3ZEw"
let postId = PostId "RCsCU2puYEmkpzotoi8p4g"
match! data.Post.FindById postId rootId with
| Some post ->
Expect.equal post.CategoryIds [ moonshotId ] "Post category IDs are not as expected"
let! result = data.Category.Delete moonshotId rootId
Expect.equal result CategoryDeleted "The category should have been deleted (no children)"
match! data.Post.FindById postId rootId with
| Some p -> Expect.isEmpty p.CategoryIds "Category ID was not removed"
| None -> Expect.isTrue false "The expected updated post was not found"
| None -> Expect.isTrue false "The expected test post was not found"
}

View File

@@ -0,0 +1,296 @@
module ConvertersTests
open Expecto
open Microsoft.FSharpLu.Json
open MyWebLog
open MyWebLog.Converters.Json
open Newtonsoft.Json
/// Unit tests for the CategoryIdConverter type
let categoryIdConverterTests = testList "CategoryIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(CategoryIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(CategoryId "test-cat-id", opts)
Expect.equal after "\"test-cat-id\"" "Category ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<CategoryId>("\"test-cat-id\"", opts)
Expect.equal after (CategoryId "test-cat-id") "Category ID not serialized incorrectly"
}
]
/// Unit tests for the CommentIdConverter type
let commentIdConverterTests = testList "CommentIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(CommentIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(CommentId "test-id", opts)
Expect.equal after "\"test-id\"" "Comment ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<CommentId>("\"my-test\"", opts)
Expect.equal after (CommentId "my-test") "Comment ID deserialized incorrectly"
}
]
/// Unit tests for the CommentStatusConverter type
let commentStatusConverterTests = testList "CommentStatusConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(CommentStatusConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(Approved, opts)
Expect.equal after "\"Approved\"" "Comment status serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<CommentStatus>("\"Spam\"", opts)
Expect.equal after Spam "Comment status deserialized incorrectly"
}
]
/// Unit tests for the CustomFeedIdConverter type
let customFeedIdConverterTests = testList "CustomFeedIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(CustomFeedIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(CustomFeedId "my-feed", opts)
Expect.equal after "\"my-feed\"" "Custom feed ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<CustomFeedId>("\"feed-me\"", opts)
Expect.equal after (CustomFeedId "feed-me") "Custom feed ID deserialized incorrectly"
}
]
/// Unit tests for the CustomFeedSourceConverter type
let customFeedSourceConverterTests = testList "CustomFeedSourceConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(CustomFeedSourceConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(Category (CategoryId "abc-123"), opts)
Expect.equal after "\"category:abc-123\"" "Custom feed source serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<CustomFeedSource>("\"tag:testing\"", opts)
Expect.equal after (Tag "testing") "Custom feed source deserialized incorrectly"
}
]
/// Unit tests for the ExplicitRating type
let explicitRatingConverterTests = testList "ExplicitRatingConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(ExplicitRatingConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(Yes, opts)
Expect.equal after "\"yes\"" "Explicit rating serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<ExplicitRating>("\"clean\"", opts)
Expect.equal after Clean "Explicit rating deserialized incorrectly"
}
]
/// Unit tests for the MarkupText type
let markupTextConverterTests = testList "MarkupTextConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(MarkupTextConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(Html "<h4>test</h4>", opts)
Expect.equal after "\"HTML: <h4>test</h4>\"" "Markup text serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<MarkupText>("\"Markdown: #### test\"", opts)
Expect.equal after (Markdown "#### test") "Markup text deserialized incorrectly"
}
]
/// Unit tests for the PermalinkConverter type
let permalinkConverterTests = testList "PermalinkConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(PermalinkConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(Permalink "2022/test", opts)
Expect.equal after "\"2022/test\"" "Permalink serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<Permalink>("\"2023/unit.html\"", opts)
Expect.equal after (Permalink "2023/unit.html") "Permalink deserialized incorrectly"
}
]
/// Unit tests for the PageIdConverter type
let pageIdConverterTests = testList "PageIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(PageIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(PageId "test-page", opts)
Expect.equal after "\"test-page\"" "Page ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<PageId>("\"page-test\"", opts)
Expect.equal after (PageId "page-test") "Page ID deserialized incorrectly"
}
]
/// Unit tests for the PodcastMedium type
let podcastMediumConverterTests = testList "PodcastMediumConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(PodcastMediumConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(Audiobook, opts)
Expect.equal after "\"audiobook\"" "Podcast medium serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<PodcastMedium>("\"newsletter\"", opts)
Expect.equal after Newsletter "Podcast medium deserialized incorrectly"
}
]
/// Unit tests for the PostIdConverter type
let postIdConverterTests = testList "PostIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(PostIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(PostId "test-post", opts)
Expect.equal after "\"test-post\"" "Post ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<PostId>("\"post-test\"", opts)
Expect.equal after (PostId "post-test") "Post ID deserialized incorrectly"
}
]
/// Unit tests for the TagMapIdConverter type
let tagMapIdConverterTests = testList "TagMapIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(TagMapIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(TagMapId "test-map", opts)
Expect.equal after "\"test-map\"" "Tag map ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<TagMapId>("\"map-test\"", opts)
Expect.equal after (TagMapId "map-test") "Tag map ID deserialized incorrectly"
}
]
/// Unit tests for the ThemeAssetIdConverter type
let themeAssetIdConverterTests = testList "ThemeAssetIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(ThemeAssetIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(ThemeAssetId (ThemeId "test", "unit.jpg"), opts)
Expect.equal after "\"test/unit.jpg\"" "Theme asset ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<ThemeAssetId>("\"theme/test.png\"", opts)
Expect.equal after (ThemeAssetId (ThemeId "theme", "test.png")) "Theme asset ID deserialized incorrectly"
}
]
/// Unit tests for the ThemeIdConverter type
let themeIdConverterTests = testList "ThemeIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(ThemeIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(ThemeId "test-theme", opts)
Expect.equal after "\"test-theme\"" "Theme ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<ThemeId>("\"theme-test\"", opts)
Expect.equal after (ThemeId "theme-test") "Theme ID deserialized incorrectly"
}
]
/// Unit tests for the UploadIdConverter type
let uploadIdConverterTests = testList "UploadIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(UploadIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(UploadId "test-up", opts)
Expect.equal after "\"test-up\"" "Upload ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<UploadId>("\"up-test\"", opts)
Expect.equal after (UploadId "up-test") "Upload ID deserialized incorrectly"
}
]
/// Unit tests for the WebLogIdConverter type
let webLogIdConverterTests = testList "WebLogIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(WebLogIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(WebLogId "test-web", opts)
Expect.equal after "\"test-web\"" "Web log ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<WebLogId>("\"web-test\"", opts)
Expect.equal after (WebLogId "web-test") "Web log ID deserialized incorrectly"
}
]
/// Unit tests for the WebLogUserIdConverter type
let webLogUserIdConverterTests = testList "WebLogUserIdConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(WebLogUserIdConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(WebLogUserId "test-user", opts)
Expect.equal after "\"test-user\"" "Web log user ID serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<WebLogUserId>("\"user-test\"", opts)
Expect.equal after (WebLogUserId "user-test") "Web log user ID deserialized incorrectly"
}
]
open NodaTime.Serialization.JsonNet
/// Unit tests for the Json.configure function
let configureTests = test "Json.configure succeeds" {
let has typ (converter: JsonConverter) = converter.GetType() = typ
let ser = configure (JsonSerializer.Create())
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<CommentStatusConverter>) "Comment status converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<CustomFeedIdConverter>) "Custom feed ID 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<MarkupTextConverter>) "Markup text converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PermalinkConverter>) "Permalink converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PageIdConverter>) "Page ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PodcastMediumConverter>) "Podcast medium converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PostIdConverter>) "Post ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<TagMapIdConverter>) "Tag map ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<ThemeAssetIdConverter>) "Theme asset ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<ThemeIdConverter>) "Theme ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<UploadIdConverter>) "Upload ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<WebLogIdConverter>) "Web log ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<WebLogUserIdConverter>) "Web log user ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<CompactUnionJsonConverter>) "F# type converter not found"
Expect.hasCountOf ser.Converters 1u (has (NodaConverters.InstantConverter.GetType())) "NodaTime converter not found"
Expect.equal ser.NullValueHandling NullValueHandling.Ignore "Null handling set incorrectly"
Expect.equal ser.MissingMemberHandling MissingMemberHandling.Ignore "Missing member handling set incorrectly"
}
/// All tests for the Data.Converters file
let all = testList "Converters" [
categoryIdConverterTests
commentIdConverterTests
commentStatusConverterTests
customFeedIdConverterTests
customFeedSourceConverterTests
explicitRatingConverterTests
markupTextConverterTests
permalinkConverterTests
pageIdConverterTests
podcastMediumConverterTests
postIdConverterTests
tagMapIdConverterTests
themeAssetIdConverterTests
themeIdConverterTests
uploadIdConverterTests
webLogIdConverterTests
webLogUserIdConverterTests
configureTests
]

View File

@@ -0,0 +1,267 @@
/// <summary>
/// Integration tests for <see cref="IPageData" /> implementations
/// </summary>
module PageDataTests
open System
open Expecto
open MyWebLog
open MyWebLog.Data
open NodaTime
/// The ID of the root web log
let private rootId = CategoryDataTests.rootId
/// The ID of the "A cool page" page
let coolPageId = PageId "hgc_BLEZ50SoAWLuPNISvA"
/// The published and updated time of the "A cool page" page
let private coolPagePublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z")
/// The ID of the "Yet Another Page" page
let private otherPageId = PageId "KouRjvSmm0Wz6TMD8xf67A"
let ``Add succeeds`` (data: IData) = task {
let page =
{ Id = PageId "added-page"
WebLogId = WebLogId "test"
AuthorId = WebLogUserId "the-author"
Title = "A New Page"
Permalink = Permalink "2024/the-page.htm"
PublishedOn = Noda.epoch + Duration.FromDays 3
UpdatedOn = Noda.epoch + Duration.FromDays 3 + Duration.FromMinutes 2L
IsInPageList = true
Template = Some "new-page-template"
Text = "<h1>A new page</h1>"
Metadata = [ { Name = "Meta Item"; Value = "Meta Value" } ]
PriorPermalinks = [ Permalink "2024/the-new-page.htm" ]
Revisions = [ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<h1>A new page</h1>" } ] }
do! data.Page.Add page
let! stored = data.Page.FindFullById (PageId "added-page") (WebLogId "test")
Expect.isSome stored "The page should have been added"
let pg = stored.Value
Expect.equal pg.Id page.Id "ID not saved properly"
Expect.equal pg.WebLogId page.WebLogId "Web log ID not saved properly"
Expect.equal pg.AuthorId page.AuthorId "Author ID not saved properly"
Expect.equal pg.Title page.Title "Title not saved properly"
Expect.equal pg.Permalink page.Permalink "Permalink not saved properly"
Expect.equal pg.PublishedOn page.PublishedOn "Published On not saved properly"
Expect.equal pg.UpdatedOn page.UpdatedOn "Updated On not saved properly"
Expect.equal pg.IsInPageList page.IsInPageList "Is in page list flag not saved properly"
Expect.equal pg.Template page.Template "Template not saved properly"
Expect.equal pg.Text page.Text "Text 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.Revisions page.Revisions "Revisions not saved properly"
}
let ``All succeeds`` (data: IData) = task {
let! pages = data.Page.All rootId
Expect.hasLength pages 2 "There should have been 2 pages retrieved"
pages |> List.iteri (fun idx pg ->
Expect.equal pg.Text "" $"Page {idx} should have had no text"
Expect.isEmpty pg.Metadata $"Page {idx} should have had no metadata"
Expect.isEmpty pg.Revisions $"Page {idx} should have had no revisions"
Expect.isEmpty pg.PriorPermalinks $"Page {idx} should have had no prior permalinks")
let! others = data.Page.All (WebLogId "not-there")
Expect.isEmpty others "There should not be pages retrieved"
}
let ``CountAll succeeds`` (data: IData) = task {
let! pages = data.Page.CountAll rootId
Expect.equal pages 2 "There should have been 2 pages counted"
}
let ``CountListed succeeds`` (data: IData) = task {
let! pages = data.Page.CountListed rootId
Expect.equal pages 1 "There should have been 1 page in the page list"
}
let ``FindById succeeds when a page is found`` (data: IData) = task {
let! page = data.Page.FindById coolPageId rootId
Expect.isSome page "A page should have been returned"
let pg = page.Value
Expect.equal pg.Id coolPageId "The wrong page was retrieved"
Expect.equal pg.WebLogId rootId "The page's web log did not match the called parameter"
Expect.equal pg.AuthorId (WebLogUserId "5EM2rimH9kONpmd2zQkiVA") "Author ID is incorrect"
Expect.equal pg.Title "Page Title" "Title is incorrect"
Expect.equal pg.Permalink (Permalink "a-cool-page.html") "Permalink is incorrect"
Expect.equal pg.PublishedOn coolPagePublished "Published On is incorrect"
Expect.equal pg.UpdatedOn coolPagePublished "Updated On is incorrect"
Expect.isFalse pg.IsInPageList "Is in page list flag should not have been set"
Expect.equal pg.Text "<h1 id=\"a-cool-page\">A Cool Page</h1>\n<p>It really is cool!</p>\n" "Text is incorrect"
Expect.equal
pg.Metadata [ { Name = "Cool"; Value = "true" }; { Name = "Warm"; Value = "false" } ] "Metadata is incorrect"
Expect.isEmpty pg.Revisions "Revisions should not have been retrieved"
Expect.isEmpty pg.PriorPermalinks "Prior permalinks should not have been retrieved"
}
let ``FindById succeeds when a page is not found (incorrect weblog)`` (data: IData) = task {
let! page = data.Page.FindById coolPageId (WebLogId "wrong")
Expect.isNone page "The page should not have been retrieved"
}
let ``FindById succeeds when a page is not found (bad page ID)`` (data: IData) = task {
let! page = data.Page.FindById (PageId "missing") rootId
Expect.isNone page "The page should not have been retrieved"
}
let ``FindByPermalink succeeds when a page is found`` (data: IData) = task {
let! page = data.Page.FindByPermalink (Permalink "a-cool-page.html") rootId
Expect.isSome page "A page should have been returned"
let pg = page.Value
Expect.equal pg.Id coolPageId "The wrong page was retrieved"
Expect.isEmpty pg.Revisions "Revisions should not have been retrieved"
Expect.isEmpty pg.PriorPermalinks "Prior permalinks should not have been retrieved"
}
let ``FindByPermalink succeeds when a page is not found (incorrect weblog)`` (data: IData) = task {
let! page = data.Page.FindByPermalink (Permalink "a-cool-page.html") (WebLogId "wrong")
Expect.isNone page "The page should not have been retrieved"
}
let ``FindByPermalink succeeds when a page is not found (no such permalink)`` (data: IData) = task {
let! page = data.Page.FindByPermalink (Permalink "1970/no-www-then.html") rootId
Expect.isNone page "The page should not have been retrieved"
}
let ``FindCurrentPermalink succeeds when a page is found`` (data: IData) = task {
let! link = data.Page.FindCurrentPermalink [ Permalink "a-cool-pg.html"; Permalink "a-cool-pg.html/" ] rootId
Expect.isSome link "A permalink should have been returned"
Expect.equal link (Some (Permalink "a-cool-page.html")) "The wrong permalink was retrieved"
}
let ``FindCurrentPermalink succeeds when a page is not found`` (data: IData) = task {
let! link = data.Page.FindCurrentPermalink [ Permalink "blah/"; Permalink "blah" ] rootId
Expect.isNone link "A permalink should not have been returned"
}
let ``FindFullById succeeds when a page is found`` (data: IData) = task {
let! page = data.Page.FindFullById coolPageId rootId
Expect.isSome page "A page should have been returned"
let pg = page.Value
Expect.equal pg.Id coolPageId "The wrong page was retrieved"
Expect.equal pg.WebLogId rootId "The page's web log did not match the called parameter"
Expect.equal
pg.Revisions
[ { AsOf = coolPagePublished; Text = Markdown "# A Cool Page\n\nIt really is cool!" } ]
"Revisions are incorrect"
Expect.equal pg.PriorPermalinks [ Permalink "a-cool-pg.html" ] "Prior permalinks are incorrect"
}
let ``FindFullById succeeds when a page is not found`` (data: IData) = task {
let! page = data.Page.FindFullById (PageId "not-there") rootId
Expect.isNone page "A page should not have been retrieved"
}
let ``FindFullByWebLog succeeds when pages are found`` (data: IData) = task {
let! pages = data.Page.FindFullByWebLog rootId
Expect.hasLength pages 2 "There should have been 2 pages returned"
pages |> List.iter (fun pg ->
Expect.contains [ coolPageId; otherPageId ] pg.Id $"Page ID {pg.Id} unexpected"
if pg.Id = coolPageId then
Expect.isNonEmpty pg.Metadata "Metadata should have been retrieved"
Expect.isNonEmpty pg.PriorPermalinks "Prior permalinks should have been retrieved"
Expect.isNonEmpty pg.Revisions "Revisions should have been retrieved")
}
let ``FindFullByWebLog succeeds when pages are not found`` (data: IData) = task {
let! pages = data.Page.FindFullByWebLog (WebLogId "does-not-exist")
Expect.isEmpty pages "No pages should have been retrieved"
}
let ``FindListed succeeds when pages are found`` (data: IData) = task {
let! pages = data.Page.FindListed rootId
Expect.hasLength pages 1 "There should have been 1 page returned"
Expect.equal pages[0].Id otherPageId "An unexpected page was returned"
Expect.equal pages[0].Text "" "Text should not have been returned"
Expect.isEmpty pages[0].PriorPermalinks "Prior permalinks should not have been retrieved"
Expect.isEmpty pages[0].Revisions "Revisions should not have been retrieved"
}
let ``FindListed succeeds when pages are not found`` (data: IData) = task {
let! pages = data.Page.FindListed (WebLogId "none")
Expect.isEmpty pages "No pages should have been retrieved"
}
let ``FindPageOfPages succeeds when pages are found`` (data: IData) = task {
let! pages = data.Page.FindPageOfPages rootId 1
Expect.hasLength pages 2 "There should have been 2 page returned"
Expect.equal pages[0].Id coolPageId "Pages not sorted correctly"
pages |> List.iteri (fun idx pg ->
Expect.notEqual pg.Text "" $"Text for page {idx} should have been retrieved"
Expect.isEmpty pg.Metadata $"Metadata for page {idx} should not have been retrieved"
Expect.isEmpty pg.PriorPermalinks $"Prior permalinks for page {idx} should not have been retrieved"
Expect.isEmpty pg.Revisions $"Revisions for page {idx} should not have been retrieved")
}
let ``FindPageOfPages succeeds when pages are not found`` (data: IData) = task {
let! pages = data.Page.FindPageOfPages rootId 2
Expect.isEmpty pages "No pages should have been retrieved"
}
let ``Update succeeds when the page exists`` (data: IData) = task {
let! page = data.Page.FindFullById coolPageId rootId
Expect.isSome page "A page should have been returned"
do! data.Page.Update
{ page.Value with
Title = "This Is Neat"
Permalink = Permalink "neat-page.html"
UpdatedOn = page.Value.PublishedOn + Duration.FromHours 5
IsInPageList = true
Text = "<p>I have been updated"
Metadata = [ List.head page.Value.Metadata ]
PriorPermalinks = [ Permalink "a-cool-page.html" ]
Revisions =
{ AsOf = page.Value.PublishedOn + Duration.FromHours 5; Text = Html "<p>I have been updated" }
:: page.Value.Revisions }
let! updated = data.Page.FindFullById coolPageId rootId
Expect.isSome updated "The updated page should have been returned"
let pg = updated.Value
Expect.equal pg.Title "This Is Neat" "Title is incorrect"
Expect.equal pg.Permalink (Permalink "neat-page.html") "Permalink is incorrect"
Expect.equal pg.PublishedOn coolPagePublished "Published On is incorrect"
Expect.equal pg.UpdatedOn (coolPagePublished + Duration.FromHours 5) "Updated On is incorrect"
Expect.isTrue pg.IsInPageList "Is in page list flag should have been set"
Expect.equal pg.Text "<p>I have been updated" "Text is incorrect"
Expect.equal pg.Metadata [ { Name = "Cool"; Value = "true" } ] "Metadata is incorrect"
Expect.equal pg.PriorPermalinks [ Permalink "a-cool-page.html" ] "Prior permalinks are incorrect"
Expect.equal
pg.Revisions
[ { AsOf = coolPagePublished + Duration.FromHours 5; Text = Html "<p>I have been updated" }
{ AsOf = coolPagePublished; Text = Markdown "# A Cool Page\n\nIt really is cool!" } ]
"Revisions are incorrect"
}
let ``Update succeeds when the page does not exist`` (data: IData) = task {
let pageId = PageId "missing-page"
do! data.Page.Update { Page.Empty with Id = pageId; WebLogId = rootId }
let! page = data.Page.FindById pageId rootId
Expect.isNone page "A page should not have been retrieved"
}
let ``UpdatePriorPermalinks succeeds when the page exists`` (data: IData) = task {
let links = [ Permalink "link-1.html"; Permalink "link-1.aspx"; Permalink "link-3.php" ]
let! found = data.Page.UpdatePriorPermalinks otherPageId rootId links
Expect.isTrue found "The permalinks should have been updated"
let! page = data.Page.FindFullById otherPageId rootId
Expect.isSome page "The page should have been found"
Expect.equal page.Value.PriorPermalinks links "The prior permalinks were not correct"
}
let ``UpdatePriorPermalinks succeeds when the page does not exist`` (data: IData) = task {
let! found =
data.Page.UpdatePriorPermalinks (PageId "no-page") WebLogId.Empty
[ Permalink "link-1.html"; Permalink "link-1.aspx"; Permalink "link-3.php" ]
Expect.isFalse found "The permalinks should not have been updated"
}
let ``Delete succeeds when a page is deleted`` (data: IData) = task {
let! deleted = data.Page.Delete coolPageId rootId
Expect.isTrue deleted "The page should have been deleted"
}
let ``Delete succeeds when a page is not deleted`` (data: IData) = task {
let! deleted = data.Page.Delete coolPageId rootId // this was deleted above
Expect.isFalse deleted "A page should not have been deleted"
}

View File

@@ -0,0 +1,431 @@
/// <summary>
/// Integration tests for <see cref="IPostData" /> implementations
/// </summary>
module PostDataTests
open System
open Expecto
open MyWebLog
open MyWebLog.Data
open NodaTime
/// The ID of the root web log
let private rootId = CategoryDataTests.rootId
/// The ID of podcast episode 1
let private episode1 = PostId "osxMfWGlAkyugUbJ1-xD1g"
/// The published instant for episode 1
let private episode1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:24:01Z")
/// The ID of podcast episode 2
let episode2 = PostId "l4_Eh4aFO06SqqJjOymNzA"
/// The ID of "Something May Happen" post
let private something = PostId "QweKbWQiOkqqrjEdgP9wwg"
/// The published instant for "Something May Happen" post
let private somethingPublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:32:59Z")
/// The ID of "An Incomplete Thought" post
let private incomplete = PostId "VweKbWQiOkqqrjEdgP9wwg"
/// The ID of "Test Post 1" post
let private testPost1 = PostId "RCsCU2puYEmkpzotoi8p4g"
/// The published instant for "Test Post 1" post
let private testPost1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:17:29Z")
/// The category IDs for "Spitball" (parent) and "Moonshot"
let private testCatIds = [ CategoryId "jw6N69YtTEWVHAO33jHU-w"; CategoryId "ScVpyu1e7UiP7bDdge3ZEw" ]
/// Ensure that a list of posts has text for each post
let private ensureHasText (posts: Post list) =
for post in posts do Expect.isNotEmpty post.Text $"Text should not be blank (post ID {post.Id})"
/// Ensure that a list of posts has no revisions or prior permalinks
let private ensureEmpty posts =
for post in posts do
Expect.isEmpty post.Revisions $"There should have been no revisions (post ID {post.Id})"
Expect.isEmpty post.PriorPermalinks $"There should have been no prior permalinks (post ID {post.Id})"
let ``Add succeeds`` (data: IData) = task {
let post =
{ Id = PostId "a-new-post"
WebLogId = WebLogId "test"
AuthorId = WebLogUserId "test-author"
Status = Published
Title = "A New Test Post"
Permalink = Permalink "2020/test-post.html"
PublishedOn = Some (Noda.epoch + Duration.FromMinutes 1L)
UpdatedOn = Noda.epoch + Duration.FromMinutes 3L
Template = Some "fancy"
Text = "<p>Test text here"
CategoryIds = [ CategoryId "a"; CategoryId "b" ]
Tags = [ "x"; "y"; "zed" ]
Episode = Some { Episode.Empty with Media = "test-ep.mp3" }
Metadata = [ { Name = "Meta"; Value = "Data" } ]
PriorPermalinks = [ Permalink "2020/test-post-a.html" ]
Revisions = [ { AsOf = Noda.epoch + Duration.FromMinutes 1L; Text = Html "<p>Test text here" } ] }
do! data.Post.Add post
let! stored = data.Post.FindFullById post.Id post.WebLogId
Expect.isSome stored "The added post should have been retrieved"
let it = stored.Value
Expect.equal it.Id post.Id "ID not saved properly"
Expect.equal it.WebLogId post.WebLogId "Web log ID not saved properly"
Expect.equal it.AuthorId post.AuthorId "Author ID not saved properly"
Expect.equal it.Status post.Status "Status not saved properly"
Expect.equal it.Title post.Title "Title not saved properly"
Expect.equal it.Permalink post.Permalink "Permalink not saved properly"
Expect.equal it.PublishedOn post.PublishedOn "Published On not saved properly"
Expect.equal it.UpdatedOn post.UpdatedOn "Updated On not saved properly"
Expect.equal it.Template post.Template "Template not saved properly"
Expect.equal it.Text post.Text "Text not saved properly"
Expect.equal it.CategoryIds post.CategoryIds "Category IDs not saved properly"
Expect.equal it.Tags post.Tags "Tags not saved properly"
Expect.equal it.Episode post.Episode "Episode 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.Revisions post.Revisions "Revisions not saved properly"
}
let ``CountByStatus succeeds`` (data: IData) = task {
let! count = data.Post.CountByStatus Published rootId
Expect.equal count 4 "There should be 4 published posts"
}
let ``FindById succeeds when a post is found`` (data: IData) = task {
let! post = data.Post.FindById episode1 rootId
Expect.isSome post "There should have been a post returned"
let it = post.Value
Expect.equal it.Id episode1 "An incorrect post was retrieved"
Expect.equal it.WebLogId rootId "The post belongs to an incorrect web log"
Expect.equal it.AuthorId (WebLogUserId "5EM2rimH9kONpmd2zQkiVA") "Author ID is incorrect"
Expect.equal it.Status Published "Status is incorrect"
Expect.equal it.Title "Episode 1" "Title is incorrect"
Expect.equal it.Permalink (Permalink "2024/episode-1.html") "Permalink is incorrect"
Expect.equal it.PublishedOn (Some episode1Published) "Published On is incorrect"
Expect.equal it.UpdatedOn episode1Published "Updated On is incorrect"
Expect.equal it.Text "<p>It's the launch of my new podcast - y'all come listen!" "Text is incorrect"
Expect.equal it.CategoryIds [ CategoryId "S5JflPsJ9EG7gA2LD4m92A" ] "Category IDs are incorrect"
Expect.equal it.Tags [ "general"; "podcast" ] "Tags are incorrect"
Expect.isSome it.Episode "There should be an episode associated with this post"
let ep = it.Episode.Value
Expect.equal ep.Media "episode-1.mp3" "Episode media is incorrect"
Expect.equal ep.Length 124302L "Episode length is incorrect"
Expect.equal
ep.Duration (Some (Duration.FromMinutes 12L + Duration.FromSeconds 22L)) "Episode duration is incorrect"
Expect.equal ep.ImageUrl (Some "images/ep1-cover.png") "Episode image URL is incorrect"
Expect.equal ep.Subtitle (Some "An introduction to this podcast") "Episode subtitle is incorrect"
Expect.equal ep.Explicit (Some Clean) "Episode explicit rating is incorrect"
Expect.equal ep.ChapterFile (Some "uploads/chapters.json") "Episode chapter file is incorrect"
Expect.equal ep.TranscriptUrl (Some "uploads/transcript.srt") "Episode transcript URL is incorrect"
Expect.equal ep.TranscriptType (Some "application/srt") "Episode transcript type is incorrect"
Expect.equal ep.TranscriptLang (Some "en") "Episode transcript language is incorrect"
Expect.equal ep.TranscriptCaptions (Some true) "Episode transcript caption flag is incorrect"
Expect.equal ep.SeasonNumber (Some 1) "Episode season number is incorrect"
Expect.equal ep.SeasonDescription (Some "The First Season") "Episode season description is incorrect"
Expect.equal ep.EpisodeNumber (Some 1.) "Episode number is incorrect"
Expect.equal ep.EpisodeDescription (Some "The first episode ever!") "Episode description is incorrect"
Expect.equal
it.Metadata
[ { Name = "Density"; Value = "Non-existent" }; { Name = "Intensity"; Value = "Low" } ]
"Metadata is incorrect"
ensureEmpty [ it ]
}
let ``FindById succeeds when a post is not found (incorrect weblog)`` (data: IData) = task {
let! post = data.Post.FindById episode1 (WebLogId "wrong")
Expect.isNone post "The post should not have been retrieved"
}
let ``FindById succeeds when a post is not found (bad post ID)`` (data: IData) = task {
let! post = data.Post.FindById (PostId "absent") rootId
Expect.isNone post "The post should not have been retrieved"
}
let ``FindByPermalink succeeds when a post is found`` (data: IData) = task {
let! post = data.Post.FindByPermalink (Permalink "2024/episode-1.html") rootId
Expect.isSome post "A post should have been returned"
let it = post.Value
Expect.equal it.Id episode1 "The wrong post was retrieved"
ensureEmpty [ it ]
}
let ``FindByPermalink succeeds when a post is not found (incorrect weblog)`` (data: IData) = task {
let! post = data.Post.FindByPermalink (Permalink "2024/episode-1.html") (WebLogId "incorrect")
Expect.isNone post "The post should not have been retrieved"
}
let ``FindByPermalink succeeds when a post is not found (no such permalink)`` (data: IData) = task {
let! post = data.Post.FindByPermalink (Permalink "404") rootId
Expect.isNone post "The post should not have been retrieved"
}
let ``FindCurrentPermalink succeeds when a post is found`` (data: IData) = task {
let! link = data.Post.FindCurrentPermalink [ Permalink "2024/ep-1.html"; Permalink "2024/ep-1.html/" ] rootId
Expect.isSome link "A permalink should have been returned"
Expect.equal link (Some (Permalink "2024/episode-1.html")) "The wrong permalink was retrieved"
}
let ``FindCurrentPermalink succeeds when a post is not found`` (data: IData) = task {
let! link = data.Post.FindCurrentPermalink [ Permalink "oops/"; Permalink "oops" ] rootId
Expect.isNone link "A permalink should not have been returned"
}
let ``FindFullById succeeds when a post is found`` (data: IData) = task {
let! post = data.Post.FindFullById episode1 rootId
Expect.isSome post "A post should have been returned"
let it = post.Value
Expect.equal it.Id episode1 "The wrong post was retrieved"
Expect.equal it.WebLogId rootId "The post's web log did not match the called parameter"
Expect.equal
it.Revisions
[ { AsOf = episode1Published; Text = Html "<p>It's the launch of my new podcast - y'all come listen!" } ]
"Revisions are incorrect"
Expect.equal it.PriorPermalinks [ Permalink "2024/ep-1.html" ] "Prior permalinks are incorrect"
}
let ``FindFullById succeeds when a post is not found`` (data: IData) = task {
let! post = data.Post.FindFullById (PostId "no-post") rootId
Expect.isNone post "A page should not have been retrieved"
}
let ``FindFullByWebLog succeeds when posts are found`` (data: IData) = task {
let! posts = data.Post.FindFullByWebLog rootId
Expect.hasLength posts 5 "There should have been 5 posts returned"
let allPosts = [ testPost1; episode1; episode2; something; incomplete ]
posts |> List.iter (fun it ->
Expect.contains allPosts it.Id $"Post ID {it.Id} unexpected"
if it.Id = episode1 then
Expect.isNonEmpty it.Metadata "Metadata should have been retrieved"
Expect.isNonEmpty it.PriorPermalinks "Prior permalinks should have been retrieved"
Expect.isNonEmpty it.Revisions "Revisions should have been retrieved")
}
let ``FindFullByWebLog succeeds when posts are not found`` (data: IData) = task {
let! posts = data.Post.FindFullByWebLog (WebLogId "nonexistent")
Expect.isEmpty posts "No posts should have been retrieved"
}
let ``FindPageOfCategorizedPosts succeeds when posts are found`` (data: IData) = task {
let! posts = data.Post.FindPageOfCategorizedPosts rootId testCatIds 1 1
Expect.hasLength posts 2 "There should be 2 posts returned"
Expect.equal posts[0].Id something "The wrong post was returned for page 1"
ensureEmpty posts
let! posts = data.Post.FindPageOfCategorizedPosts rootId testCatIds 2 1
Expect.hasLength posts 1 "There should be 1 post returned"
Expect.equal posts[0].Id testPost1 "The wrong post was returned for page 2"
ensureEmpty posts
}
let ``FindPageOfCategorizedPosts succeeds when finding a too-high page number`` (data: IData) = task {
let! posts = data.Post.FindPageOfCategorizedPosts rootId testCatIds 17 2
Expect.hasLength posts 0 "There should have been no posts returned (not enough posts)"
}
let ``FindPageOfCategorizedPosts succeeds when a category has no posts`` (data: IData) = task {
let! posts = data.Post.FindPageOfCategorizedPosts rootId [ CategoryId "nope" ] 1 1
Expect.hasLength posts 0 "There should have been no posts returned (none match)"
}
let ``FindPageOfPosts succeeds when posts are found`` (data: IData) = task {
let ensureNoText (posts: Post list) =
for post in posts do Expect.equal post.Text "" $"There should be no text (post ID {post.Id})"
let! posts = data.Post.FindPageOfPosts rootId 1 2
Expect.hasLength posts 3 "There should have been 3 posts returned for page 1"
Expect.equal posts[0].Id incomplete "Page 1, post 1 is incorrect"
Expect.equal posts[1].Id something "Page 1, post 2 is incorrect"
Expect.equal posts[2].Id episode2 "Page 1, post 3 is incorrect"
ensureNoText posts
ensureEmpty posts
let! posts = data.Post.FindPageOfPosts rootId 2 2
Expect.hasLength posts 3 "There should have been 3 posts returned for page 2"
Expect.equal posts[0].Id episode2 "Page 2, post 1 is incorrect"
Expect.equal posts[1].Id episode1 "Page 2, post 2 is incorrect"
Expect.equal posts[2].Id testPost1 "Page 2, post 3 is incorrect"
ensureNoText posts
ensureEmpty posts
let! posts = data.Post.FindPageOfPosts rootId 3 2
Expect.hasLength posts 1 "There should have been 1 post returned for page 3"
Expect.equal posts[0].Id testPost1 "Page 3, post 1 is incorrect"
ensureNoText posts
ensureEmpty posts
}
let ``FindPageOfPosts succeeds when finding a too-high page number`` (data: IData) = task {
let! posts = data.Post.FindPageOfPosts rootId 88 3
Expect.isEmpty posts "There should have been no posts returned (not enough posts)"
}
let ``FindPageOfPosts succeeds when there are no posts`` (data: IData) = task {
let! posts = data.Post.FindPageOfPosts (WebLogId "no-posts") 1 25
Expect.isEmpty posts "There should have been no posts returned (no posts)"
}
let ``FindPageOfPublishedPosts succeeds when posts are found`` (data: IData) = task {
let! posts = data.Post.FindPageOfPublishedPosts rootId 1 3
Expect.hasLength posts 4 "There should have been 4 posts returned for page 1"
Expect.equal posts[0].Id something "Page 1, post 1 is incorrect"
Expect.equal posts[1].Id episode2 "Page 1, post 2 is incorrect"
Expect.equal posts[2].Id episode1 "Page 1, post 3 is incorrect"
Expect.equal posts[3].Id testPost1 "Page 1, post 4 is incorrect"
ensureHasText posts
ensureEmpty posts
let! posts = data.Post.FindPageOfPublishedPosts rootId 2 2
Expect.hasLength posts 2 "There should have been 2 posts returned for page 2"
Expect.equal posts[0].Id episode1 "Page 2, post 1 is incorrect"
Expect.equal posts[1].Id testPost1 "Page 2, post 2 is incorrect"
ensureHasText posts
ensureEmpty posts
}
let ``FindPageOfPublishedPosts succeeds when finding a too-high page number`` (data: IData) = task {
let! posts = data.Post.FindPageOfPublishedPosts rootId 7 22
Expect.isEmpty posts "There should have been no posts returned (not enough posts)"
}
let ``FindPageOfPublishedPosts succeeds when there are no posts`` (data: IData) = task {
let! posts = data.Post.FindPageOfPublishedPosts (WebLogId "empty") 1 8
Expect.isEmpty posts "There should have been no posts returned (no posts)"
}
let ``FindPageOfTaggedPosts succeeds when posts are found`` (data: IData) = task {
let! posts = data.Post.FindPageOfTaggedPosts rootId "f#" 1 1
Expect.hasLength posts 2 "There should have been 2 posts returned"
Expect.equal posts[0].Id something "Page 1, post 1 is incorrect"
Expect.equal posts[1].Id testPost1 "Page 1, post 2 is incorrect"
ensureHasText posts
ensureEmpty posts
let! posts = data.Post.FindPageOfTaggedPosts rootId "f#" 2 1
Expect.hasLength posts 1 "There should have been 1 posts returned"
Expect.equal posts[0].Id testPost1 "Page 2, post 1 is incorrect"
ensureHasText posts
ensureEmpty posts
}
let ``FindPageOfTaggedPosts succeeds when posts are found (excluding drafts)`` (data: IData) = task {
let! posts = data.Post.FindPageOfTaggedPosts rootId "speculation" 1 10
Expect.hasLength posts 1 "There should have been 1 post returned"
Expect.equal posts[0].Id something "Post 1 is incorrect"
ensureHasText posts
ensureEmpty posts
}
let ``FindPageOfTaggedPosts succeeds when finding a too-high page number`` (data: IData) = task {
let! posts = data.Post.FindPageOfTaggedPosts rootId "f#" 436 18
Expect.isEmpty posts "There should have been no posts returned (not enough posts)"
}
let ``FindPageOfTaggedPosts succeeds when there are no posts`` (data: IData) = task {
let! posts = data.Post.FindPageOfTaggedPosts rootId "non-existent-tag" 1 8
Expect.isEmpty posts "There should have been no posts returned (no posts)"
}
let ``FindSurroundingPosts succeeds when there is no next newer post`` (data: IData) = task {
let! older, newer = data.Post.FindSurroundingPosts rootId somethingPublished
Expect.isSome older "There should have been an older post"
Expect.equal older.Value.Id episode2 "The next older post is incorrect"
ensureHasText [ older.Value ]
ensureEmpty [ older.Value ]
Expect.isNone newer "There should not have been a newer post"
}
let ``FindSurroundingPosts succeeds when there is no next older post`` (data: IData) = task {
let! older, newer = data.Post.FindSurroundingPosts rootId testPost1Published
Expect.isNone older "There should not have been an older post"
Expect.isSome newer "There should have been a newer post"
Expect.equal newer.Value.Id episode1 "The next newer post is incorrect"
ensureHasText [ newer.Value ]
ensureEmpty [ newer.Value ]
}
let ``FindSurroundingPosts succeeds when older and newer exist`` (data: IData) = task {
let! older, newer = data.Post.FindSurroundingPosts rootId episode1Published
Expect.isSome older "There should have been an older post"
Expect.equal older.Value.Id testPost1 "The next older post is incorrect"
Expect.isSome newer "There should have been a newer post"
Expect.equal newer.Value.Id episode2 "The next newer post is incorrect"
ensureHasText [ older.Value; newer.Value ]
ensureEmpty [ older.Value; newer.Value ]
}
let ``Update succeeds when the post exists`` (data: IData) = task {
let! before = data.Post.FindFullById (PostId "a-new-post") (WebLogId "test")
Expect.isSome before "The post to be updated should have been found"
do! data.Post.Update
{ before.Value with
AuthorId = WebLogUserId "someone-else"
Status = Draft
Title = "An Updated Test Post"
Permalink = Permalink "2021/updated-post.html"
PublishedOn = None
UpdatedOn = Noda.epoch + Duration.FromDays 4
Template = Some "other"
Text = "<p>Updated text here"
CategoryIds = [ CategoryId "c"; CategoryId "d"; CategoryId "e" ]
Tags = [ "alpha"; "beta"; "nu"; "zeta" ]
Episode = None
Metadata = [ { Name = "Howdy"; Value = "Pardner" } ]
PriorPermalinks = Permalink "2020/test-post.html" :: before.Value.PriorPermalinks
Revisions =
{ AsOf = Noda.epoch + Duration.FromDays 4; Text = Html "<p>Updated text here" }
:: before.Value.Revisions }
let! after = data.Post.FindFullById (PostId "a-new-post") (WebLogId "test")
Expect.isSome after "The updated post should have been found"
let post = after.Value
Expect.equal post.AuthorId (WebLogUserId "someone-else") "Updated author is incorrect"
Expect.equal post.Status Draft "Updated status is incorrect"
Expect.equal post.Title "An Updated Test Post" "Updated title is incorrect"
Expect.equal post.Permalink (Permalink "2021/updated-post.html") "Updated permalink is incorrect"
Expect.isNone post.PublishedOn "Updated post should not have had a published-on date/time"
Expect.equal post.UpdatedOn (Noda.epoch + Duration.FromDays 4) "Updated updated-on date/time is incorrect"
Expect.equal post.Template (Some "other") "Updated template is incorrect"
Expect.equal post.Text "<p>Updated text here" "Updated text is incorrect"
Expect.equal
post.CategoryIds [ CategoryId "c"; CategoryId "d"; CategoryId "e" ] "Updated category IDs are incorrect"
Expect.equal post.Tags [ "alpha"; "beta"; "nu"; "zeta" ] "Updated tags are incorrect"
Expect.isNone post.Episode "Update episode is incorrect"
Expect.equal post.Metadata [ { Name = "Howdy"; Value = "Pardner" } ] "Updated metadata is incorrect"
Expect.equal
post.PriorPermalinks
[ Permalink "2020/test-post.html"; Permalink "2020/test-post-a.html" ]
"Updated prior permalinks are incorrect"
Expect.equal
post.Revisions
[ { AsOf = Noda.epoch + Duration.FromDays 4; Text = Html "<p>Updated text here" }
{ AsOf = Noda.epoch + Duration.FromMinutes 1L; Text = Html "<p>Test text here" } ]
"Updated revisions are incorrect"
}
let ``Update succeeds when the post does not exist`` (data: IData) = task {
let postId = PostId "lost-post"
do! data.Post.Update { Post.Empty with Id = postId; WebLogId = rootId }
let! post = data.Post.FindById postId rootId
Expect.isNone post "A post should not have been retrieved"
}
let ``UpdatePriorPermalinks succeeds when the post exists`` (data: IData) = task {
let links = [ Permalink "2024/ep-1.html"; Permalink "2023/ep-1.html" ]
let! found = data.Post.UpdatePriorPermalinks episode1 rootId links
Expect.isTrue found "The permalinks should have been updated"
let! post = data.Post.FindFullById episode1 rootId
Expect.isSome post "The post should have been found"
Expect.equal post.Value.PriorPermalinks links "The prior permalinks were not correct"
}
let ``UpdatePriorPermalinks succeeds when the post does not exist`` (data: IData) = task {
let! found =
data.Post.UpdatePriorPermalinks (PostId "silence") WebLogId.Empty [ Permalink "a.html"; Permalink "b.html" ]
Expect.isFalse found "The permalinks should not have been updated"
}
let ``Delete succeeds when a post is deleted`` (data: IData) = task {
let! deleted = data.Post.Delete episode2 rootId
Expect.isTrue deleted "The post should have been deleted"
}
let ``Delete succeeds when a post is not deleted`` (data: IData) = task {
let! deleted = data.Post.Delete episode2 rootId // this was deleted above
Expect.isFalse deleted "A post should not have been deleted"
}

View File

@@ -0,0 +1,722 @@
module PostgresDataTests
open BitBadger.Documents.Postgres
open Expecto
open Microsoft.Extensions.Logging.Abstractions
open MyWebLog
open MyWebLog.Converters
open MyWebLog.Data
open Newtonsoft.Json
open Npgsql
open ThrowawayDb.Postgres
/// JSON serializer
let private ser = Json.configure (JsonSerializer.CreateDefault())
/// The throwaway database (deleted when disposed)
let mutable private db: ThrowawayDatabase option = None
/// Create a PostgresData instance for testing
let private mkData () =
PostgresData(NullLogger<PostgresData>(), ser) :> IData
/// The host for the PostgreSQL test database (defaults to localhost)
let private testHost =
RethinkDbDataTests.env "PG_HOST" "localhost"
/// The database name for the PostgreSQL test database (defaults to postgres)
let private testDb =
RethinkDbDataTests.env "PG_DB" "postgres"
/// The user ID for the PostgreSQL test database (defaults to postgres)
let private testUser =
RethinkDbDataTests.env "PG_USER" "postgres"
/// The password for the PostgreSQL test database (defaults to postgres)
let private testPw =
RethinkDbDataTests.env "PG_PW" "postgres"
/// Create a fresh environment from the root backup
let private freshEnvironment () = task {
if Option.isSome db then db.Value.Dispose()
db <- Some (ThrowawayDatabase.Create $"Host={testHost};Database={testDb};User ID={testUser};Password={testPw}")
let source = NpgsqlDataSourceBuilder db.Value.ConnectionString
let _ = source.UseNodaTime()
Configuration.useDataSource (source.Build())
let env = mkData ()
do! env.StartUp()
// This exercises Restore for all implementations; all tests are dependent on it working as expected
do! Maintenance.Backup.restoreBackup "root-weblog.json" None false false env
}
/// Set up the environment for the PostgreSQL tests
let private environmentSetUp = testTask "creating database" {
do! freshEnvironment ()
}
/// Integration tests for the Category implementation in PostgreSQL
let private categoryTests = testList "Category" [
testTask "Add succeeds" {
do! CategoryDataTests.``Add succeeds`` (mkData ())
}
testList "CountAll" [
testTask "succeeds when categories exist" {
do! CategoryDataTests.``CountAll succeeds when categories exist`` (mkData ())
}
testTask "succeeds when categories do not exist" {
do! CategoryDataTests.``CountAll succeeds when categories do not exist`` (mkData ())
}
]
testList "CountTopLevel" [
testTask "succeeds when top-level categories exist" {
do! CategoryDataTests.``CountTopLevel succeeds when top-level categories exist`` (mkData ())
}
testTask "succeeds when no top-level categories exist" {
do! CategoryDataTests.``CountTopLevel succeeds when no top-level categories exist`` (mkData ())
}
]
testTask "FindAllForView succeeds" {
do! CategoryDataTests.``FindAllForView succeeds`` (mkData ())
}
testList "FindById" [
testTask "succeeds when a category is found" {
do! CategoryDataTests.``FindById succeeds when a category is found`` (mkData ())
}
testTask "succeeds when a category is not found" {
do! CategoryDataTests.``FindById succeeds when a category is not found`` (mkData ())
}
]
testList "FindByWebLog" [
testTask "succeeds when categories exist" {
do! CategoryDataTests.``FindByWebLog succeeds when categories exist`` (mkData ())
}
testTask "succeeds when no categories exist" {
do! CategoryDataTests.``FindByWebLog succeeds when no categories exist`` (mkData ())
}
]
testTask "Update succeeds" {
do! CategoryDataTests.``Update succeeds`` (mkData ())
}
testList "Delete" [
testTask "succeeds when the category is deleted (no posts)" {
do! CategoryDataTests.``Delete succeeds when the category is deleted (no posts)`` (mkData ())
}
testTask "succeeds when the category does not exist" {
do! CategoryDataTests.``Delete succeeds when the category does not exist`` (mkData ())
}
testTask "succeeds when reassigning parent category to None" {
do! CategoryDataTests.``Delete succeeds when reassigning parent category to None`` (mkData ())
}
testTask "succeeds when reassigning parent category to Some" {
do! CategoryDataTests.``Delete succeeds when reassigning parent category to Some`` (mkData ())
}
testTask "succeeds and removes category from posts" {
do! CategoryDataTests.``Delete succeeds and removes category from posts`` (mkData ())
}
]
]
/// Integration tests for the Page implementation in PostgreSQL
let private pageTests = testList "Page" [
testTask "Add succeeds" {
do! PageDataTests.``Add succeeds`` (mkData ())
}
testTask "All succeeds" {
do! PageDataTests.``All succeeds`` (mkData ())
}
testTask "CountAll succeeds" {
do! PageDataTests.``CountAll succeeds`` (mkData ())
}
testTask "CountListed succeeds" {
do! PageDataTests.``CountListed succeeds`` (mkData ())
}
testList "FindById" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindById succeeds when a page is found`` (mkData ())
}
testTask "succeeds when a page is not found (incorrect weblog)" {
do! PageDataTests.``FindById succeeds when a page is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when a page is not found (bad page ID)" {
do! PageDataTests.``FindById succeeds when a page is not found (bad page ID)`` (mkData ())
}
]
testList "FindByPermalink" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindByPermalink succeeds when a page is found`` (mkData ())
}
testTask "succeeds when a page is not found (incorrect weblog)" {
do! PageDataTests.``FindByPermalink succeeds when a page is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when a page is not found (no such permalink)" {
do! PageDataTests.``FindByPermalink succeeds when a page is not found (no such permalink)`` (mkData ())
}
]
testList "FindCurrentPermalink" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindCurrentPermalink succeeds when a page is found`` (mkData ())
}
testTask "succeeds when a page is not found" {
do! PageDataTests.``FindCurrentPermalink succeeds when a page is not found`` (mkData ())
}
]
testList "FindFullById" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindFullById succeeds when a page is found`` (mkData ())
}
testTask "succeeds when a page is not found" {
do! PageDataTests.``FindFullById succeeds when a page is not found`` (mkData ())
}
]
testList "FindFullByWebLog" [
testTask "succeeds when pages are found" {
do! PageDataTests.``FindFullByWebLog succeeds when pages are found`` (mkData ())
}
testTask "succeeds when a pages are not found" {
do! PageDataTests.``FindFullByWebLog succeeds when pages are not found`` (mkData ())
}
]
testList "FindListed" [
testTask "succeeds when pages are found" {
do! PageDataTests.``FindListed succeeds when pages are found`` (mkData ())
}
testTask "succeeds when a pages are not found" {
do! PageDataTests.``FindListed succeeds when pages are not found`` (mkData ())
}
]
testList "FindPageOfPages" [
testTask "succeeds when pages are found" {
do! PageDataTests.``FindPageOfPages succeeds when pages are found`` (mkData ())
}
testTask "succeeds when a pages are not found" {
do! PageDataTests.``FindPageOfPages succeeds when pages are not found`` (mkData ())
}
]
testList "Update" [
testTask "succeeds when the page exists" {
do! PageDataTests.``Update succeeds when the page exists`` (mkData ())
}
testTask "succeeds when the page does not exist" {
do! PageDataTests.``Update succeeds when the page does not exist`` (mkData ())
}
]
testList "UpdatePriorPermalinks" [
testTask "succeeds when the page exists" {
do! PageDataTests.``UpdatePriorPermalinks succeeds when the page exists`` (mkData ())
}
testTask "succeeds when the page does not exist" {
do! PageDataTests.``UpdatePriorPermalinks succeeds when the page does not exist`` (mkData ())
}
]
testList "Delete" [
testTask "succeeds when a page is deleted" {
do! PageDataTests.``Delete succeeds when a page is deleted`` (mkData ())
let! revisions =
Custom.scalar
"SELECT COUNT(*) AS it FROM page_revision WHERE page_id = @id"
[ idParam PageDataTests.coolPageId ]
toCount
Expect.equal revisions 0 "All revisions for the page should have been deleted"
}
testTask "succeeds when a page is not deleted" {
do! PageDataTests.``Delete succeeds when a page is not deleted`` (mkData ())
}
]
]
/// Integration tests for the Post implementation in PostgreSQL
let private postTests = testList "Post" [
testTask "Add succeeds" {
// We'll need the root website categories restored for these tests
do! freshEnvironment ()
do! PostDataTests.``Add succeeds`` (mkData ())
}
testTask "CountByStatus succeeds" {
do! PostDataTests.``CountByStatus succeeds`` (mkData ())
}
testList "FindById" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindById succeeds when a post is found`` (mkData ())
}
testTask "succeeds when a post is not found (incorrect weblog)" {
do! PostDataTests.``FindById succeeds when a post is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when a post is not found (bad post ID)" {
do! PostDataTests.``FindById succeeds when a post is not found (bad post ID)`` (mkData ())
}
]
testList "FindByPermalink" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindByPermalink succeeds when a post is found`` (mkData ())
}
testTask "succeeds when a post is not found (incorrect weblog)" {
do! PostDataTests.``FindByPermalink succeeds when a post is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when a post is not found (no such permalink)" {
do! PostDataTests.``FindByPermalink succeeds when a post is not found (no such permalink)`` (mkData ())
}
]
testList "FindCurrentPermalink" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindCurrentPermalink succeeds when a post is found`` (mkData ())
}
testTask "succeeds when a post is not found" {
do! PostDataTests.``FindCurrentPermalink succeeds when a post is not found`` (mkData ())
}
]
testList "FindFullById" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindFullById succeeds when a post is found`` (mkData ())
}
testTask "succeeds when a post is not found" {
do! PostDataTests.``FindFullById succeeds when a post is not found`` (mkData ())
}
]
testList "FindFullByWebLog" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindFullByWebLog succeeds when posts are found`` (mkData ())
}
testTask "succeeds when a posts are not found" {
do! PostDataTests.``FindFullByWebLog succeeds when posts are not found`` (mkData ())
}
]
testList "FindPageOfCategorizedPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfCategorizedPosts succeeds when posts are found`` (mkData ())
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfCategorizedPosts succeeds when finding a too-high page number`` (mkData ())
}
testTask "succeeds when a category has no posts" {
do! PostDataTests.``FindPageOfCategorizedPosts succeeds when a category has no posts`` (mkData ())
}
]
testList "FindPageOfPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfPosts succeeds when posts are found`` (mkData ())
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfPosts succeeds when finding a too-high page number`` (mkData ())
}
testTask "succeeds when there are no posts" {
do! PostDataTests.``FindPageOfPosts succeeds when there are no posts`` (mkData ())
}
]
testList "FindPageOfPublishedPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfPublishedPosts succeeds when posts are found`` (mkData ())
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfPublishedPosts succeeds when finding a too-high page number`` (mkData ())
}
testTask "succeeds when there are no posts" {
do! PostDataTests.``FindPageOfPublishedPosts succeeds when there are no posts`` (mkData ())
}
]
testList "FindPageOfTaggedPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when posts are found`` (mkData ())
}
testTask "succeeds when posts are found (excluding drafts)" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when posts are found (excluding drafts)`` (mkData ())
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when finding a too-high page number`` (mkData ())
}
testTask "succeeds when there are no posts" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when there are no posts`` (mkData ())
}
]
testList "FindSurroundingPosts" [
testTask "succeeds when there is no next newer post" {
do! PostDataTests.``FindSurroundingPosts succeeds when there is no next newer post`` (mkData ())
}
testTask "succeeds when there is no next older post" {
do! PostDataTests.``FindSurroundingPosts succeeds when there is no next older post`` (mkData ())
}
testTask "succeeds when older and newer exist" {
do! PostDataTests.``FindSurroundingPosts succeeds when older and newer exist`` (mkData ())
}
]
testList "Update" [
testTask "succeeds when the post exists" {
do! PostDataTests.``Update succeeds when the post exists`` (mkData ())
}
testTask "succeeds when the post does not exist" {
do! PostDataTests.``Update succeeds when the post does not exist`` (mkData ())
}
]
testList "UpdatePriorPermalinks" [
testTask "succeeds when the post exists" {
do! PostDataTests.``UpdatePriorPermalinks succeeds when the post exists`` (mkData ())
}
testTask "succeeds when the post does not exist" {
do! PostDataTests.``UpdatePriorPermalinks succeeds when the post does not exist`` (mkData ())
}
]
testList "Delete" [
testTask "succeeds when a post is deleted" {
do! PostDataTests.``Delete succeeds when a post is deleted`` (mkData ())
let! revisions =
Custom.scalar
"SELECT COUNT(*) AS it FROM post_revision WHERE post_id = @id"
[ idParam PostDataTests.episode2 ]
toCount
Expect.equal revisions 0 "All revisions for the post should have been deleted"
}
testTask "succeeds when a post is not deleted" {
do! PostDataTests.``Delete succeeds when a post is not deleted`` (mkData ())
}
]
]
let private tagMapTests = testList "TagMap" [
testList "FindById" [
testTask "succeeds when a tag mapping is found" {
do! TagMapDataTests.``FindById succeeds when a tag mapping is found`` (mkData ())
}
testTask "succeeds when a tag mapping is not found (incorrect weblog)" {
do! TagMapDataTests.``FindById succeeds when a tag mapping is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when a tag mapping is not found (bad tag map ID)" {
do! TagMapDataTests.``FindById succeeds when a tag mapping is not found (bad tag map ID)`` (mkData ())
}
]
testList "FindByUrlValue" [
testTask "succeeds when a tag mapping is found" {
do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is found`` (mkData ())
}
testTask "succeeds when a tag mapping is not found (incorrect weblog)" {
do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is not found (incorrect weblog)``
(mkData ())
}
testTask "succeeds when a tag mapping is not found (no such value)" {
do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is not found (no such value)`` (mkData ())
}
]
testList "FindByWebLog" [
testTask "succeeds when tag mappings are found" {
do! TagMapDataTests.``FindByWebLog succeeds when tag mappings are found`` (mkData ())
}
testTask "succeeds when no tag mappings are found" {
do! TagMapDataTests.``FindByWebLog succeeds when no tag mappings are found`` (mkData ())
}
]
testList "FindMappingForTags" [
testTask "succeeds when mappings exist" {
do! TagMapDataTests.``FindMappingForTags succeeds when mappings exist`` (mkData ())
}
testTask "succeeds when no mappings exist" {
do! TagMapDataTests.``FindMappingForTags succeeds when no mappings exist`` (mkData ())
}
]
testList "Save" [
testTask "succeeds when adding a tag mapping" {
do! TagMapDataTests.``Save succeeds when adding a tag mapping`` (mkData ())
}
testTask "succeeds when updating a tag mapping" {
do! TagMapDataTests.``Save succeeds when updating a tag mapping`` (mkData ())
}
]
testList "Delete" [
testTask "succeeds when a tag mapping is deleted" {
do! TagMapDataTests.``Delete succeeds when a tag mapping is deleted`` (mkData ())
}
testTask "succeeds when a tag mapping is not deleted" {
do! TagMapDataTests.``Delete succeeds when a tag mapping is not deleted`` (mkData ())
}
]
]
let private themeTests = testList "Theme" [
testTask "All succeeds" {
do! ThemeDataTests.``All succeeds`` (mkData ())
}
testList "Exists" [
testTask "succeeds when the theme exists" {
do! ThemeDataTests.``Exists succeeds when the theme exists`` (mkData ())
}
testTask "succeeds when the theme does not exist" {
do! ThemeDataTests.``Exists succeeds when the theme does not exist`` (mkData ())
}
]
testList "FindById" [
testTask "succeeds when the theme exists" {
do! ThemeDataTests.``FindById succeeds when the theme exists`` (mkData ())
}
testTask "succeeds when the theme does not exist" {
do! ThemeDataTests.``FindById succeeds when the theme does not exist`` (mkData ())
}
]
testList "FindByIdWithoutText" [
testTask "succeeds when the theme exists" {
do! ThemeDataTests.``FindByIdWithoutText succeeds when the theme exists`` (mkData ())
}
testTask "succeeds when the theme does not exist" {
do! ThemeDataTests.``FindByIdWithoutText succeeds when the theme does not exist`` (mkData ())
}
]
testList "Save" [
testTask "succeeds when adding a theme" {
do! ThemeDataTests.``Save succeeds when adding a theme`` (mkData ())
}
testTask "succeeds when updating a theme" {
do! ThemeDataTests.``Save succeeds when updating a theme`` (mkData ())
}
]
testList "Delete" [
testTask "succeeds when a theme is deleted" {
do! ThemeDataTests.``Delete succeeds when a theme is deleted`` (mkData ())
}
testTask "succeeds when a theme is not deleted" {
do! ThemeDataTests.``Delete succeeds when a theme is not deleted`` (mkData ())
}
]
]
let private themeAssetTests = testList "ThemeAsset" [
testList "Save" [
testTask "succeeds when adding an asset" {
do! ThemeDataTests.Asset.``Save succeeds when adding an asset`` (mkData ())
}
testTask "succeeds when updating an asset" {
do! ThemeDataTests.Asset.``Save succeeds when updating an asset`` (mkData ())
}
]
testTask "All succeeds" {
do! ThemeDataTests.Asset.``All succeeds`` (mkData ())
}
testList "FindById" [
testTask "succeeds when an asset is found" {
do! ThemeDataTests.Asset.``FindById succeeds when an asset is found`` (mkData ())
}
testTask "succeeds when an asset is not found" {
do! ThemeDataTests.Asset.``FindById succeeds when an asset is not found`` (mkData ())
}
]
testList "FindByTheme" [
testTask "succeeds when assets exist" {
do! ThemeDataTests.Asset.``FindByTheme succeeds when assets exist`` (mkData ())
}
testTask "succeeds when assets do not exist" {
do! ThemeDataTests.Asset.``FindByTheme succeeds when assets do not exist`` (mkData ())
}
]
testList "FindByThemeWithData" [
testTask "succeeds when assets exist" {
do! ThemeDataTests.Asset.``FindByThemeWithData succeeds when assets exist`` (mkData ())
}
testTask "succeeds when assets do not exist" {
do! ThemeDataTests.Asset.``FindByThemeWithData succeeds when assets do not exist`` (mkData ())
}
]
testList "DeleteByTheme" [
testTask "succeeds when assets are deleted" {
do! ThemeDataTests.Asset.``DeleteByTheme succeeds when assets are deleted`` (mkData ())
}
testTask "succeeds when no assets are deleted" {
do! ThemeDataTests.Asset.``DeleteByTheme succeeds when no assets are deleted`` (mkData ())
}
]
]
let private uploadTests = testList "Upload" [
testTask "Add succeeds" {
do! UploadDataTests.``Add succeeds`` (mkData ())
}
testList "FindByPath" [
testTask "succeeds when an upload is found" {
do! UploadDataTests.``FindByPath succeeds when an upload is found`` (mkData ())
}
testTask "succeeds when an upload is not found (incorrect weblog)" {
do! UploadDataTests.``FindByPath succeeds when an upload is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when an upload is not found (bad path)" {
do! UploadDataTests.``FindByPath succeeds when an upload is not found (bad path)`` (mkData ())
}
]
testList "FindByWebLog" [
testTask "succeeds when uploads exist" {
do! UploadDataTests.``FindByWebLog succeeds when uploads exist`` (mkData ())
}
testTask "succeeds when no uploads exist" {
do! UploadDataTests.``FindByWebLog succeeds when no uploads exist`` (mkData ())
}
]
testList "FindByWebLogWithData" [
testTask "succeeds when uploads exist" {
do! UploadDataTests.``FindByWebLogWithData succeeds when uploads exist`` (mkData ())
}
testTask "succeeds when no uploads exist" {
do! UploadDataTests.``FindByWebLogWithData succeeds when no uploads exist`` (mkData ())
}
]
testList "Delete" [
testTask "succeeds when an upload is deleted" {
do! UploadDataTests.``Delete succeeds when an upload is deleted`` (mkData ())
}
testTask "succeeds when an upload is not deleted" {
do! UploadDataTests.``Delete succeeds when an upload is not deleted`` (mkData ())
}
]
]
let private webLogUserTests = testList "WebLogUser" [
testTask "Add succeeds" {
// This restore ensures all the posts and pages exist
do! freshEnvironment ()
do! WebLogUserDataTests.``Add succeeds`` (mkData ())
}
testList "FindByEmail" [
testTask "succeeds when a user is found" {
do! WebLogUserDataTests.``FindByEmail succeeds when a user is found`` (mkData ())
}
testTask "succeeds when a user is not found (incorrect weblog)" {
do! WebLogUserDataTests.``FindByEmail succeeds when a user is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when a user is not found (bad email)" {
do! WebLogUserDataTests.``FindByEmail succeeds when a user is not found (bad email)`` (mkData ())
}
]
testList "FindById" [
testTask "succeeds when a user is found" {
do! WebLogUserDataTests.``FindById succeeds when a user is found`` (mkData ())
}
testTask "succeeds when a user is not found (incorrect weblog)" {
do! WebLogUserDataTests.``FindById succeeds when a user is not found (incorrect weblog)`` (mkData ())
}
testTask "succeeds when a user is not found (bad ID)" {
do! WebLogUserDataTests.``FindById succeeds when a user is not found (bad ID)`` (mkData ())
}
]
testList "FindByWebLog" [
testTask "succeeds when users exist" {
do! WebLogUserDataTests.``FindByWebLog succeeds when users exist`` (mkData ())
}
testTask "succeeds when no users exist" {
do! WebLogUserDataTests.``FindByWebLog succeeds when no users exist`` (mkData ())
}
]
testList "FindNames" [
testTask "succeeds when users exist" {
do! WebLogUserDataTests.``FindNames succeeds when users exist`` (mkData ())
}
testTask "succeeds when users do not exist" {
do! WebLogUserDataTests.``FindNames succeeds when users do not exist`` (mkData ())
}
]
testList "SetLastSeen" [
testTask "succeeds when the user exists" {
do! WebLogUserDataTests.``SetLastSeen succeeds when the user exists`` (mkData ())
}
testTask "succeeds when the user does not exist" {
do! WebLogUserDataTests.``SetLastSeen succeeds when the user does not exist`` (mkData ())
}
]
testList "Update" [
testTask "succeeds when the user exists" {
do! WebLogUserDataTests.``Update succeeds when the user exists`` (mkData ())
}
testTask "succeeds when the user does not exist" {
do! WebLogUserDataTests.``Update succeeds when the user does not exist`` (mkData ())
}
]
testList "Delete" [
testTask "fails when the user is the author of a page" {
do! WebLogUserDataTests.``Delete fails when the user is the author of a page`` (mkData ())
}
testTask "fails when the user is the author of a post" {
do! WebLogUserDataTests.``Delete fails when the user is the author of a post`` (mkData ())
}
testTask "succeeds when the user is not an author" {
do! WebLogUserDataTests.``Delete succeeds when the user is not an author`` (mkData ())
}
testTask "succeeds when the user does not exist" {
do! WebLogUserDataTests.``Delete succeeds when the user does not exist`` (mkData ())
}
]
]
let private webLogTests = testList "WebLog" [
testTask "Add succeeds" {
do! WebLogDataTests.``Add succeeds`` (mkData ())
}
testTask "All succeeds" {
do! WebLogDataTests.``All succeeds`` (mkData ())
}
testList "FindByHost" [
testTask "succeeds when a web log is found" {
do! WebLogDataTests.``FindByHost succeeds when a web log is found`` (mkData ())
}
testTask "succeeds when a web log is not found" {
do! WebLogDataTests.``FindByHost succeeds when a web log is not found`` (mkData ())
}
]
testList "FindById" [
testTask "succeeds when a web log is found" {
do! WebLogDataTests.``FindById succeeds when a web log is found`` (mkData ())
}
testTask "succeeds when a web log is not found" {
do! WebLogDataTests.``FindById succeeds when a web log is not found`` (mkData ())
}
]
testList "UpdateRedirectRules" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``UpdateRedirectRules succeeds when the web log exists`` (mkData ())
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``UpdateRedirectRules succeeds when the web log does not exist`` (mkData ())
}
]
testList "UpdateRssOptions" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``UpdateRssOptions succeeds when the web log exists`` (mkData ())
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``UpdateRssOptions succeeds when the web log does not exist`` (mkData ())
}
]
testList "UpdateSettings" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``UpdateSettings succeeds when the web log exists`` (mkData ())
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``UpdateSettings succeeds when the web log does not exist`` (mkData ())
}
]
testList "Delete" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``Delete succeeds when the web log exists`` (mkData ())
let! revisions =
Custom.scalar
"SELECT (SELECT COUNT(*) FROM page_revision) + (SELECT COUNT(*) FROM post_revision) AS it"
[]
toCount
Expect.equal revisions 0 "All revisions should be deleted"
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``Delete succeeds when the web log does not exist`` (mkData ())
}
]
]
/// Drop the throwaway PostgreSQL database
let private environmentCleanUp = test "Clean Up" {
if db.IsSome then db.Value.Dispose()
}
/// All PostgreSQL data tests
let all =
testList "PostgresData"
[ environmentSetUp
categoryTests
pageTests
postTests
tagMapTests
themeTests
themeAssetTests
uploadTests
webLogUserTests
webLogTests
environmentCleanUp ]
|> testSequenced

View File

@@ -0,0 +1,704 @@
module RethinkDbDataTests
open System
open Expecto
open Microsoft.Extensions.Logging.Abstractions
open MyWebLog
open MyWebLog.Converters
open MyWebLog.Data
open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net
/// Get an environment variable, using the given value as the default if it is not set
let env name value =
match Environment.GetEnvironmentVariable $"MWL_TEST_{name}" with
| null -> value
| it when it.Trim() = "" -> value
| it -> it
/// The data configuration for the test database
let private dataCfg =
DataConfig.FromUri (env "RETHINK_URI" "rethinkdb://172.17.0.2/mwl_test")
/// The active data instance to use for testing
let mutable private data: IData option = None
/// Dispose the existing data
let private disposeData () = task {
if data.IsSome then
let conn = (data.Value :?> RethinkDbData).Conn
do! rethink { dbDrop dataCfg.Database; write; withRetryOnce; ignoreResult conn }
conn.Dispose()
data <- None
}
/// Create a new data implementation instance
let private newData () =
let log = NullLogger<RethinkDbData>()
let conn = dataCfg.CreateConnection log
RethinkDbData(conn, dataCfg, log)
/// Create a fresh environment from the root backup
let private freshEnvironment () = task {
do! disposeData ()
data <- Some (newData ())
do! data.Value.StartUp()
// This exercises Restore for all implementations; all tests are dependent on it working as expected
do! Maintenance.Backup.restoreBackup "root-weblog.json" None false false data.Value
}
/// Set up the environment for the RethinkDB tests
let private environmentSetUp = testTask "creating database" {
let _ = Json.configure Converter.Serializer
do! freshEnvironment ()
}
/// Integration tests for the Category implementation in RethinkDB
let private categoryTests = testList "Category" [
testTask "Add succeeds" {
do! CategoryDataTests.``Add succeeds`` data.Value
}
testList "CountAll" [
testTask "succeeds when categories exist" {
do! CategoryDataTests.``CountAll succeeds when categories exist`` data.Value
}
testTask "succeeds when categories do not exist" {
do! CategoryDataTests.``CountAll succeeds when categories do not exist`` data.Value
}
]
testList "CountTopLevel" [
testTask "succeeds when top-level categories exist" {
do! CategoryDataTests.``CountTopLevel succeeds when top-level categories exist`` data.Value
}
testTask "succeeds when no top-level categories exist" {
do! CategoryDataTests.``CountTopLevel succeeds when no top-level categories exist`` data.Value
}
]
testTask "FindAllForView succeeds" {
do! CategoryDataTests.``FindAllForView succeeds`` data.Value
}
testList "FindById" [
testTask "succeeds when a category is found" {
do! CategoryDataTests.``FindById succeeds when a category is found`` data.Value
}
testTask "succeeds when a category is not found" {
do! CategoryDataTests.``FindById succeeds when a category is not found`` data.Value
}
]
testList "FindByWebLog" [
testTask "succeeds when categories exist" {
do! CategoryDataTests.``FindByWebLog succeeds when categories exist`` data.Value
}
testTask "succeeds when no categories exist" {
do! CategoryDataTests.``FindByWebLog succeeds when no categories exist`` data.Value
}
]
testTask "Update succeeds" {
do! CategoryDataTests.``Update succeeds`` data.Value
}
testList "Delete" [
testTask "succeeds when the category is deleted (no posts)" {
do! CategoryDataTests.``Delete succeeds when the category is deleted (no posts)`` data.Value
}
testTask "succeeds when the category does not exist" {
do! CategoryDataTests.``Delete succeeds when the category does not exist`` data.Value
}
testTask "succeeds when reassigning parent category to None" {
do! CategoryDataTests.``Delete succeeds when reassigning parent category to None`` data.Value
}
testTask "succeeds when reassigning parent category to Some" {
do! CategoryDataTests.``Delete succeeds when reassigning parent category to Some`` data.Value
}
testTask "succeeds and removes category from posts" {
do! CategoryDataTests.``Delete succeeds and removes category from posts`` data.Value
}
]
]
/// Integration tests for the Page implementation in RethinkDB
let private pageTests = testList "Page" [
testTask "Add succeeds" {
do! PageDataTests.``Add succeeds`` data.Value
}
testTask "All succeeds" {
do! PageDataTests.``All succeeds`` data.Value
}
testTask "CountAll succeeds" {
do! PageDataTests.``CountAll succeeds`` data.Value
}
testTask "CountListed succeeds" {
do! PageDataTests.``CountListed succeeds`` data.Value
}
testList "FindById" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindById succeeds when a page is found`` data.Value
}
testTask "succeeds when a page is not found (incorrect weblog)" {
do! PageDataTests.``FindById succeeds when a page is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when a page is not found (bad page ID)" {
do! PageDataTests.``FindById succeeds when a page is not found (bad page ID)`` data.Value
}
]
testList "FindByPermalink" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindByPermalink succeeds when a page is found`` data.Value
}
testTask "succeeds when a page is not found (incorrect weblog)" {
do! PageDataTests.``FindByPermalink succeeds when a page is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when a page is not found (no such permalink)" {
do! PageDataTests.``FindByPermalink succeeds when a page is not found (no such permalink)`` data.Value
}
]
testList "FindCurrentPermalink" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindCurrentPermalink succeeds when a page is found`` data.Value
}
testTask "succeeds when a page is not found" {
do! PageDataTests.``FindCurrentPermalink succeeds when a page is not found`` data.Value
}
]
testList "FindFullById" [
testTask "succeeds when a page is found" {
do! PageDataTests.``FindFullById succeeds when a page is found`` data.Value
}
testTask "succeeds when a page is not found" {
do! PageDataTests.``FindFullById succeeds when a page is not found`` data.Value
}
]
testList "FindFullByWebLog" [
testTask "succeeds when pages are found" {
do! PageDataTests.``FindFullByWebLog succeeds when pages are found`` data.Value
}
testTask "succeeds when a pages are not found" {
do! PageDataTests.``FindFullByWebLog succeeds when pages are not found`` data.Value
}
]
testList "FindListed" [
testTask "succeeds when pages are found" {
do! PageDataTests.``FindListed succeeds when pages are found`` data.Value
}
testTask "succeeds when a pages are not found" {
do! PageDataTests.``FindListed succeeds when pages are not found`` data.Value
}
]
testList "FindPageOfPages" [
testTask "succeeds when pages are found" {
do! PageDataTests.``FindPageOfPages succeeds when pages are found`` data.Value
}
testTask "succeeds when a pages are not found" {
do! PageDataTests.``FindPageOfPages succeeds when pages are not found`` data.Value
}
]
testList "Update" [
testTask "succeeds when the page exists" {
do! PageDataTests.``Update succeeds when the page exists`` data.Value
}
testTask "succeeds when the page does not exist" {
do! PageDataTests.``Update succeeds when the page does not exist`` data.Value
}
]
testList "UpdatePriorPermalinks" [
testTask "succeeds when the page exists" {
do! PageDataTests.``UpdatePriorPermalinks succeeds when the page exists`` data.Value
}
testTask "succeeds when the page does not exist" {
do! PageDataTests.``UpdatePriorPermalinks succeeds when the page does not exist`` data.Value
}
]
testList "Delete" [
testTask "succeeds when a page is deleted" {
do! PageDataTests.``Delete succeeds when a page is deleted`` data.Value
}
testTask "succeeds when a page is not deleted" {
do! PageDataTests.``Delete succeeds when a page is not deleted`` data.Value
}
]
]
/// Integration tests for the Post implementation in RethinkDB
let private postTests = testList "Post" [
testTask "Add succeeds" {
// We'll need the root website categories restored for these tests
do! freshEnvironment ()
do! PostDataTests.``Add succeeds`` data.Value
}
testTask "CountByStatus succeeds" {
do! PostDataTests.``CountByStatus succeeds`` data.Value
}
testList "FindById" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindById succeeds when a post is found`` data.Value
}
testTask "succeeds when a post is not found (incorrect weblog)" {
do! PostDataTests.``FindById succeeds when a post is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when a post is not found (bad post ID)" {
do! PostDataTests.``FindById succeeds when a post is not found (bad post ID)`` data.Value
}
]
testList "FindByPermalink" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindByPermalink succeeds when a post is found`` data.Value
}
testTask "succeeds when a post is not found (incorrect weblog)" {
do! PostDataTests.``FindByPermalink succeeds when a post is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when a post is not found (no such permalink)" {
do! PostDataTests.``FindByPermalink succeeds when a post is not found (no such permalink)`` data.Value
}
]
testList "FindCurrentPermalink" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindCurrentPermalink succeeds when a post is found`` data.Value
}
testTask "succeeds when a post is not found" {
do! PostDataTests.``FindCurrentPermalink succeeds when a post is not found`` data.Value
}
]
testList "FindFullById" [
testTask "succeeds when a post is found" {
do! PostDataTests.``FindFullById succeeds when a post is found`` data.Value
}
testTask "succeeds when a post is not found" {
do! PostDataTests.``FindFullById succeeds when a post is not found`` data.Value
}
]
testList "FindFullByWebLog" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindFullByWebLog succeeds when posts are found`` data.Value
}
testTask "succeeds when a posts are not found" {
do! PostDataTests.``FindFullByWebLog succeeds when posts are not found`` data.Value
}
]
testList "FindPageOfCategorizedPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfCategorizedPosts succeeds when posts are found`` data.Value
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfCategorizedPosts succeeds when finding a too-high page number`` data.Value
}
testTask "succeeds when a category has no posts" {
do! PostDataTests.``FindPageOfCategorizedPosts succeeds when a category has no posts`` data.Value
}
]
testList "FindPageOfPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfPosts succeeds when posts are found`` data.Value
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfPosts succeeds when finding a too-high page number`` data.Value
}
testTask "succeeds when there are no posts" {
do! PostDataTests.``FindPageOfPosts succeeds when there are no posts`` data.Value
}
]
testList "FindPageOfPublishedPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfPublishedPosts succeeds when posts are found`` data.Value
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfPublishedPosts succeeds when finding a too-high page number`` data.Value
}
testTask "succeeds when there are no posts" {
do! PostDataTests.``FindPageOfPublishedPosts succeeds when there are no posts`` data.Value
}
]
testList "FindPageOfTaggedPosts" [
testTask "succeeds when posts are found" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when posts are found`` data.Value
}
testTask "succeeds when posts are found (excluding drafts)" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when posts are found (excluding drafts)`` data.Value
}
testTask "succeeds when finding a too-high page number" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when finding a too-high page number`` data.Value
}
testTask "succeeds when there are no posts" {
do! PostDataTests.``FindPageOfTaggedPosts succeeds when there are no posts`` data.Value
}
]
testList "FindSurroundingPosts" [
testTask "succeeds when there is no next newer post" {
do! PostDataTests.``FindSurroundingPosts succeeds when there is no next newer post`` data.Value
}
testTask "succeeds when there is no next older post" {
do! PostDataTests.``FindSurroundingPosts succeeds when there is no next older post`` data.Value
}
testTask "succeeds when older and newer exist" {
do! PostDataTests.``FindSurroundingPosts succeeds when older and newer exist`` data.Value
}
]
testList "Update" [
testTask "succeeds when the post exists" {
do! PostDataTests.``Update succeeds when the post exists`` data.Value
}
testTask "succeeds when the post does not exist" {
do! PostDataTests.``Update succeeds when the post does not exist`` data.Value
}
]
testList "UpdatePriorPermalinks" [
testTask "succeeds when the post exists" {
do! PostDataTests.``UpdatePriorPermalinks succeeds when the post exists`` data.Value
}
testTask "succeeds when the post does not exist" {
do! PostDataTests.``UpdatePriorPermalinks succeeds when the post does not exist`` data.Value
}
]
testList "Delete" [
testTask "succeeds when a post is deleted" {
do! PostDataTests.``Delete succeeds when a post is deleted`` data.Value
}
testTask "succeeds when a post is not deleted" {
do! PostDataTests.``Delete succeeds when a post is not deleted`` data.Value
}
]
]
let private tagMapTests = testList "TagMap" [
testList "FindById" [
testTask "succeeds when a tag mapping is found" {
do! TagMapDataTests.``FindById succeeds when a tag mapping is found`` data.Value
}
testTask "succeeds when a tag mapping is not found (incorrect weblog)" {
do! TagMapDataTests.``FindById succeeds when a tag mapping is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when a tag mapping is not found (bad tag map ID)" {
do! TagMapDataTests.``FindById succeeds when a tag mapping is not found (bad tag map ID)`` data.Value
}
]
testList "FindByUrlValue" [
testTask "succeeds when a tag mapping is found" {
do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is found`` data.Value
}
testTask "succeeds when a tag mapping is not found (incorrect weblog)" {
do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is not found (incorrect weblog)``
data.Value
}
testTask "succeeds when a tag mapping is not found (no such value)" {
do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is not found (no such value)`` data.Value
}
]
testList "FindByWebLog" [
testTask "succeeds when tag mappings are found" {
do! TagMapDataTests.``FindByWebLog succeeds when tag mappings are found`` data.Value
}
testTask "succeeds when no tag mappings are found" {
do! TagMapDataTests.``FindByWebLog succeeds when no tag mappings are found`` data.Value
}
]
testList "FindMappingForTags" [
testTask "succeeds when mappings exist" {
do! TagMapDataTests.``FindMappingForTags succeeds when mappings exist`` data.Value
}
testTask "succeeds when no mappings exist" {
do! TagMapDataTests.``FindMappingForTags succeeds when no mappings exist`` data.Value
}
]
testList "Save" [
testTask "succeeds when adding a tag mapping" {
do! TagMapDataTests.``Save succeeds when adding a tag mapping`` data.Value
}
testTask "succeeds when updating a tag mapping" {
do! TagMapDataTests.``Save succeeds when updating a tag mapping`` data.Value
}
]
testList "Delete" [
testTask "succeeds when a tag mapping is deleted" {
do! TagMapDataTests.``Delete succeeds when a tag mapping is deleted`` data.Value
}
testTask "succeeds when a tag mapping is not deleted" {
do! TagMapDataTests.``Delete succeeds when a tag mapping is not deleted`` data.Value
}
]
]
let private themeTests = testList "Theme" [
testTask "All succeeds" {
do! ThemeDataTests.``All succeeds`` data.Value
}
testList "Exists" [
testTask "succeeds when the theme exists" {
do! ThemeDataTests.``Exists succeeds when the theme exists`` data.Value
}
testTask "succeeds when the theme does not exist" {
do! ThemeDataTests.``Exists succeeds when the theme does not exist`` data.Value
}
]
testList "FindById" [
testTask "succeeds when the theme exists" {
do! ThemeDataTests.``FindById succeeds when the theme exists`` data.Value
}
testTask "succeeds when the theme does not exist" {
do! ThemeDataTests.``FindById succeeds when the theme does not exist`` data.Value
}
]
testList "FindByIdWithoutText" [
testTask "succeeds when the theme exists" {
do! ThemeDataTests.``FindByIdWithoutText succeeds when the theme exists`` data.Value
}
testTask "succeeds when the theme does not exist" {
do! ThemeDataTests.``FindByIdWithoutText succeeds when the theme does not exist`` data.Value
}
]
testList "Save" [
testTask "succeeds when adding a theme" {
do! ThemeDataTests.``Save succeeds when adding a theme`` data.Value
}
testTask "succeeds when updating a theme" {
do! ThemeDataTests.``Save succeeds when updating a theme`` data.Value
}
]
testList "Delete" [
testTask "succeeds when a theme is deleted" {
do! ThemeDataTests.``Delete succeeds when a theme is deleted`` data.Value
}
testTask "succeeds when a theme is not deleted" {
do! ThemeDataTests.``Delete succeeds when a theme is not deleted`` data.Value
}
]
]
let private themeAssetTests = testList "ThemeAsset" [
testList "Save" [
testTask "succeeds when adding an asset" {
do! ThemeDataTests.Asset.``Save succeeds when adding an asset`` data.Value
}
testTask "succeeds when updating an asset" {
do! ThemeDataTests.Asset.``Save succeeds when updating an asset`` data.Value
}
]
testTask "All succeeds" {
do! ThemeDataTests.Asset.``All succeeds`` data.Value
}
testList "FindById" [
testTask "succeeds when an asset is found" {
do! ThemeDataTests.Asset.``FindById succeeds when an asset is found`` data.Value
}
testTask "succeeds when an asset is not found" {
do! ThemeDataTests.Asset.``FindById succeeds when an asset is not found`` data.Value
}
]
testList "FindByTheme" [
testTask "succeeds when assets exist" {
do! ThemeDataTests.Asset.``FindByTheme succeeds when assets exist`` data.Value
}
testTask "succeeds when assets do not exist" {
do! ThemeDataTests.Asset.``FindByTheme succeeds when assets do not exist`` data.Value
}
]
testList "FindByThemeWithData" [
testTask "succeeds when assets exist" {
do! ThemeDataTests.Asset.``FindByThemeWithData succeeds when assets exist`` data.Value
}
testTask "succeeds when assets do not exist" {
do! ThemeDataTests.Asset.``FindByThemeWithData succeeds when assets do not exist`` data.Value
}
]
testList "DeleteByTheme" [
testTask "succeeds when assets are deleted" {
do! ThemeDataTests.Asset.``DeleteByTheme succeeds when assets are deleted`` data.Value
}
testTask "succeeds when no assets are deleted" {
do! ThemeDataTests.Asset.``DeleteByTheme succeeds when no assets are deleted`` data.Value
}
]
]
let private uploadTests = testList "Upload" [
testTask "Add succeeds" {
do! UploadDataTests.``Add succeeds`` data.Value
}
testList "FindByPath" [
testTask "succeeds when an upload is found" {
do! UploadDataTests.``FindByPath succeeds when an upload is found`` data.Value
}
testTask "succeeds when an upload is not found (incorrect weblog)" {
do! UploadDataTests.``FindByPath succeeds when an upload is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when an upload is not found (bad path)" {
do! UploadDataTests.``FindByPath succeeds when an upload is not found (bad path)`` data.Value
}
]
testList "FindByWebLog" [
testTask "succeeds when uploads exist" {
do! UploadDataTests.``FindByWebLog succeeds when uploads exist`` data.Value
}
testTask "succeeds when no uploads exist" {
do! UploadDataTests.``FindByWebLog succeeds when no uploads exist`` data.Value
}
]
testList "FindByWebLogWithData" [
testTask "succeeds when uploads exist" {
do! UploadDataTests.``FindByWebLogWithData succeeds when uploads exist`` data.Value
}
testTask "succeeds when no uploads exist" {
do! UploadDataTests.``FindByWebLogWithData succeeds when no uploads exist`` data.Value
}
]
testList "Delete" [
testTask "succeeds when an upload is deleted" {
do! UploadDataTests.``Delete succeeds when an upload is deleted`` data.Value
}
testTask "succeeds when an upload is not deleted" {
do! UploadDataTests.``Delete succeeds when an upload is not deleted`` data.Value
}
]
]
let private webLogUserTests = testList "WebLogUser" [
testTask "Add succeeds" {
// This restore ensures all the posts and pages exist
do! freshEnvironment ()
do! WebLogUserDataTests.``Add succeeds`` data.Value
}
testList "FindByEmail" [
testTask "succeeds when a user is found" {
do! WebLogUserDataTests.``FindByEmail succeeds when a user is found`` data.Value
}
testTask "succeeds when a user is not found (incorrect weblog)" {
do! WebLogUserDataTests.``FindByEmail succeeds when a user is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when a user is not found (bad email)" {
do! WebLogUserDataTests.``FindByEmail succeeds when a user is not found (bad email)`` data.Value
}
]
testList "FindById" [
testTask "succeeds when a user is found" {
do! WebLogUserDataTests.``FindById succeeds when a user is found`` data.Value
}
testTask "succeeds when a user is not found (incorrect weblog)" {
do! WebLogUserDataTests.``FindById succeeds when a user is not found (incorrect weblog)`` data.Value
}
testTask "succeeds when a user is not found (bad ID)" {
do! WebLogUserDataTests.``FindById succeeds when a user is not found (bad ID)`` data.Value
}
]
testList "FindByWebLog" [
testTask "succeeds when users exist" {
do! WebLogUserDataTests.``FindByWebLog succeeds when users exist`` data.Value
}
testTask "succeeds when no users exist" {
do! WebLogUserDataTests.``FindByWebLog succeeds when no users exist`` data.Value
}
]
testList "FindNames" [
testTask "succeeds when users exist" {
do! WebLogUserDataTests.``FindNames succeeds when users exist`` data.Value
}
testTask "succeeds when users do not exist" {
do! WebLogUserDataTests.``FindNames succeeds when users do not exist`` data.Value
}
]
testList "SetLastSeen" [
testTask "succeeds when the user exists" {
do! WebLogUserDataTests.``SetLastSeen succeeds when the user exists`` data.Value
}
testTask "succeeds when the user does not exist" {
do! WebLogUserDataTests.``SetLastSeen succeeds when the user does not exist`` data.Value
}
]
testList "Update" [
testTask "succeeds when the user exists" {
do! WebLogUserDataTests.``Update succeeds when the user exists`` data.Value
}
testTask "succeeds when the user does not exist" {
do! WebLogUserDataTests.``Update succeeds when the user does not exist`` data.Value
}
]
testList "Delete" [
testTask "fails when the user is the author of a page" {
do! WebLogUserDataTests.``Delete fails when the user is the author of a page`` data.Value
}
testTask "fails when the user is the author of a post" {
do! WebLogUserDataTests.``Delete fails when the user is the author of a post`` data.Value
}
testTask "succeeds when the user is not an author" {
do! WebLogUserDataTests.``Delete succeeds when the user is not an author`` data.Value
}
testTask "succeeds when the user does not exist" {
do! WebLogUserDataTests.``Delete succeeds when the user does not exist`` data.Value
}
]
]
let private webLogTests = testList "WebLog" [
testTask "Add succeeds" {
do! WebLogDataTests.``Add succeeds`` data.Value
}
testTask "All succeeds" {
do! WebLogDataTests.``All succeeds`` data.Value
}
testList "FindByHost" [
testTask "succeeds when a web log is found" {
do! WebLogDataTests.``FindByHost succeeds when a web log is found`` data.Value
}
testTask "succeeds when a web log is not found" {
do! WebLogDataTests.``FindByHost succeeds when a web log is not found`` data.Value
}
]
testList "FindById" [
testTask "succeeds when a web log is found" {
do! WebLogDataTests.``FindById succeeds when a web log is found`` data.Value
}
testTask "succeeds when a web log is not found" {
do! WebLogDataTests.``FindById succeeds when a web log is not found`` data.Value
}
]
testList "UpdateRedirectRules" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``UpdateRedirectRules succeeds when the web log exists`` data.Value
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``UpdateRedirectRules succeeds when the web log does not exist`` data.Value
}
]
testList "UpdateRssOptions" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``UpdateRssOptions succeeds when the web log exists`` data.Value
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``UpdateRssOptions succeeds when the web log does not exist`` data.Value
}
]
testList "UpdateSettings" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``UpdateSettings succeeds when the web log exists`` data.Value
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``UpdateSettings succeeds when the web log does not exist`` data.Value
}
]
testList "Delete" [
testTask "succeeds when the web log exists" {
do! WebLogDataTests.``Delete succeeds when the web log exists`` data.Value
}
testTask "succeeds when the web log does not exist" {
do! WebLogDataTests.``Delete succeeds when the web log does not exist`` data.Value
}
]
]
/// Drop the throwaway RethinkDB database
let private environmentCleanUp = testTask "Clean Up" {
do! disposeData ()
}
/// All RethinkDB data tests
let all =
testList "RethinkDbData"
[ environmentSetUp
categoryTests
pageTests
postTests
tagMapTests
themeTests
themeAssetTests
uploadTests
webLogUserTests
webLogTests
environmentCleanUp ]
|> testSequenced

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,112 @@
/// <summary>
/// Integration tests for <see cref="ITagMapData" /> implementations
/// </summary>
module TagMapDataTests
open Expecto
open MyWebLog
open MyWebLog.Data
/// The ID of the root web log
let private rootId = CategoryDataTests.rootId
/// The ID of the f# tag
let private fSharpId = TagMapId "Icm027noqE-rPHKZA98vAw"
/// The ID of the ghoti tag
let private fishId = TagMapId "GdryXh-S0kGsNBs2RIacGA"
let ``FindById succeeds when a tag mapping is found`` (data: IData) = task {
let! tagMap = data.TagMap.FindById fSharpId rootId
Expect.isSome tagMap "There should have been a tag mapping returned"
let tag = tagMap.Value
Expect.equal tag.Id fSharpId "ID is incorrect"
Expect.equal tag.WebLogId rootId "Web log ID is incorrect"
Expect.equal tag.Tag "f#" "Tag is incorrect"
Expect.equal tag.UrlValue "f-sharp" "URL value is incorrect"
}
let ``FindById succeeds when a tag mapping is not found (incorrect weblog)`` (data: IData) = task {
let! tagMap = data.TagMap.FindById fSharpId (WebLogId "wrong")
Expect.isNone tagMap "There should not have been a tag mapping returned"
}
let ``FindById succeeds when a tag mapping is not found (bad tag map ID)`` (data: IData) = task {
let! tagMap = data.TagMap.FindById (TagMapId "out") rootId
Expect.isNone tagMap "There should not have been a tag mapping returned"
}
let ``FindByUrlValue succeeds when a tag mapping is found`` (data: IData) = task {
let! tagMap = data.TagMap.FindByUrlValue "f-sharp" rootId
Expect.isSome tagMap "There should have been a tag mapping returned"
Expect.equal tagMap.Value.Id fSharpId "ID is incorrect"
}
let ``FindByUrlValue succeeds when a tag mapping is not found (incorrect weblog)`` (data: IData) = task {
let! tagMap = data.TagMap.FindByUrlValue "f-sharp" (WebLogId "incorrect")
Expect.isNone tagMap "There should not have been a tag mapping returned"
}
let ``FindByUrlValue succeeds when a tag mapping is not found (no such value)`` (data: IData) = task {
let! tagMap = data.TagMap.FindByUrlValue "c-sharp" rootId
Expect.isNone tagMap "There should not have been a tag mapping returned"
}
let ``FindByWebLog succeeds when tag mappings are found`` (data: IData) = task {
let! mappings = data.TagMap.FindByWebLog rootId
Expect.hasLength mappings 2 "There should have been 2 tag mappings returned"
for mapping in mappings do
Expect.contains [ fSharpId; fishId ] mapping.Id $"Unexpected mapping ID ({mapping.Id})"
Expect.equal mapping.WebLogId rootId "Web log ID is incorrect"
Expect.isNotEmpty mapping.Tag "Tag should not have been blank"
Expect.isNotEmpty mapping.UrlValue "URL value should not have been blank"
}
let ``FindByWebLog succeeds when no tag mappings are found`` (data: IData) = task {
let! mappings = data.TagMap.FindByWebLog (WebLogId "no-maps")
Expect.isEmpty mappings "There should have been no tag mappings returned"
}
let ``FindMappingForTags succeeds when mappings exist`` (data: IData) = task {
let! mappings = data.TagMap.FindMappingForTags [ "f#"; "testing"; "unit" ] rootId
Expect.hasLength mappings 1 "There should have been one mapping returned"
Expect.equal mappings[0].Id fSharpId "The wrong mapping was returned"
}
let ``FindMappingForTags succeeds when no mappings exist`` (data: IData) = task {
let! mappings = data.TagMap.FindMappingForTags [ "c#"; "turkey"; "ham" ] rootId
Expect.isEmpty mappings "There should have been no tag mappings returned"
}
let ``Save succeeds when adding a tag mapping`` (data: IData) = task {
let mapId = TagMapId "test"
do! data.TagMap.Save { Id = mapId; WebLogId = rootId; Tag = "c#"; UrlValue = "c-sharp" }
let! mapping = data.TagMap.FindById mapId rootId
Expect.isSome mapping "The mapping should have been retrieved"
let tag = mapping.Value
Expect.equal tag.Id mapId "ID is incorrect"
Expect.equal tag.WebLogId rootId "Web log ID is incorrect"
Expect.equal tag.Tag "c#" "Tag is incorrect"
Expect.equal tag.UrlValue "c-sharp" "URL value is incorrect"
}
let ``Save succeeds when updating a tag mapping`` (data: IData) = task {
do! data.TagMap.Save { Id = fishId; WebLogId = rootId; Tag = "halibut"; UrlValue = "mackerel" }
let! mapping = data.TagMap.FindById fishId rootId
Expect.isSome mapping "The mapping should have been retrieved"
let tag = mapping.Value
Expect.equal tag.Id fishId "ID is incorrect"
Expect.equal tag.WebLogId rootId "Web log ID is incorrect"
Expect.equal tag.Tag "halibut" "Tag is incorrect"
Expect.equal tag.UrlValue "mackerel" "URL value is incorrect"
}
let ``Delete succeeds when a tag mapping is deleted`` (data: IData) = task {
let! deleted = data.TagMap.Delete fSharpId rootId
Expect.isTrue deleted "The tag mapping should have been deleted"
}
let ``Delete succeeds when a tag mapping is not deleted`` (data: IData) = task {
let! deleted = data.TagMap.Delete fSharpId rootId // this was deleted above
Expect.isFalse deleted "A tag mapping should not have been deleted"
}

View File

@@ -0,0 +1,234 @@
/// <summary>
/// Integration tests for <see cref="IThemeData" /> implementations
/// </summary>
module ThemeDataTests
open System.IO
open Expecto
open MyWebLog
open MyWebLog.Data
open NodaTime
/// The ID of the default theme (restored from root-weblog.json)
let private defaultId = ThemeId "default"
/// The ID of the test theme loaded and manipulated by these tests
let private testId = ThemeId "test-theme"
/// The dark version of the myWebLog logo
let private darkFile = File.ReadAllBytes "../admin-theme/wwwroot/logo-dark.png"
/// The light version of the myWebLog logo
let private lightFile = File.ReadAllBytes "../admin-theme/wwwroot/logo-light.png"
/// Ensure that theme templates do not have any text
let private ensureNoText theme =
for template in theme.Templates do
Expect.equal template.Text "" $"Text for template {template.Name} should have been blank"
let ``All succeeds`` (data: IData) = task {
let! themes = data.Theme.All()
Expect.hasLength themes 1 "There should have been one theme returned"
Expect.equal themes[0].Id defaultId "ID was incorrect"
Expect.equal themes[0].Name "myWebLog Default Theme" "Name was incorrect"
Expect.equal themes[0].Version "2.1.0" "Version was incorrect"
ensureNoText themes[0]
}
let ``Exists succeeds when the theme exists`` (data: IData) = task {
let! exists = data.Theme.Exists defaultId
Expect.isTrue exists "The \"default\" theme should have existed"
}
let ``Exists succeeds when the theme does not exist`` (data: IData) = task {
let! exists = data.Theme.Exists (ThemeId "fancy")
Expect.isFalse exists "The \"fancy\" theme should not have existed"
}
let ``FindById succeeds when the theme exists`` (data: IData) = task {
let! theme = data.Theme.FindById defaultId
Expect.isSome theme "The theme should have been found"
let it = theme.Value
Expect.equal it.Id defaultId "ID was incorrect"
Expect.equal it.Name "myWebLog Default Theme" "Name was incorrect"
Expect.equal it.Version "2.1.0" "Version was incorrect"
for template in it.Templates do
Expect.isNotEmpty template.Text $"Text for template {template.Name} should not have been blank"
}
let ``FindById succeeds when the theme does not exist`` (data: IData) = task {
let! theme = data.Theme.FindById (ThemeId "missing")
Expect.isNone theme "There should not have been a theme found"
}
let ``FindByIdWithoutText succeeds when the theme exists`` (data: IData) = task {
let! theme = data.Theme.FindByIdWithoutText defaultId
Expect.isSome theme "The theme should have been found"
let it = theme.Value
Expect.equal it.Id defaultId "ID was incorrect"
ensureNoText it
}
let ``FindByIdWithoutText succeeds when the theme does not exist`` (data: IData) = task {
let! theme = data.Theme.FindByIdWithoutText (ThemeId "ornate")
Expect.isNone theme "There should not have been a theme found"
}
let ``Save succeeds when adding a theme`` (data: IData) = task {
do! data.Theme.Save
{ Id = testId
Name = "Test Theme"
Version = "evergreen"
Templates =
[ { Name = "index"; Text = "<h1>{{ values_here }}</h1>" }
{ Name = "single-post"; Text = "<p>{{ the_post }}" } ] }
let! saved = data.Theme.FindById testId
Expect.isSome saved "There should have been a theme returned"
let it = saved.Value
Expect.equal it.Id testId "ID was incorrect"
Expect.equal it.Name "Test Theme" "Name was incorrect"
Expect.equal it.Version "evergreen" "Version was incorrect"
Expect.hasLength it.Templates 2 "There should have been 2 templates"
Expect.equal it.Templates[0].Name "index" "Template 0 name incorrect"
Expect.equal it.Templates[0].Text "<h1>{{ values_here }}</h1>" "Template 0 text incorrect"
Expect.equal it.Templates[1].Name "single-post" "Template 1 name incorrect"
Expect.equal it.Templates[1].Text "<p>{{ the_post }}" "Template 1 text incorrect"
}
let ``Save succeeds when updating a theme`` (data: IData) = task {
do! data.Theme.Save
{ Id = testId
Name = "Updated Theme"
Version = "still evergreen"
Templates =
[ { Name = "index"; Text = "<h1>{{ values_there }}</h1>" }
{ Name = "layout"; Text = "<!DOCTYPE html><etc />" }
{ Name = "single-post"; Text = "<p>{{ the_post }}" } ] }
let! updated = data.Theme.FindById testId
Expect.isSome updated "The updated theme should have been returned"
let it = updated.Value
Expect.equal it.Id testId "ID was incorrect"
Expect.equal it.Name "Updated Theme" "Name was incorrect"
Expect.equal it.Version "still evergreen" "Version was incorrect"
Expect.hasLength it.Templates 3 "There should have been 3 templates"
Expect.equal it.Templates[0].Name "index" "Template 0 name incorrect"
Expect.equal it.Templates[0].Text "<h1>{{ values_there }}</h1>" "Template 0 text incorrect"
Expect.equal it.Templates[1].Name "layout" "Template 1 name incorrect"
Expect.equal it.Templates[1].Text "<!DOCTYPE html><etc />" "Template 1 text incorrect"
Expect.equal it.Templates[2].Name "single-post" "Template 2 name incorrect"
Expect.equal it.Templates[2].Text "<p>{{ the_post }}" "Template 2 text incorrect"
}
let ``Delete succeeds when a theme is deleted`` (data: IData) = task {
// Delete should also delete assets associated with the theme
do! data.ThemeAsset.Save { Id = ThemeAssetId (testId, "logo-dark.png"); UpdatedOn = Noda.epoch; Data = darkFile }
do! data.ThemeAsset.Save { Id = ThemeAssetId (testId, "logo-light.png"); UpdatedOn = Noda.epoch; Data = lightFile }
let! deleted = data.Theme.Delete testId
Expect.isTrue deleted "The theme should have been deleted"
let! assets = data.ThemeAsset.FindByTheme testId
Expect.isEmpty assets "The theme's assets should have been deleted"
}
let ``Delete succeeds when a theme is not deleted`` (data: IData) = task {
let! deleted = data.Theme.Delete (ThemeId "test-theme") // already deleted above
Expect.isFalse deleted "The theme should not have been deleted"
}
/// <summary>
/// Integration tests for <see cref="IThemeAssetData" /> implementations
/// </summary>
module Asset =
/// The theme ID for which assets will be tested
let private assetThemeId = ThemeId "asset-test"
/// The asset ID for the dark logo
let private darkId = ThemeAssetId (assetThemeId, "logo-dark.png")
/// The asset ID for the light logo
let private lightId = ThemeAssetId (assetThemeId, "logo-light.png")
let ``Save succeeds when adding an asset`` (data: IData) = task {
do! data.Theme.Save { Theme.Empty with Id = assetThemeId }
do! data.ThemeAsset.Save { Id = lightId; UpdatedOn = Noda.epoch + Duration.FromDays 18; Data = lightFile }
let! asset = data.ThemeAsset.FindById lightId
Expect.isSome asset "The asset should have been found"
let it = asset.Value
Expect.equal it.Id lightId "ID was incorrect"
Expect.equal it.UpdatedOn (Noda.epoch + Duration.FromDays 18) "Updated on was incorrect"
Expect.equal it.Data lightFile "Data was incorrect"
}
let ``Save succeeds when updating an asset`` (data: IData) = task {
do! data.ThemeAsset.Save { Id = lightId; UpdatedOn = Noda.epoch + Duration.FromDays 20; Data = darkFile }
let! asset = data.ThemeAsset.FindById lightId
Expect.isSome asset "The asset should have been found"
let it = asset.Value
Expect.equal it.Id lightId "ID was incorrect"
Expect.equal it.UpdatedOn (Noda.epoch + Duration.FromDays 20) "Updated on was incorrect"
Expect.equal it.Data darkFile "Data was incorrect"
}
let ``All succeeds`` (data: IData) = task {
let! all = data.ThemeAsset.All()
Expect.hasLength all 2 "There should have been 2 assets retrieved"
for asset in all do
Expect.contains
[ ThemeAssetId (defaultId, "style.css"); lightId ] asset.Id $"Unexpected asset found ({asset.Id})"
Expect.isEmpty asset.Data $"Asset {asset.Id} should not have had data"
}
let ``FindById succeeds when an asset is found`` (data: IData) = task {
let! asset = data.ThemeAsset.FindById lightId
Expect.isSome asset "The asset should have been found"
let it = asset.Value
Expect.equal it.Id lightId "ID was incorrect"
Expect.equal it.UpdatedOn (Noda.epoch + Duration.FromDays 20) "Updated on was incorrect"
Expect.equal it.Data darkFile "Data was incorrect"
}
let ``FindById succeeds when an asset is not found`` (data: IData) = task {
let! asset = data.ThemeAsset.FindById (ThemeAssetId (assetThemeId, "404.jpg"))
Expect.isNone asset "There should not have been an asset returned"
}
let ``FindByTheme succeeds when assets exist`` (data: IData) = task {
do! data.ThemeAsset.Save { Id = darkId; UpdatedOn = Noda.epoch; Data = darkFile }
do! data.ThemeAsset.Save { Id = lightId; UpdatedOn = Noda.epoch; Data = lightFile }
let! assets = data.ThemeAsset.FindByTheme assetThemeId
Expect.hasLength assets 2 "There should have been 2 assets returned"
for asset in assets do
Expect.contains [ darkId; lightId ] asset.Id $"Unexpected asset found ({asset.Id})"
Expect.equal asset.UpdatedOn Noda.epoch $"Updated on was incorrect ({asset.Id})"
Expect.isEmpty asset.Data $"Data should not have been retrieved ({asset.Id})"
}
let ``FindByTheme succeeds when assets do not exist`` (data: IData) = task {
let! assets = data.ThemeAsset.FindByTheme (ThemeId "no-assets-here")
Expect.isEmpty assets "There should have been no assets returned"
}
let ``FindByThemeWithData succeeds when assets exist`` (data: IData) = task {
let! assets = data.ThemeAsset.FindByThemeWithData assetThemeId
Expect.hasLength assets 2 "There should have been 2 assets returned"
let darkLogo = assets |> List.find (fun it -> it.Id = darkId)
Expect.equal darkLogo.Data darkFile "The dark asset's data is incorrect"
let lightLogo = assets |> List.find (fun it -> it.Id = lightId)
Expect.equal lightLogo.Data lightFile "The light asset's data is incorrect"
}
let ``FindByThemeWithData succeeds when assets do not exist`` (data: IData) = task {
let! assets = data.ThemeAsset.FindByThemeWithData (ThemeId "still-no-assets")
Expect.isEmpty assets "There should have been no assets returned"
}
let ``DeleteByTheme succeeds when assets are deleted`` (data: IData) = task {
do! data.ThemeAsset.DeleteByTheme assetThemeId
let! assets = data.ThemeAsset.FindByTheme assetThemeId
Expect.isEmpty assets "There should be no assets remaining"
}
let ``DeleteByTheme succeeds when no assets are deleted`` (data: IData) = task {
do! data.ThemeAsset.DeleteByTheme assetThemeId // already deleted above
Expect.isTrue true "The above did not raise an exception; that's the test"
}

View File

@@ -0,0 +1,95 @@
/// <summary>
/// Integration tests for <see cref="IUploadData" /> implementations
/// </summary>
module UploadDataTests
open System
open System.IO
open Expecto
open MyWebLog
open MyWebLog.Data
open NodaTime
/// The ID of the root web log
let private rootId = CategoryDataTests.rootId
/// The ID of the favicon upload
let private faviconId = UploadId "XweKbWQiOkqqrjEdgP9wwg"
let ``Add succeeds`` (data: IData) = task {
let file = File.ReadAllBytes "../admin-theme/wwwroot/logo-dark.png"
do! data.Upload.Add
{ Id = UploadId "new-upload"
WebLogId = rootId
UpdatedOn = Noda.epoch + Duration.FromDays 30
Path = Permalink "1970/01/logo-dark.png"
Data = file }
let! added = data.Upload.FindByPath "1970/01/logo-dark.png" rootId
Expect.isSome added "There should have been an upload returned"
let upload = added.Value
Expect.equal upload.Id (UploadId "new-upload") "ID is incorrect"
Expect.equal upload.WebLogId rootId "Web log ID is incorrect"
Expect.equal upload.UpdatedOn (Noda.epoch + Duration.FromDays 30) "Updated on is incorrect"
Expect.equal upload.Path (Permalink "1970/01/logo-dark.png") "Path is incorrect"
Expect.equal upload.Data file "Data is incorrect"
}
let ``FindByPath succeeds when an upload is found`` (data: IData) = task {
let! upload = data.Upload.FindByPath "2022/06/favicon.ico" rootId
Expect.isSome upload "There should have been an upload returned"
let it = upload.Value
Expect.equal it.Id faviconId "ID is incorrect"
Expect.equal it.WebLogId rootId "Web log ID is incorrect"
Expect.equal
it.UpdatedOn (Instant.FromDateTimeOffset(DateTimeOffset.Parse "2022-06-23T21:15:40Z")) "Updated on is incorrect"
Expect.equal it.Path (Permalink "2022/06/favicon.ico") "Path is incorrect"
Expect.isNonEmpty it.Data "Data should have been retrieved"
}
let ``FindByPath succeeds when an upload is not found (incorrect weblog)`` (data: IData) = task {
let! upload = data.Upload.FindByPath "2022/06/favicon.ico" (WebLogId "wrong")
Expect.isNone upload "There should not have been an upload returned"
}
let ``FindByPath succeeds when an upload is not found (bad path)`` (data: IData) = task {
let! upload = data.Upload.FindByPath "2022/07/favicon.ico" rootId
Expect.isNone upload "There should not have been an upload returned"
}
let ``FindByWebLog succeeds when uploads exist`` (data: IData) = task {
let! uploads = data.Upload.FindByWebLog rootId
Expect.hasLength uploads 2 "There should have been 2 uploads returned"
for upload in uploads do
Expect.contains [ faviconId; UploadId "new-upload" ] upload.Id $"Unexpected upload returned ({upload.Id})"
Expect.isEmpty upload.Data $"Upload should not have had its data ({upload.Id})"
}
let ``FindByWebLog succeeds when no uploads exist`` (data: IData) = task {
let! uploads = data.Upload.FindByWebLog (WebLogId "nothing")
Expect.isEmpty uploads "There should have been no uploads returned"
}
let ``FindByWebLogWithData succeeds when uploads exist`` (data: IData) = task {
let! uploads = data.Upload.FindByWebLogWithData rootId
Expect.hasLength uploads 2 "There should have been 2 uploads returned"
for upload in uploads do
Expect.contains [ faviconId; UploadId "new-upload" ] upload.Id $"Unexpected upload returned ({upload.Id})"
Expect.isNonEmpty upload.Data $"Upload should have had its data ({upload.Id})"
}
let ``FindByWebLogWithData succeeds when no uploads exist`` (data: IData) = task {
let! uploads = data.Upload.FindByWebLogWithData (WebLogId "data-nope")
Expect.isEmpty uploads "There should have been no uploads returned"
}
let ``Delete succeeds when an upload is deleted`` (data: IData) = task {
match! data.Upload.Delete faviconId rootId with
| Ok path -> Expect.equal path "2022/06/favicon.ico" "The path of the deleted upload was incorrect"
| Error it -> Expect.isTrue false $"Upload deletion should have succeeded (message {it})"
}
let ``Delete succeeds when an upload is not deleted`` (data: IData) = task {
match! data.Upload.Delete faviconId rootId with
| Ok it -> Expect.isTrue false $"Upload deletion should not have succeeded (path {it})"
| Error msg -> Expect.equal msg $"Upload ID {faviconId} not found" "Error message was incorrect"
}

View File

@@ -0,0 +1,96 @@
module UtilsTests
open Expecto
open MyWebLog
open MyWebLog.Data
open NodaTime
/// Unit tests for the orderByHierarchy function
let orderByHierarchyTests = test "orderByHierarchy succeeds" {
let rawCats =
[ { Category.Empty with Id = CategoryId "a"; Name = "Audio"; Slug = "audio"; ParentId = Some (CategoryId "p") }
{ Category.Empty with
Id = CategoryId "b"
Name = "Breaking"
Description = Some "Breaking News"
Slug = "breaking"
ParentId = Some (CategoryId "n") }
{ Category.Empty with Id = CategoryId "l"; Name = "Local"; Slug = "local"; ParentId = Some (CategoryId "b") }
{ Category.Empty with Id = CategoryId "n"; Name = "News"; Slug = "news" }
{ Category.Empty with Id = CategoryId "p"; Name = "Podcast"; Slug = "podcast" }
{ Category.Empty with Id = CategoryId "v"; Name = "Video"; Slug = "vid"; ParentId = Some (CategoryId "p") } ]
let cats = Utils.orderByHierarchy rawCats None None [] |> List.ofSeq
Expect.equal cats.Length 6 "There should have been 6 categories"
Expect.equal cats[0].Id "n" "The first top-level category should have been News"
Expect.equal cats[0].Slug "news" "Slug for News not filled properly"
Expect.isEmpty cats[0].ParentNames "Parent names for News not filled properly"
Expect.equal cats[1].Id "b" "Breaking should have been just below News"
Expect.equal cats[1].Slug "news/breaking" "Slug for Breaking not filled properly"
Expect.equal cats[1].Name "Breaking" "Name not filled properly"
Expect.equal cats[1].Description (Some "Breaking News") "Description not filled properly"
Expect.equal cats[1].ParentNames [| "News" |] "Parent names for Breaking not filled properly"
Expect.equal cats[2].Id "l" "Local should have been just below Breaking"
Expect.equal cats[2].Slug "news/breaking/local" "Slug for Local not filled properly"
Expect.equal cats[2].ParentNames [| "News"; "Breaking" |] "Parent names for Local not filled properly"
Expect.equal cats[3].Id "p" "Podcast should have been the next top-level category"
Expect.equal cats[3].Slug "podcast" "Slug for Podcast not filled properly"
Expect.isEmpty cats[3].ParentNames "Parent names for Podcast not filled properly"
Expect.equal cats[4].Id "a" "Audio should have been just below Podcast"
Expect.equal cats[4].Slug "podcast/audio" "Slug for Audio not filled properly"
Expect.equal cats[4].ParentNames [| "Podcast" |] "Parent names for Audio not filled properly"
Expect.equal cats[5].Id "v" "Video should have been below Audio"
Expect.equal cats[5].Slug "podcast/vid" "Slug for Video not filled properly"
Expect.equal cats[5].ParentNames [| "Podcast" |] "Parent names for Video not filled properly"
Expect.hasCountOf cats 6u (fun it -> it.PostCount = 0) "All post counts should have been 0"
}
/// Unit tests for the diffLists function
let diffListsTests = testList "diffLists" [
test "succeeds with identical lists" {
let removed, added = Utils.diffLists [ 1; 2; 3 ] [ 1; 2; 3 ] id
Expect.isEmpty removed "There should have been no removed items returned"
Expect.isEmpty added "There should have been no added items returned"
}
test "succeeds with differing lists" {
let removed, added = Utils.diffLists [ 1; 2; 3 ] [ 3; 4; 5 ] string
Expect.equal removed [ 1; 2 ] "Removed items incorrect"
Expect.equal added [ 4; 5 ] "Added items incorrect"
}
]
/// Unit tests for the diffRevisions function
let diffRevisionsTests = testList "diffRevisions" [
test "succeeds with identical lists" {
let oldItems =
[ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<p>test" }
{ AsOf = Noda.epoch; Text = Html "<p>test test" } ]
let newItems =
[ { AsOf = Noda.epoch; Text = Html "<p>test test" }
{ AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<p>test" } ]
let removed, added = Utils.diffRevisions oldItems newItems
Expect.isEmpty removed "There should have been no removed items returned"
Expect.isEmpty added "There should have been no added items returned"
}
test "succeeds with differing lists" {
let oldItems =
[ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<p>test" }
{ AsOf = Noda.epoch + Duration.FromDays 2; Text = Html "<p>tests" }
{ AsOf = Noda.epoch; Text = Html "<p>test test" } ]
let newItems =
[ { AsOf = Noda.epoch + Duration.FromDays 4; Text = Html "<p>tests" }
{ AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<p>test" }
{ AsOf = Noda.epoch; Text = Html "<p>test test" } ]
let removed, added = Utils.diffRevisions oldItems newItems
Expect.equal removed.Length 1 "There should be 1 removed item"
Expect.equal removed[0].AsOf (Noda.epoch + Duration.FromDays 2) "Expected removed item incorrect"
Expect.equal added.Length 1 "There should be 1 added item"
Expect.equal added[0].AsOf (Noda.epoch + Duration.FromDays 4) "Expected added item incorrect"
}
]
/// All tests for the Utils file
let all = testList "Utils" [
orderByHierarchyTests
diffListsTests
diffRevisionsTests
]

View File

@@ -0,0 +1,198 @@
/// <summary>
/// Integration tests for <see cref="IWebLogData" /> implementations
/// </summary>
module WebLogDataTests
open System
open Expecto
open MyWebLog
open MyWebLog.Data
/// The ID of the root web log
let private rootId = CategoryDataTests.rootId
let ``Add succeeds`` (data: IData) = task {
do! data.WebLog.Add
{ Id = WebLogId "new-weblog"
Name = "Test Web Log"
Slug = "test-web-log"
Subtitle = None
DefaultPage = ""
PostsPerPage = 7
ThemeId = ThemeId "default"
UrlBase = "https://example.com/new"
TimeZone = "America/Los_Angeles"
Rss =
{ IsFeedEnabled = true
FeedName = "my-feed.xml"
ItemsInFeed = None
IsCategoryEnabled = false
IsTagEnabled = false
Copyright = Some "go for it"
CustomFeeds = [] }
AutoHtmx = true
Uploads = Disk
RedirectRules = [ { From = "/here"; To = "/there"; IsRegex = false } ] }
let! webLog = data.WebLog.FindById (WebLogId "new-weblog")
Expect.isSome webLog "The web log should have been returned"
let it = webLog.Value
Expect.equal it.Id (WebLogId "new-weblog") "ID is incorrect"
Expect.equal it.Name "Test Web Log" "Name is incorrect"
Expect.equal it.Slug "test-web-log" "Slug is incorrect"
Expect.isNone it.Subtitle "Subtitle is incorrect"
Expect.equal it.DefaultPage "" "Default page is incorrect"
Expect.equal it.PostsPerPage 7 "Posts per page 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.TimeZone "America/Los_Angeles" "Time zone is incorrect"
Expect.isTrue it.AutoHtmx "Auto htmx flag is incorrect"
Expect.equal it.Uploads Disk "Upload destination is incorrect"
Expect.equal it.RedirectRules [ { From = "/here"; To = "/there"; IsRegex = false } ] "Redirect rules are incorrect"
let rss = it.Rss
Expect.isTrue rss.IsFeedEnabled "Is feed enabled flag is incorrect"
Expect.equal rss.FeedName "my-feed.xml" "Feed name is incorrect"
Expect.isNone rss.ItemsInFeed "Items in feed is incorrect"
Expect.isFalse rss.IsCategoryEnabled "Is category enabled flag is incorrect"
Expect.isFalse rss.IsTagEnabled "Is tag enabled flag is incorrect"
Expect.equal rss.Copyright (Some "go for it") "Copyright is incorrect"
Expect.isEmpty rss.CustomFeeds "Custom feeds are incorrect"
}
let ``All succeeds`` (data: IData) = task {
let! webLogs = data.WebLog.All()
Expect.hasLength webLogs 2 "There should have been 2 web logs returned"
for webLog in webLogs do
Expect.contains [ rootId; WebLogId "new-weblog" ] webLog.Id $"Unexpected web log returned ({webLog.Id})"
}
let ``FindByHost succeeds when a web log is found`` (data: IData) = task {
let! webLog = data.WebLog.FindByHost "http://localhost:8081"
Expect.isSome webLog "A web log should have been returned"
Expect.equal webLog.Value.Id rootId "The wrong web log was returned"
}
let ``FindByHost succeeds when a web log is not found`` (data: IData) = task {
let! webLog = data.WebLog.FindByHost "https://test.units"
Expect.isNone webLog "There should not have been a web log returned"
}
let ``FindById succeeds when a web log is found`` (data: IData) = task {
let! webLog = data.WebLog.FindById rootId
Expect.isSome webLog "There should have been a web log returned"
let it = webLog.Value
Expect.equal it.Id rootId "ID is incorrect"
Expect.equal it.Name "Root WebLog" "Name is incorrect"
Expect.equal it.Slug "root-weblog" "Slug is incorrect"
Expect.equal it.Subtitle (Some "This is the main one") "Subtitle is incorrect"
Expect.equal it.DefaultPage "posts" "Default page is incorrect"
Expect.equal it.PostsPerPage 9 "Posts per page 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.TimeZone "America/Denver" "Time zone is incorrect"
Expect.isTrue it.AutoHtmx "Auto htmx flag is incorrect"
Expect.equal it.Uploads Database "Upload destination is incorrect"
Expect.isEmpty it.RedirectRules "Redirect rules are incorrect"
let rss = it.Rss
Expect.isTrue rss.IsFeedEnabled "Is feed enabled flag is incorrect"
Expect.equal rss.FeedName "feed" "Feed name is incorrect"
Expect.equal rss.ItemsInFeed (Some 7) "Items in feed is incorrect"
Expect.isTrue rss.IsCategoryEnabled "Is category enabled flag is incorrect"
Expect.isTrue rss.IsTagEnabled "Is tag enabled flag is incorrect"
Expect.equal rss.Copyright (Some "CC40-NC-BY") "Copyright is incorrect"
Expect.hasLength rss.CustomFeeds 1 "There should be 1 custom feed"
Expect.equal rss.CustomFeeds[0].Id (CustomFeedId "isPQ6drbDEydxohQzaiYtQ") "Custom feed ID incorrect"
Expect.equal rss.CustomFeeds[0].Source (Tag "podcast") "Custom feed source is incorrect"
Expect.equal rss.CustomFeeds[0].Path (Permalink "podcast-feed") "Custom feed path is incorrect"
Expect.isSome rss.CustomFeeds[0].Podcast "There should be podcast settings for this custom feed"
let pod = rss.CustomFeeds[0].Podcast.Value
Expect.equal pod.Title "Root Podcast" "Podcast title is incorrect"
Expect.equal pod.ItemsInFeed 23 "Podcast items in feed is incorrect"
Expect.equal pod.Summary "All things that happen in the domain root" "Podcast summary is incorrect"
Expect.equal pod.DisplayedAuthor "Podcaster Extraordinaire" "Podcast author is incorrect"
Expect.equal pod.Email "podcaster@example.com" "Podcast e-mail is incorrect"
Expect.equal pod.ImageUrl (Permalink "images/cover-art.png") "Podcast image URL is incorrect"
Expect.equal pod.AppleCategory "Fiction" "Podcast Apple category is incorrect"
Expect.equal pod.AppleSubcategory (Some "Drama") "Podcast Apple subcategory is incorrect"
Expect.equal pod.Explicit No "Podcast explicit rating is incorrect"
Expect.equal pod.DefaultMediaType (Some "audio/mpeg") "Podcast default media type is incorrect"
Expect.equal pod.MediaBaseUrl (Some "https://media.example.com/root/") "Podcast media base URL is incorrect"
Expect.equal pod.PodcastGuid (Some (Guid.Parse "10fd7f79-c719-4e1d-9da7-10405dd4fd96")) "Podcast GUID is incorrect"
Expect.equal pod.FundingUrl (Some "https://example.com/support-us") "Podcast funding URL is incorrect"
Expect.equal pod.FundingText (Some "Support Our Work") "Podcast funding text is incorrect"
Expect.equal pod.Medium (Some Newsletter) "Podcast medium is incorrect"
}
let ``FindById succeeds when a web log is not found`` (data: IData) = task {
let! webLog = data.WebLog.FindById (WebLogId "no-web-log")
Expect.isNone webLog "There should not have been a web log returned"
}
let ``UpdateRedirectRules succeeds when the web log exists`` (data: IData) = task {
let! webLog = data.WebLog.FindById (WebLogId "new-weblog")
Expect.isSome webLog "The test web log should have been returned"
do! data.WebLog.UpdateRedirectRules
{ webLog.Value with
RedirectRules = { From = "/now"; To = "/later"; IsRegex = false } :: webLog.Value.RedirectRules }
let! updated = data.WebLog.FindById (WebLogId "new-weblog")
Expect.isSome updated "The updated web log should have been returned"
Expect.equal
updated.Value.RedirectRules
[ { From = "/now"; To = "/later"; IsRegex = false }; { From = "/here"; To = "/there"; IsRegex = false } ]
"Redirect rules not updated correctly"
}
let ``UpdateRedirectRules succeeds when the web log does not exist`` (data: IData) = task {
do! data.WebLog.UpdateRedirectRules { WebLog.Empty with Id = WebLogId "no-rules" }
Expect.isTrue true "This not raising an exception is the test"
}
let ``UpdateRssOptions succeeds when the web log exists`` (data: IData) = task {
let! webLog = data.WebLog.FindById rootId
Expect.isSome webLog "The root web log should have been returned"
do! data.WebLog.UpdateRssOptions { webLog.Value with Rss = { webLog.Value.Rss with CustomFeeds = [] } }
let! updated = data.WebLog.FindById rootId
Expect.isSome updated "The updated web log should have been returned"
Expect.isEmpty updated.Value.Rss.CustomFeeds "RSS options not updated correctly"
}
let ``UpdateRssOptions succeeds when the web log does not exist`` (data: IData) = task {
do! data.WebLog.UpdateRssOptions { WebLog.Empty with Id = WebLogId "rss-less" }
Expect.isTrue true "This not raising an exception is the test"
}
let ``UpdateSettings succeeds when the web log exists`` (data: IData) = task {
let! webLog = data.WebLog.FindById rootId
Expect.isSome webLog "The root web log should have been returned"
do! data.WebLog.UpdateSettings { webLog.Value with AutoHtmx = false; Subtitle = None }
let! updated = data.WebLog.FindById rootId
Expect.isSome updated "The updated web log should have been returned"
Expect.isFalse updated.Value.AutoHtmx "Auto htmx flag not updated correctly"
Expect.isNone updated.Value.Subtitle "Subtitle not updated correctly"
}
let ``UpdateSettings succeeds when the web log does not exist`` (data: IData) = task {
do! data.WebLog.UpdateRedirectRules { WebLog.Empty with Id = WebLogId "no-settings" }
let! webLog = data.WebLog.FindById (WebLogId "no-settings")
Expect.isNone webLog "Updating settings should not have created a web log"
}
let ``Delete succeeds when the web log exists`` (data: IData) = task {
do! data.WebLog.Delete rootId
let! cats = data.Category.FindByWebLog rootId
Expect.isEmpty cats "There should be no categories remaining"
let! pages = data.Page.FindFullByWebLog rootId
Expect.isEmpty pages "There should be no pages remaining"
let! posts = data.Post.FindFullByWebLog rootId
Expect.isEmpty posts "There should be no posts remaining"
let! tagMappings = data.TagMap.FindByWebLog rootId
Expect.isEmpty tagMappings "There should be no tag mappings remaining"
let! uploads = data.Upload.FindByWebLog rootId
Expect.isEmpty uploads "There should be no uploads remaining"
let! users = data.WebLogUser.FindByWebLog rootId
Expect.isEmpty users "There should be no users remaining"
}
let ``Delete succeeds when the web log does not exist`` (data: IData) = task {
do! data.WebLog.Delete rootId // already deleted above
Expect.isTrue true "This not raising an exception is the test"
}

View File

@@ -0,0 +1,184 @@
/// <summary>
/// Integration tests for <see cref="IWebLogUserData" /> implementations
/// </summary>
module WebLogUserDataTests
open Expecto
open MyWebLog
open MyWebLog.Data
open NodaTime
/// The ID of the root web log
let private rootId = CategoryDataTests.rootId
/// The ID of the admin user
let private adminId = WebLogUserId "5EM2rimH9kONpmd2zQkiVA"
/// The ID of the editor user
let private editorId = WebLogUserId "GPbJaSOwTkKt14ZKYyveKA"
/// The ID of the author user
let private authorId = WebLogUserId "iIRNLSeY0EanxRPyqGuwVg"
/// The ID of the user added during the run of these tests
let private newId = WebLogUserId "new-user"
let ``Add succeeds`` (data: IData) = task {
do! data.WebLogUser.Add
{ Id = newId
WebLogId = rootId
Email = "new@example.com"
FirstName = "New"
LastName = "User"
PreferredName = "n00b"
PasswordHash = "hashed-password"
Url = Some "https://example.com/~new"
AccessLevel = Author
CreatedOn = Noda.epoch + Duration.FromDays 365
LastSeenOn = None }
let! user = data.WebLogUser.FindById newId rootId
Expect.isSome user "There should have been a user returned"
let it = user.Value
Expect.equal it.Id newId "ID is incorrect"
Expect.equal it.WebLogId rootId "Web log ID is incorrect"
Expect.equal it.Email "new@example.com" "E-mail address is incorrect"
Expect.equal it.FirstName "New" "First name is incorrect"
Expect.equal it.LastName "User" "Last name is incorrect"
Expect.equal it.PreferredName "n00b" "Preferred name is incorrect"
Expect.equal it.PasswordHash "hashed-password" "Password hash is incorrect"
Expect.equal it.Url (Some "https://example.com/~new") "URL is incorrect"
Expect.equal it.AccessLevel Author "Access level is incorrect"
Expect.equal it.CreatedOn (Noda.epoch + Duration.FromDays 365) "Created on is incorrect"
Expect.isNone it.LastSeenOn "Last seen on should not have had a value"
}
let ``FindByEmail succeeds when a user is found`` (data: IData) = task {
let! user = data.WebLogUser.FindByEmail "root@example.com" rootId
Expect.isSome user "There should have been a user returned"
Expect.equal user.Value.Id adminId "The wrong user was returned"
}
let ``FindByEmail succeeds when a user is not found (incorrect weblog)`` (data: IData) = task {
let! user = data.WebLogUser.FindByEmail "root@example.com" (WebLogId "other")
Expect.isNone user "There should not have been a user returned"
}
let ``FindByEmail succeeds when a user is not found (bad email)`` (data: IData) = task {
let! user = data.WebLogUser.FindByEmail "wwwdata@example.com" rootId
Expect.isNone user "There should not have been a user returned"
}
let ``FindById succeeds when a user is found`` (data: IData) = task {
let! user = data.WebLogUser.FindById adminId rootId
Expect.isSome user "There should have been a user returned"
Expect.equal user.Value.Id adminId "The wrong user was returned"
// The remainder of field population is tested in the "Add succeeds" test above
}
let ``FindById succeeds when a user is not found (incorrect weblog)`` (data: IData) = task {
let! user = data.WebLogUser.FindById adminId (WebLogId "not-admin")
Expect.isNone user "There should not have been a user returned"
}
let ``FindById succeeds when a user is not found (bad ID)`` (data: IData) = task {
let! user = data.WebLogUser.FindById (WebLogUserId "tom") rootId
Expect.isNone user "There should not have been a user returned"
}
let ``FindByWebLog succeeds when users exist`` (data: IData) = task {
let! users = data.WebLogUser.FindByWebLog rootId
Expect.hasLength users 4 "There should have been 4 users returned"
for user in users do
Expect.contains [ adminId; editorId; authorId; newId ] user.Id $"Unexpected user returned ({user.Id})"
}
let ``FindByWebLog succeeds when no users exist`` (data: IData) = task {
let! users = data.WebLogUser.FindByWebLog (WebLogId "no-users")
Expect.isEmpty users "There should have been no users returned"
}
let ``FindNames succeeds when users exist`` (data: IData) = task {
let! names = data.WebLogUser.FindNames rootId [ editorId; authorId ]
let expected =
[ { Name = string editorId; Value = "Edits It-Or" }; { Name = string authorId; Value = "Mister Dude" } ]
Expect.hasLength names 2 "There should have been 2 names returned"
for name in names do Expect.contains expected name $"Unexpected name returned ({name.Name}|{name.Value})"
}
let ``FindNames succeeds when users do not exist`` (data: IData) = task {
let! names = data.WebLogUser.FindNames rootId [ WebLogUserId "nope"; WebLogUserId "no" ]
Expect.isEmpty names "There should have been no names returned"
}
let ``SetLastSeen succeeds when the user exists`` (data: IData) = task {
let now = Noda.now ()
do! data.WebLogUser.SetLastSeen newId rootId
let! user = data.WebLogUser.FindById newId rootId
Expect.isSome user "The user should have been returned"
let it = user.Value
Expect.isSome it.LastSeenOn "Last seen on should have been set"
Expect.isGreaterThanOrEqual it.LastSeenOn.Value now "The last seen on date/time was not set correctly"
}
let ``SetLastSeen succeeds when the user does not exist`` (data: IData) = task {
do! data.WebLogUser.SetLastSeen (WebLogUserId "matt") rootId
Expect.isTrue true "This not raising an exception is the test"
}
let ``Update succeeds when the user exists`` (data: IData) = task {
let! currentUser = data.WebLogUser.FindById newId rootId
Expect.isSome currentUser "The current user should have been found"
do! data.WebLogUser.Update
{ currentUser.Value with
Email = "newish@example.com"
FirstName = "New-ish"
LastName = "User-ish"
PreferredName = "n00b-ish"
PasswordHash = "hashed-ish-password"
Url = None
AccessLevel = Editor }
let! updated = data.WebLogUser.FindById newId rootId
Expect.isSome updated "The updated user should have been returned"
let it = updated.Value
Expect.equal it.Id newId "ID is incorrect"
Expect.equal it.WebLogId rootId "Web log ID is incorrect"
Expect.equal it.Email "newish@example.com" "E-mail address is incorrect"
Expect.equal it.FirstName "New-ish" "First name is incorrect"
Expect.equal it.LastName "User-ish" "Last name is incorrect"
Expect.equal it.PreferredName "n00b-ish" "Preferred name is incorrect"
Expect.equal it.PasswordHash "hashed-ish-password" "Password hash is incorrect"
Expect.isNone it.Url "URL is incorrect"
Expect.equal it.AccessLevel Editor "Access level is incorrect"
Expect.equal it.CreatedOn (Noda.epoch + Duration.FromDays 365) "Created on is incorrect"
Expect.isSome it.LastSeenOn "Last seen on should have had a value"
}
let ``Update succeeds when the user does not exist`` (data: IData) = task {
do! data.WebLogUser.Update { WebLogUser.Empty with Id = WebLogUserId "nothing"; WebLogId = rootId }
let! updated = data.WebLogUser.FindById (WebLogUserId "nothing") rootId
Expect.isNone updated "The update of a missing user should not have created the user"
}
let ``Delete fails when the user is the author of a page`` (data: IData) = task {
match! data.WebLogUser.Delete adminId rootId with
| Ok _ -> Expect.isTrue false "Deletion should have failed because the user is a page author"
| Error msg -> Expect.equal msg "User has pages or posts; cannot delete" "Error message is incorrect"
}
let ``Delete fails when the user is the author of a post`` (data: IData) = task {
match! data.WebLogUser.Delete authorId rootId with
| Ok _ -> Expect.isTrue false "Deletion should have failed because the user is a post author"
| Error msg -> Expect.equal msg "User has pages or posts; cannot delete" "Error message is incorrect"
}
let ``Delete succeeds when the user is not an author`` (data: IData) = task {
match! data.WebLogUser.Delete newId rootId with
| Ok _ -> Expect.isTrue true "This is the expected outcome"
| Error msg -> Expect.isTrue false $"Deletion unexpectedly failed (message {msg})"
}
let ``Delete succeeds when the user does not exist`` (data: IData) = task {
match! data.WebLogUser.Delete newId rootId with // already deleted above
| Ok _ -> Expect.isTrue false "Deletion should have failed because the user does not exist"
| Error msg -> Expect.equal msg "User does not exist" "Error message is incorrect"
}

View File

@@ -0,0 +1,87 @@
module DataTypesTests
open Expecto
open MyWebLog
/// Unit tests for the WebLog type
let webLogTests = testList "WebLog" [
testList "ExtraPath" [
test "succeeds for blank URL base" {
Expect.equal WebLog.Empty.ExtraPath "" "Extra path should have been blank for blank URL base"
}
test "succeeds for domain root URL" {
Expect.equal
{ WebLog.Empty with UrlBase = "https://example.com" }.ExtraPath
""
"Extra path should have been blank for domain root"
}
test "succeeds for single subdirectory" {
Expect.equal
{ WebLog.Empty with UrlBase = "https://a.com/sub" }.ExtraPath
"/sub"
"Extra path incorrect for a single subdirectory"
}
test "succeeds for deeper nesting" {
Expect.equal
{ WebLog.Empty with UrlBase = "https://b.com/users/test/units" }.ExtraPath
"/users/test/units"
"Extra path incorrect for deeper nesting"
}
]
test "AbsoluteUrl succeeds" {
Expect.equal
({ WebLog.Empty with UrlBase = "https://my.site" }.AbsoluteUrl(Permalink "blog/page.html"))
"https://my.site/blog/page.html"
"Absolute URL is incorrect"
}
testList "RelativeUrl" [
test "succeeds for domain root URL" {
Expect.equal
({ WebLog.Empty with UrlBase = "https://test.me" }.RelativeUrl(Permalink "about.htm"))
"/about.htm"
"Relative URL is incorrect for domain root site"
}
test "succeeds for domain non-root URL" {
Expect.equal
({ WebLog.Empty with UrlBase = "https://site.page/a/b/c" }.RelativeUrl(Permalink "x/y/z"))
"/a/b/c/x/y/z"
"Relative URL is incorrect for domain non-root site"
}
]
testList "LocalTime" [
test "succeeds when no time zone is set" {
Expect.equal
(WebLog.Empty.LocalTime(Noda.epoch))
(Noda.epoch.ToDateTimeUtc())
"Reference should be UTC when no time zone is specified"
}
test "succeeds when time zone is set" {
Expect.equal
({ WebLog.Empty with TimeZone = "Etc/GMT-1" }.LocalTime(Noda.epoch))
(Noda.epoch.ToDateTimeUtc().AddHours 1)
"The time should have been adjusted by one hour"
}
]
]
/// Unit tests for the WebLogUser type
let webLogUserTests = testList "WebLogUser" [
testList "DisplayName" [
test "succeeds when a preferred name is present" {
Expect.equal
{ WebLogUser.Empty with
FirstName = "Thomas"; PreferredName = "Tom"; LastName = "Tester" }.DisplayName
"Tom Tester"
"Display name incorrect when preferred name is present"
}
test "succeeds when a preferred name is absent" {
Expect.equal
{ WebLogUser.Empty with FirstName = "Test"; LastName = "Units" }.DisplayName
"Test Units"
"Display name incorrect when preferred name is absent"
}
]
]
/// All tests for the Domain.DataTypes file
let all = testList "DataTypes" [ webLogTests; webLogUserTests ]

View File

@@ -0,0 +1,415 @@
module SupportTypesTests
open System
open Expecto
open MyWebLog
open NodaTime
/// Tests for the NodaTime-wrapping module
let nodaTests = testList "Noda" [
test "epoch succeeds" {
Expect.equal
(Noda.epoch.ToDateTimeUtc())
(DateTime(1970, 1, 1, 0, 0, 0, DateTimeKind.Utc))
"The Unix epoch value is not correct"
}
test "toSecondsPrecision succeeds" {
let testDate = Instant.FromDateTimeUtc(DateTime(1970, 1, 1, 0, 0, 0, 444, DateTimeKind.Utc))
// testDate.
Expect.equal
((Noda.toSecondsPrecision testDate).ToDateTimeUtc())
(Noda.epoch.ToDateTimeUtc())
"Instant value was not rounded to seconds precision"
}
test "fromDateTime succeeds" {
let testDate = DateTime(1970, 1, 1, 0, 0, 0, 444, DateTimeKind.Utc)
Expect.equal (Noda.fromDateTime testDate) Noda.epoch "fromDateTime did not truncate to seconds"
}
]
/// Tests for the AccessLevel type
let accessLevelTests = testList "AccessLevel" [
testList "Parse" [
test "succeeds for \"Author\"" {
Expect.equal Author (AccessLevel.Parse "Author") "Author not parsed correctly"
}
test "succeeds for \"Editor\"" {
Expect.equal Editor (AccessLevel.Parse "Editor") "Editor not parsed correctly"
}
test "succeeds for \"WebLogAdmin\"" {
Expect.equal WebLogAdmin (AccessLevel.Parse "WebLogAdmin") "WebLogAdmin not parsed correctly"
}
test "succeeds for \"Administrator\"" {
Expect.equal Administrator (AccessLevel.Parse "Administrator") "Administrator not parsed correctly"
}
test "fails when given an unrecognized value" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (AccessLevel.Parse "Hacker")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "Author succeeds" {
Expect.equal (string Author) "Author" "Author string incorrect"
}
test "Editor succeeds" {
Expect.equal (string Editor) "Editor" "Editor string incorrect"
}
test "WebLogAdmin succeeds" {
Expect.equal (string WebLogAdmin) "WebLogAdmin" "WebLogAdmin string incorrect"
}
test "Administrator succeeds" {
Expect.equal (string Administrator) "Administrator" "Administrator string incorrect"
}
]
testList "HasAccess" [
test "Author has Author access" {
Expect.isTrue (Author.HasAccess Author) "Author should have Author access"
}
test "Author does not have Editor access" {
Expect.isFalse (Author.HasAccess Editor) "Author should not have Editor access"
}
test "Author does not have WebLogAdmin access" {
Expect.isFalse (Author.HasAccess WebLogAdmin) "Author should not have WebLogAdmin access"
}
test "Author does not have Administrator access" {
Expect.isFalse (Author.HasAccess Administrator) "Author should not have Administrator access"
}
test "Editor has Author access" {
Expect.isTrue (Editor.HasAccess Author) "Editor should have Author access"
}
test "Editor has Editor access" {
Expect.isTrue (Editor.HasAccess Editor) "Editor should have Editor access"
}
test "Editor does not have WebLogAdmin access" {
Expect.isFalse (Editor.HasAccess WebLogAdmin) "Editor should not have WebLogAdmin access"
}
test "Editor does not have Administrator access" {
Expect.isFalse (Editor.HasAccess Administrator) "Editor should not have Administrator access"
}
test "WebLogAdmin has Author access" {
Expect.isTrue (WebLogAdmin.HasAccess Author) "WebLogAdmin should have Author access"
}
test "WebLogAdmin has Editor access" {
Expect.isTrue (WebLogAdmin.HasAccess Editor) "WebLogAdmin should have Editor access"
}
test "WebLogAdmin has WebLogAdmin access" {
Expect.isTrue (WebLogAdmin.HasAccess WebLogAdmin) "WebLogAdmin should have WebLogAdmin access"
}
test "WebLogAdmin does not have Administrator access" {
Expect.isFalse (WebLogAdmin.HasAccess Administrator) "WebLogAdmin should not have Administrator access"
}
test "Administrator has Author access" {
Expect.isTrue (Administrator.HasAccess Author) "Administrator should have Author access"
}
test "Administrator has Editor access" {
Expect.isTrue (Administrator.HasAccess Editor) "Administrator should have Editor access"
}
test "Administrator has WebLogAdmin access" {
Expect.isTrue (Administrator.HasAccess WebLogAdmin) "Administrator should have WebLogAdmin access"
}
test "Administrator has Administrator access" {
Expect.isTrue (Administrator.HasAccess Administrator) "Administrator should have Administrator access"
}
]
]
/// Tests for the CommentStatus type
let commentStatusTests = testList "CommentStatus" [
testList "Parse" [
test "succeeds for \"Approved\"" {
Expect.equal Approved (CommentStatus.Parse "Approved") "Approved not parsed correctly"
}
test "succeeds for \"Pending\"" {
Expect.equal Pending (CommentStatus.Parse "Pending") "Pending not parsed correctly"
}
test "succeeds for \"Spam\"" {
Expect.equal Spam (CommentStatus.Parse "Spam") "Spam not parsed correctly"
}
test "fails for unrecognized value" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (CommentStatus.Parse "Live")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "Approved succeeds" {
Expect.equal (string Approved) "Approved" "Approved string incorrect"
}
test "Pending succeeds" {
Expect.equal (string Pending) "Pending" "Pending string incorrect"
}
test "Spam succeeds" {
Expect.equal (string Spam) "Spam" "Spam string incorrect"
}
]
]
/// Tests for the ExplicitRating type
let explicitRatingTests = testList "ExplicitRating" [
testList "Parse" [
test "succeeds for \"yes\"" {
Expect.equal Yes (ExplicitRating.Parse "yes") "\"yes\" not parsed correctly"
}
test "succeeds for \"no\"" {
Expect.equal No (ExplicitRating.Parse "no") "\"no\" not parsed correctly"
}
test "succeeds for \"clean\"" {
Expect.equal Clean (ExplicitRating.Parse "clean") "\"clean\" not parsed correctly"
}
test "fails for unrecognized value" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (ExplicitRating.Parse "maybe")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "Yes succeeds" {
Expect.equal (string Yes) "yes" "Yes string incorrect"
}
test "No succeeds" {
Expect.equal (string No) "no" "No string incorrect"
}
test "Clean succeeds" {
Expect.equal (string Clean) "clean" "Clean string incorrect"
}
]
]
/// Tests for the Episode type
let episodeTests = testList "Episode" [
testList "FormatDuration" [
test "succeeds when no duration is specified" {
Expect.isNone (Episode.Empty.FormatDuration()) "A missing duration should have returned None"
}
test "succeeds when duration is specified" {
Expect.equal
({ Episode.Empty with
Duration = Some (Duration.FromMinutes 3L + Duration.FromSeconds 13L) }.FormatDuration())
(Some "0:03:13")
"Duration not formatted correctly"
}
test "succeeds when duration is > 10 hours" {
Expect.equal
({ Episode.Empty with Duration = Some (Duration.FromHours 11) }.FormatDuration())
(Some "11:00:00")
"Duration not formatted correctly"
}
]
]
/// Unit tests for the MarkupText type
let markupTextTests = testList "MarkupText" [
testList "Parse" [
test "succeeds with HTML content" {
let txt = MarkupText.Parse "HTML: <p>howdy</p>"
match txt with
| Html it when it = "<p>howdy</p>" -> ()
| _ -> Expect.isTrue false $"Unexpected parse result for HTML: %A{txt}"
}
test "succeeds with Markdown content" {
let txt = MarkupText.Parse "Markdown: # A Title"
match txt with
| Markdown it when it = "# A Title" -> ()
| _ -> Expect.isTrue false $"Unexpected parse result for Markdown: %A{txt}"
}
test "fails with unexpected content" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (MarkupText.Parse "LaTEX: nope")) "Invalid value should have raised an exception"
}
]
testList "SourceType" [
test "succeeds for HTML" {
Expect.equal (MarkupText.Parse "HTML: something").SourceType "HTML" "HTML source type incorrect"
}
test "succeeds for Markdown" {
Expect.equal (MarkupText.Parse "Markdown: blah").SourceType "Markdown" "Markdown source type incorrect"
}
]
testList "Text" [
test "succeeds for HTML" {
Expect.equal (MarkupText.Parse "HTML: test").Text "test" "HTML text incorrect"
}
test "succeeds for Markdown" {
Expect.equal (MarkupText.Parse "Markdown: test!").Text "test!" "Markdown text incorrect"
}
]
testList "ToString" [
test "succeeds for HTML" {
Expect.equal
(string (MarkupText.Parse "HTML: <h1>HTML</h1>")) "HTML: <h1>HTML</h1>" "HTML string value incorrect"
}
test "succeeds for Markdown" {
Expect.equal
(string (MarkupText.Parse "Markdown: # Some Content"))
"Markdown: # Some Content"
"Markdown string value incorrect"
}
]
testList "AsHtml" [
test "succeeds for HTML" {
Expect.equal
((MarkupText.Parse "HTML: <h1>The Heading</h1>").AsHtml()) "<h1>The Heading</h1>" "HTML value incorrect"
}
test "succeeds for Markdown" {
Expect.equal
((MarkupText.Parse "Markdown: *emphasis*").AsHtml())
"<p><em>emphasis</em></p>\n"
"Markdown HTML value incorrect"
}
]
]
/// Unit tests for the PodcastMedium type
let podcastMediumTests = testList "PodcastMedium" [
testList "Parse" [
test "succeeds for \"podcast\"" {
Expect.equal (PodcastMedium.Parse "podcast") Podcast "\"podcast\" not parsed correctly"
}
test "succeeds for \"music\"" {
Expect.equal (PodcastMedium.Parse "music") Music "\"music\" not parsed correctly"
}
test "succeeds for \"video\"" {
Expect.equal (PodcastMedium.Parse "video") Video "\"video\" not parsed correctly"
}
test "succeeds for \"film\"" {
Expect.equal (PodcastMedium.Parse "film") Film "\"film\" not parsed correctly"
}
test "succeeds for \"audiobook\"" {
Expect.equal (PodcastMedium.Parse "audiobook") Audiobook "\"audiobook\" not parsed correctly"
}
test "succeeds for \"newsletter\"" {
Expect.equal (PodcastMedium.Parse "newsletter") Newsletter "\"newsletter\" not parsed correctly"
}
test "succeeds for \"blog\"" {
Expect.equal (PodcastMedium.Parse "blog") Blog "\"blog\" not parsed correctly"
}
test "fails for invalid type" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (PodcastMedium.Parse "laser")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "succeeds for Podcast" {
Expect.equal (string Podcast) "podcast" "Podcast string incorrect"
}
test "succeeds for Music" {
Expect.equal (string Music) "music" "Music string incorrect"
}
test "succeeds for Video" {
Expect.equal (string Video) "video" "Video string incorrect"
}
test "succeeds for Film" {
Expect.equal (string Film) "film" "Film string incorrect"
}
test "succeeds for Audiobook" {
Expect.equal (string Audiobook) "audiobook" "Audiobook string incorrect"
}
test "succeeds for Newsletter" {
Expect.equal (string Newsletter) "newsletter" "Newsletter string incorrect"
}
test "succeeds for Blog" {
Expect.equal (string Blog) "blog" "Blog string incorrect"
}
]
]
/// Unit tests for the PostStatus type
let postStatusTests = testList "PostStatus" [
testList "Parse" [
test "succeeds for \"Draft\"" {
Expect.equal (PostStatus.Parse "Draft") Draft "\"Draft\" not parsed correctly"
}
test "succeeds for \"Published\"" {
Expect.equal (PostStatus.Parse "Published") Published "\"Published\" not parsed correctly"
}
test "fails for unrecognized value" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (PostStatus.Parse "Rescinded")) "Invalid value should have raised an exception"
}
]
]
/// Unit tests for the CustomFeedSource type
let customFeedSourceTests = testList "CustomFeedSource" [
testList "Parse" [
test "succeeds for category feeds" {
Expect.equal
(CustomFeedSource.Parse "category:abc123")
(Category (CategoryId "abc123"))
"Category feed not parsed correctly"
}
test "succeeds for tag feeds" {
Expect.equal (CustomFeedSource.Parse "tag:turtles") (Tag "turtles") "Tag feed not parsed correctly"
}
test "fails for unknown type" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (CustomFeedSource.Parse "nasa:sat1")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "succeeds for category feed" {
Expect.equal
(string (CustomFeedSource.Parse "category:fish")) "category:fish" "Category feed string incorrect"
}
test "succeeds for tag feed" {
Expect.equal (string (CustomFeedSource.Parse "tag:rocks")) "tag:rocks" "Tag feed string incorrect"
}
]
]
/// Unit tests for the ThemeAssetId type
let themeAssetIdTests = testList "ThemeAssetId" [
testList "Parse" [
test "succeeds with expected values" {
Expect.equal
(ThemeAssetId.Parse "test-theme/the-asset")
(ThemeAssetId ((ThemeId "test-theme"), "the-asset"))
"Theme asset ID not parsed correctly"
}
test "fails if no slash is present" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (ThemeAssetId.Parse "my-theme-asset")) "Invalid value should have raised an exception"
}
]
test "ToString succeeds" {
Expect.equal
(string (ThemeAssetId ((ThemeId "howdy"), "pardner"))) "howdy/pardner" "Theme asset ID string incorrect"
}
]
/// Unit tests for the UploadDestination type
let uploadDestinationTests = testList "UploadDestination" [
testList "Parse" [
test "succeeds for \"Database\"" {
Expect.equal (UploadDestination.Parse "Database") Database "\"Database\" not parsed correctly"
}
test "succeeds for \"Disk\"" {
Expect.equal (UploadDestination.Parse "Disk") Disk "\"Disk\" not parsed correctly"
}
test "fails for unrecognized value" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (UploadDestination.Parse "Azure")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "succeeds for Database" {
Expect.equal (string Database) "Database" "Database string incorrect"
}
test "succeeds for Disk" {
Expect.equal (string Disk) "Disk" "Disk string incorrect"
}
]
]
/// All tests for the Domain.SupportTypes file
let all = testList "SupportTypes" [
nodaTests
accessLevelTests
commentStatusTests
explicitRatingTests
episodeTests
markupTextTests
podcastMediumTests
postStatusTests
customFeedSourceTests
themeAssetIdTests
uploadDestinationTests
]

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,38 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<OutputType>Exe</OutputType>
</PropertyGroup>
<ItemGroup>
<Compile Include="Domain\SupportTypesTests.fs" />
<Compile Include="Domain\DataTypesTests.fs" />
<Compile Include="Domain\ViewModelsTests.fs" />
<Compile Include="Data\ConvertersTests.fs" />
<Compile Include="Data\UtilsTests.fs" />
<Compile Include="Data\CategoryDataTests.fs" />
<Compile Include="Data\PageDataTests.fs" />
<Compile Include="Data\PostDataTests.fs" />
<Compile Include="Data\TagMapDataTests.fs" />
<Compile Include="Data\ThemeDataTests.fs" />
<Compile Include="Data\UploadDataTests.fs" />
<Compile Include="Data\WebLogUserDataTests.fs" />
<Compile Include="Data\WebLogDataTests.fs" />
<Compile Include="Data\RethinkDbDataTests.fs" />
<Compile Include="Data\SQLiteDataTests.fs" />
<Compile Include="Data\PostgresDataTests.fs" />
<Compile Include="Program.fs" />
<None Include="root-weblog.json" />
</ItemGroup>
<ItemGroup>
<PackageReference Include="Expecto" Version="10.2.1" />
<PackageReference Include="ThrowawayDb.Postgres" Version="1.4.0" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
</ItemGroup>
<ItemGroup>
<ProjectReference Include="..\MyWebLog\MyWebLog.fsproj" />
</ItemGroup>
</Project>

View File

@@ -0,0 +1,31 @@
open Expecto
/// Whether to only run RethinkDB data tests
let rethinkOnly = (RethinkDbDataTests.env "RETHINK_ONLY" "0") = "1"
/// Whether to only run SQLite data tests
let sqliteOnly = (RethinkDbDataTests.env "SQLITE_ONLY" "0") = "1"
/// Whether to only run PostgreSQL data tests
let postgresOnly = (RethinkDbDataTests.env "PG_ONLY" "0") = "1"
/// Whether any of the data tests are being isolated
let dbOnly = rethinkOnly || sqliteOnly || postgresOnly
/// Whether to only run the unit tests (skip database/integration tests)
let unitOnly = (RethinkDbDataTests.env "UNIT_ONLY" "0") = "1"
let allTests = testList "MyWebLog" [
if not dbOnly then testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ]
if not unitOnly then
testList "Data" [
if not dbOnly then ConvertersTests.all
if not dbOnly then UtilsTests.all
if not dbOnly || (dbOnly && rethinkOnly) then RethinkDbDataTests.all
if not dbOnly || (dbOnly && sqliteOnly) then SQLiteDataTests.all
if not dbOnly || (dbOnly && postgresOnly) then PostgresDataTests.all
]
]
[<EntryPoint>]
let main args = runTestsWithCLIArgs [] args allTests

File diff suppressed because one or more lines are too long

View File

@@ -9,6 +9,8 @@ Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "MyWebLog.Data", "MyWebLog.D
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
@@ -27,6 +29,10 @@ Global
{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

View File

@@ -42,7 +42,7 @@ module Extensions =
member this.UserAccessLevel =
this.User.Claims
|> 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
member this.UserId =
@@ -53,8 +53,7 @@ module Extensions =
/// Does the current user have the requested level of access?
member this.HasAccessLevel level =
defaultArg (this.UserAccessLevel |> Option.map (AccessLevel.hasAccess level)) false
defaultArg (this.UserAccessLevel |> Option.map _.HasAccess(level)) false
open System.Collections.Concurrent
@@ -66,26 +65,60 @@ open System.Collections.Concurrent
/// settings update page</remarks>
module WebLogCache =
open System.Text.RegularExpressions
/// A redirect rule that caches compiled regular expression rules
type CachedRedirectRule =
/// A straight text match rule
| Text of string * string
/// A regular expression match rule
| RegEx of Regex * string
/// The cache of web log details
let mutable private _cache : WebLog list = []
/// Redirect rules with compiled regular expressions
let mutable private _redirectCache = ConcurrentDictionary<WebLogId, CachedRedirectRule list> ()
/// Try to get the web log for the current request (longest matching URL base wins)
let tryGet (path : string) =
_cache
|> List.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending (fun wl -> wl.UrlBase.Length)
|> List.sortByDescending _.UrlBase.Length
|> List.tryHead
/// Cache the web log for a particular host
let set webLog =
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.Id <> webLog.Id))
_redirectCache[webLog.Id] <-
webLog.RedirectRules
|> List.map (fun it ->
let relUrl = Permalink >> webLog.RelativeUrl
let urlTo = if it.To.Contains "://" then it.To else relUrl it.To
if it.IsRegex then
let pattern = if it.From.StartsWith "^" then $"^{relUrl it.From[1..]}" else it.From
RegEx(Regex(pattern, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo)
else
Text(relUrl it.From, urlTo))
/// Get all cached web logs
let all () =
_cache
/// Fill the web log cache from the database
let fill (data: IData) = backgroundTask {
let! webLogs = data.WebLog.All()
_cache <- webLogs
webLogs |> List.iter set
}
/// Get the cached redirect rules for the given web log
let redirectRules webLogId =
_redirectCache[webLogId]
/// Is the given theme in use by any web logs?
let isThemeInUse themeId =
_cache |> List.exists (fun wl -> wl.ThemeId = themeId)
/// A cache of page information needed to display the page list in templates
module PageListCache =
@@ -93,22 +126,30 @@ module PageListCache =
open MyWebLog.ViewModels
/// Cache of displayed pages
let private _cache = ConcurrentDictionary<string, DisplayPage[]> ()
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage array> ()
let private fillPages (webLog: WebLog) pages =
_cache[webLog.Id] <-
pages
|> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" })
|> Array.ofList
/// Are there pages cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.UrlBase
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the pages for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.UrlBase]
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the pages for the current web log
let update (ctx: HttpContext) = backgroundTask {
let webLog = ctx.WebLog
let! pages = ctx.Data.Page.FindListed webLog.Id
_cache[webLog.UrlBase] <-
pages
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with Text = "" })
|> Array.ofList
let! pages = ctx.Data.Page.FindListed ctx.WebLog.Id
fillPages ctx.WebLog pages
}
/// Refresh the pages for the given web log
let refresh (webLog: WebLog) (data: IData) = backgroundTask {
let! pages = data.Page.FindListed webLog.Id
fillPages webLog pages
}
@@ -118,18 +159,24 @@ module CategoryCache =
open MyWebLog.ViewModels
/// The cache itself
let private _cache = ConcurrentDictionary<string, DisplayCategory[]> ()
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array> ()
/// Are there categories cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.UrlBase
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the categories for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.UrlBase]
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the cache with fresh data
let update (ctx: HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id
_cache[ctx.WebLog.UrlBase] <- cats
_cache[ctx.WebLog.Id] <- cats
}
/// Refresh the category cache for the given web log
let refresh webLogId (data: IData) = backgroundTask {
let! cats = data.Category.FindAllForView webLogId
_cache[webLogId] <- cats
}
@@ -147,30 +194,55 @@ module TemplateCache =
let private hasInclude = Regex("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
/// Get a template for the given theme and template name
let get (themeId : string) (templateName : string) (data : IData) = backgroundTask {
let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask {
let templatePath = $"{themeId}/{templateName}"
match _cache.ContainsKey templatePath with
| true -> ()
| true -> return Ok _cache[templatePath]
| false ->
match! data.Theme.FindById (ThemeId themeId) with
match! data.Theme.FindById themeId with
| Some theme ->
let mutable text = (theme.Templates |> List.find (fun t -> t.Name = templateName)).Text
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 = (theme.Templates |> List.find (fun t -> t.Name = child.Groups[1].Value)).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)
| None -> ()
return _cache[templatePath]
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 : string) =
let invalidateTheme (themeId: ThemeId) =
let keyPrefix = string themeId
_cache.Keys
|> Seq.filter (fun key -> key.StartsWith themeId)
|> 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
module ThemeAssetCache =

View File

@@ -7,6 +7,7 @@ open System.Web
open DotLiquid
open Giraffe.ViewEngine
open MyWebLog.ViewModels
open MyWebLog.Views
/// Extensions on the DotLiquid Context object
type Context with
@@ -21,7 +22,7 @@ let assetExists fileName (webLog : WebLog) =
ThemeAssetCache.get webLog.ThemeId |> List.exists (fun it -> it = fileName)
/// Obtain the link from known types
let permalink (ctx : Context) (item : obj) (linkFunc : WebLog -> Permalink -> string) =
let permalink (item: obj) (linkFunc: Permalink -> string) =
match item with
| :? String as link -> Some link
| :? DisplayPage as page -> Some page.Permalink
@@ -29,14 +30,14 @@ let permalink (ctx : Context) (item : obj) (linkFunc : WebLog -> Permalink -> st
| :? DropProxy as proxy -> Option.ofObj proxy["Permalink"] |> Option.map string
| _ -> None
|> function
| Some link -> linkFunc ctx.WebLog (Permalink link)
| 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 ctx item WebLog.absoluteUrl
permalink item ctx.WebLog.AbsoluteUrl
/// A filter to generate a link with posts categorized under the given category
@@ -47,7 +48,7 @@ type CategoryLinkFilter () =
| :? DropProxy as proxy -> Option.ofObj proxy["Slug"] |> Option.map string
| _ -> None
|> function
| Some slug -> WebLog.relativeUrl ctx.WebLog (Permalink $"category/{slug}/")
| Some slug -> ctx.WebLog.RelativeUrl(Permalink $"category/{slug}/")
| None -> $"alert('unknown category object type {catObj.GetType().Name}')"
@@ -60,7 +61,7 @@ type EditPageLinkFilter () =
| :? String as theId -> Some theId
| _ -> None
|> function
| Some pageId -> WebLog.relativeUrl ctx.WebLog (Permalink $"admin/page/{pageId}/edit")
| Some pageId -> ctx.WebLog.RelativeUrl(Permalink $"admin/page/{pageId}/edit")
| None -> $"alert('unknown page object type {pageObj.GetType().Name}')"
@@ -73,23 +74,23 @@ type EditPostLinkFilter () =
| :? String as theId -> Some theId
| _ -> None
|> function
| Some postId -> WebLog.relativeUrl ctx.WebLog (Permalink $"admin/post/{postId}/edit")
| 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 _, path = WebLog.hostAndPath ctx.WebLog
let path = if path = "" then path else $"{path.Substring 1}/"
let extraPath = ctx.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
seq {
"<li class=\"nav-item\"><a class=\"nav-link"
"<li class=nav-item><a class=\"nav-link"
if (string ctx.Environments[0].["current_page"]).StartsWith $"{path}{url}" then " active"
"\" href=\""
WebLog.relativeUrl ctx.WebLog (Permalink url)
ctx.WebLog.RelativeUrl(Permalink url)
"\">"
text
"</a></li>"
"</a>"
}
|> String.concat ""
@@ -97,7 +98,7 @@ type NavLinkFilter () =
/// A filter to generate a link for theme asset (image, stylesheet, script, etc.)
type ThemeAssetFilter() =
static member ThemeAsset(ctx: Context, asset: string) =
WebLog.relativeUrl ctx.WebLog (Permalink $"themes/{ThemeId.toString ctx.WebLog.ThemeId}/{asset}")
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
@@ -111,23 +112,23 @@ type PageHeadTag () =
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"]}">"""
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")}">"""
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")}">"""
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 webLog (Permalink url)
$"""{s}<link rel="alternate" type="application/rss+xml" title="{escTitle}" href="{relUrl}">"""
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 webLog Permalink.empty}">"""
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
@@ -139,13 +140,13 @@ type PageHeadTag () =
if getBool "is_post" then
let post = context.Environments[0].["model"] :?> PostDisplay
let url = WebLog.absoluteUrl webLog (Permalink post.Posts[0].Permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
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 webLog (Permalink page.Permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
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
@@ -167,7 +168,7 @@ type PageFootTag () =
/// A filter to generate a relative link
type RelativeLinkFilter() =
static member RelativeLink(ctx: Context, item: obj) =
permalink ctx item WebLog.relativeUrl
permalink item ctx.WebLog.RelativeUrl
/// A filter to generate a link with posts tagged with the given tag
@@ -178,7 +179,7 @@ type TagLinkFilter () =
|> function
| Some tagMap -> tagMap.UrlValue
| None -> tag.Replace(" ", "+")
|> function tagUrl -> WebLog.relativeUrl ctx.WebLog (Permalink $"tag/{tagUrl}/")
|> 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
@@ -186,21 +187,21 @@ type UserLinksTag () =
inherit Tag()
override this.Render(context: Context, result: TextWriter) =
let link it = WebLog.relativeUrl context.WebLog (Permalink it)
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>"""
$"""<li class="nav-item"><a class="nav-link" href="{link "user/log-off"}">Log Off</a></li>"""
$"""<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></li>"""
$"""<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 }}`)
// (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
@@ -224,15 +225,11 @@ let register () =
Template.RegisterTag<UserLinksTag> "user_links"
[ // Domain types
typeof<CustomFeed>; typeof<Episode>; typeof<Episode option>; typeof<MetaItem>; typeof<Page>
typeof<RssOptions>; typeof<TagMap>; typeof<UploadDestination>; typeof<WebLog>
typeof<CustomFeed>; typeof<Episode>; typeof<Episode option>; typeof<MetaItem>; typeof<Page>; typeof<RssOptions>
typeof<TagMap>; typeof<WebLog>
// View models
typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<DisplayRevision>; typeof<DisplayUpload>; typeof<DisplayUser>; typeof<EditCategoryModel>
typeof<EditCustomFeedModel>; typeof<EditMyInfoModel>; typeof<EditPageModel>; typeof<EditPostModel>
typeof<EditRssModel>; typeof<EditTagMapModel>; typeof<EditUserModel>; typeof<LogOnModel>
typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>; typeof<PostDisplay>; typeof<PostListItem>
typeof<SettingsModel>; typeof<UserMessage>
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>

View File

@@ -3,59 +3,109 @@ module MyWebLog.Handlers.Admin
open System.Threading.Tasks
open Giraffe
open Giraffe.Htmx
open MyWebLog
open MyWebLog.ViewModels
open NodaTime
// GET /admin
let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
/// ~~~ DASHBOARDS ~~~
module Dashboard =
// GET /admin/dashboard
let user : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let getCount (f: WebLogId -> Task<int>) = f ctx.WebLog.Id
let data = ctx.Data
let posts = getCount (data.Post.CountByStatus Published)
let drafts = getCount (data.Post.CountByStatus Draft)
let pages = getCount data.Page.CountAll
let listed = getCount data.Page.CountListed
let cats = getCount data.Category.CountAll
let topCats = getCount data.Category.CountTopLevel
let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats)
return!
hashForPage "Dashboard"
|> addToHash ViewContext.Model {
Posts = posts.Result
Drafts = drafts.Result
Pages = pages.Result
ListedPages = listed.Result
Categories = cats.Result
TopLevelCategories = topCats.Result
}
|> adminView "dashboard" next ctx
let! posts = getCount (data.Post.CountByStatus Published)
let! drafts = getCount (data.Post.CountByStatus Draft)
let! pages = getCount data.Page.CountAll
let! listed = getCount data.Page.CountListed
let! cats = getCount data.Category.CountAll
let! topCats = getCount data.Category.CountTopLevel
let model =
{ Posts = posts
Drafts = drafts
Pages = pages
ListedPages = listed
Categories = cats
TopLevelCategories = topCats }
return! adminPage "Dashboard" false next ctx (Views.WebLog.dashboard model)
}
// -- CATEGORIES --
// GET /admin/administration
let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let! themes = ctx.Data.Theme.All()
return! adminPage "myWebLog Administration" true next ctx (Views.Admin.dashboard themes)
}
/// Redirect the user to the admin dashboard
let toAdminDashboard : HttpHandler = redirectToGet "admin/administration"
/// ~~~ CACHES ~~~
module Cache =
// POST /admin/cache/web-log/{id}/refresh
let refreshWebLog webLogId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let data = ctx.Data
if webLogId = "all" then
do! WebLogCache.fill data
for webLog in WebLogCache.all () do
do! PageListCache.refresh webLog data
do! CategoryCache.refresh webLog.Id data
do! addMessage ctx
{ UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" }
else
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
{ 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
let refreshTheme themeId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let data = ctx.Data
if themeId = "all" then
TemplateCache.empty ()
do! ThemeAssetCache.fill data
do! addMessage ctx
{ UserMessage.Success with
Message = "Successfully cleared template cache and refreshed theme asset cache" }
else
match! data.Theme.FindById(ThemeId themeId) with
| Some theme ->
TemplateCache.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 ~~~
module Category =
open MyWebLog.Data
// GET /admin/categories
let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data
let! hash =
hashForPage "Categories"
|> withAntiCsrf ctx
|> addViewContext ctx
return!
addToHash "category_list" (catListTemplate.Render hash) hash
|> adminView "category-list" next ctx
}
// GET /admin/categories/bare
let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
hashForPage "Categories"
|> withAntiCsrf ctx
|> adminBareView "category-list-body" next ctx
let all : HttpHandler = fun next ctx ->
let response = fun next ctx ->
adminPage "Categories" true 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
let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let edit catId : HttpHandler = fun next ctx -> task {
let! result = task {
match catId with
| "new" -> return Some ("Add a New Category", { Category.empty with Id = CategoryId "new" })
| "new" -> return Some ("Add a New Category", { Category.Empty with Id = CategoryId "new" })
| _ ->
match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with
| Some cat -> return Some ("Edit Category", cat)
@@ -64,19 +114,17 @@ let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ct
match result with
| Some (title, cat) ->
return!
hashForPage title
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditCategoryModel.fromCategory cat)
|> adminBareView "category-edit" next ctx
Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat)
|> adminBarePage title true next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/save
let saveCategory : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let save : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditCategoryModel>()
let category =
if model.IsNew then someTask { Category.empty with Id = CategoryId.create (); WebLogId = ctx.WebLog.Id }
if model.IsNew then someTask { Category.Empty with Id = CategoryId.Create(); WebLogId = ctx.WebLog.Id }
else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id
match! category with
| Some cat ->
@@ -85,95 +133,163 @@ let saveCategory : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
Name = model.Name
Slug = model.Slug
Description = if model.Description = "" then None else Some model.Description
ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId)
}
ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId) }
do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Category saved successfully" }
return! listCategoriesBare next ctx
do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" }
return! all next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/{id}/delete
let deleteCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id with
| true ->
// DELETE /admin/category/{id}
let delete catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! result = ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id
match result with
| CategoryDeleted
| ReassignedChildCategories ->
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Category deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Category not found; cannot delete" }
return! listCategoriesBare next ctx
let detail =
match result with
| ReassignedChildCategories ->
Some "<em>(Its child categories were reassigned to its parent category)</em>"
| _ -> None
do! addMessage 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 ~~~
module RedirectRules =
open Microsoft.AspNetCore.Http
// -- TAG MAPPINGS --
// GET /admin/settings/redirect-rules
let all : HttpHandler = fun next ctx ->
adminPage "Redirect Rules" true next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules)
/// Get the hash necessary to render the tag mapping list
let private tagMappingHash (ctx : HttpContext) = task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return!
hashForPage "Tag Mappings"
|> withAntiCsrf ctx
|> addToHash "mappings" mappings
|> addToHash "mapping_ids" (mappings |> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id }))
|> addViewContext ctx
// GET /admin/settings/redirect-rules/[index]
let edit idx : HttpHandler = fun next ctx ->
let titleAndView =
if idx = -1 then
Some ("Add", Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty))
else
let rules = ctx.WebLog.RedirectRules
if rules.Length < idx || idx < 0 then
None
else
Some
("Edit", (Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules))))
match titleAndView with
| Some (title, view) -> adminBarePage $"{title} Redirect Rule" true next ctx view
| None -> Error.notFound next ctx
/// 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 {
do! ctx.Data.WebLog.UpdateRedirectRules webLog
ctx.Items["webLog"] <- webLog
WebLogCache.set webLog
}
// POST /admin/settings/redirect-rules/[index]
let save idx : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<EditRedirectRuleModel>()
let rule = model.ToRule()
let rules =
ctx.WebLog.RedirectRules
|> match idx with
| -1 when model.InsertAtTop -> List.insertAt 0 rule
| -1 -> List.insertAt ctx.WebLog.RedirectRules.Length rule
| _ -> 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
let moveUp idx : HttpHandler = fun next ctx -> task {
if idx < 1 || idx >= ctx.WebLog.RedirectRules.Length then
return! Error.notFound next ctx
else
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
let moveDown idx : HttpHandler = fun next ctx -> task {
if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length - 1 then
return! Error.notFound next ctx
else
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]
let delete idx : HttpHandler = fun next ctx -> task {
if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length then
return! Error.notFound next ctx
else
let rules = ctx.WebLog.RedirectRules |> List.removeAt idx
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 ~~~
module TagMapping =
// GET /admin/settings/tag-mappings
let tagMappings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = tagMappingHash ctx
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data
return!
addToHash "tag_mapping_list" (listTemplate.Render hash) hash
|> adminView "tag-mapping-list" next ctx
}
// GET /admin/settings/tag-mappings/bare
let tagMappingsBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = tagMappingHash ctx
return! adminBareView "tag-mapping-list-body" next ctx hash
let all : HttpHandler = fun next ctx -> task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return! adminBarePage "Tag Mapping List" true next ctx (Views.WebLog.tagMapList mappings)
}
// GET /admin/settings/tag-mapping/{id}/edit
let editMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let edit tagMapId : HttpHandler = fun next ctx -> task {
let isNew = tagMapId = "new"
let tagMap =
if isNew then someTask { TagMap.empty with Id = TagMapId "new" }
if isNew then someTask { TagMap.Empty with Id = TagMapId "new" }
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id
match! tagMap with
| Some tm ->
return!
hashForPage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag")
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditTagMapModel.fromMapping tm)
|> adminBareView "tag-mapping-edit" next ctx
Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm)
|> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") true next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/tag-mapping/save
let saveMapping : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let save : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditTagMapModel>()
let tagMap =
if model.IsNew then someTask { TagMap.empty with Id = TagMapId.create (); WebLogId = ctx.WebLog.Id }
if model.IsNew then someTask { TagMap.Empty with Id = TagMapId.Create(); WebLogId = ctx.WebLog.Id }
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id
match! tagMap with
| Some tm ->
do! data.TagMap.Save { tm with Tag = model.Tag.ToLower(); UrlValue = model.UrlValue.ToLower() }
do! addMessage ctx { UserMessage.success with Message = "Tag mapping saved successfully" }
return! tagMappingsBare next ctx
do! addMessage ctx { UserMessage.Success with Message = "Tag mapping saved successfully" }
return! all next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/tag-mapping/{id}/delete
let deleteMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// DELETE /admin/settings/tag-mapping/{id}
let delete tagMapId : HttpHandler = fun next ctx -> task {
match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.Id with
| true -> do! addMessage ctx { UserMessage.success with Message = "Tag mapping deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Tag mapping not found; nothing deleted" }
return! tagMappingsBare next ctx
| 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 ~~~
module Theme =
open System
open System.IO
@@ -181,11 +297,17 @@ open System.IO.Compression
open System.Text.RegularExpressions
open MyWebLog.Data
// GET /admin/theme/update
let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx ->
hashForPage "Upload Theme"
|> withAntiCsrf ctx
|> adminView "upload-theme" next ctx
// GET /admin/theme/list
let all : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let! themes = ctx.Data.Theme.All ()
return!
Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes)
|> adminBarePage "Themes" true next ctx
}
// GET /admin/theme/new
let add : HttpHandler = requireAccess Administrator >=> fun next ctx ->
adminBarePage "Upload a Theme File" true next ctx Views.Admin.themeUpload
/// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask {
@@ -195,18 +317,10 @@ let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = background
use versionFile = new StreamReader(versionItem.Open())
let! versionText = versionFile.ReadToEndAsync()
let parts = versionText.Trim().Replace("\r", "").Split "\n"
let displayName = if parts[0] > "" then parts[0] else ThemeId.toString theme.Id
let displayName = if parts[0] > "" then parts[0] else string theme.Id
let version = if parts.Length > 1 && parts[1] > "" then parts[1] else now ()
return { theme with Name = displayName; Version = version }
| None -> return { theme with Name = ThemeId.toString theme.Id; Version = now () }
}
/// Delete all theme assets, and remove templates from theme
let private checkForCleanLoad (theme : Theme) cleanLoad (data : IData) = backgroundTask {
if cleanLoad then
do! data.ThemeAsset.DeleteByTheme theme.Id
return { theme with Templates = [] }
else return theme
| None -> return { theme with Name = string theme.Id; Version = now () }
}
/// Update the theme with all templates from the ZIP archive
@@ -229,103 +343,138 @@ let private updateTemplates (theme : Theme) (zip : ZipArchive) = backgroundTask
/// Update theme assets from the ZIP archive
let private updateAssets themeId (zip: ZipArchive) (data: IData) = backgroundTask {
for asset in zip.Entries |> Seq.filter (fun it -> it.FullName.StartsWith "wwwroot") do
for asset in zip.Entries |> Seq.filter _.FullName.StartsWith("wwwroot") do
let assetName = asset.FullName.Replace("wwwroot/", "")
if assetName <> "" && not (assetName.EndsWith "/") then
use stream = new MemoryStream()
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.Save
{ Id = ThemeAssetId(themeId, assetName)
UpdatedOn = asset.LastWriteTime.DateTime
UpdatedOn = LocalDateTime.FromDateTime(asset.LastWriteTime.DateTime)
.InZoneLeniently(DateTimeZone.Utc).ToInstant()
Data = stream.ToArray()
}
}
/// Get the theme name from the file name given
let getThemeName (fileName : string) =
/// Derive the theme ID from the file name given
let deriveIdFromFileName (fileName: string) =
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace(" ", "-")
if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then Ok themeName else Error $"Theme name {fileName} is invalid"
if themeName.EndsWith "-theme" then
if Regex.IsMatch(themeName, """^[a-z0-9\-]+$""") then
Ok(ThemeId(themeName[..themeName.Length - 7]))
else Error $"Theme ID {fileName} is invalid"
else Error "Theme .zip file name must end in \"-theme.zip\""
/// Load a theme from the given stream, which should contain a ZIP archive
let loadThemeFromZip themeName file clean (data : IData) = backgroundTask {
use zip = new ZipArchive (file, ZipArchiveMode.Read)
let themeId = ThemeId themeName
let! theme = backgroundTask {
let loadFromZip themeId file (data: IData) = backgroundTask {
let! isNew, theme = backgroundTask {
match! data.Theme.FindById themeId with
| Some t -> return t
| None -> return { Theme.empty with Id = themeId }
| Some t -> return false, t
| None -> return true, { Theme.Empty with Id = themeId }
}
use zip = new ZipArchive(file, ZipArchiveMode.Read)
let! theme = updateNameAndVersion theme zip
let! theme = checkForCleanLoad theme clean data
let! theme = updateTemplates theme zip
if not isNew then do! data.ThemeAsset.DeleteByTheme theme.Id
let! theme = updateTemplates { theme with Templates = [] } zip
do! data.Theme.Save theme
do! updateAssets themeId zip data
return theme
}
// POST /admin/theme/update
let updateTheme : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
// POST /admin/theme/new
let save : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
let themeFile = Seq.head ctx.Request.Form.Files
match getThemeName themeFile.FileName with
| Ok themeName when themeName <> "admin" ->
match deriveIdFromFileName themeFile.FileName with
| Ok themeId when themeId <> ThemeId "admin" ->
let data = ctx.Data
let! exists = data.Theme.Exists themeId
let isNew = not exists
let! model = ctx.BindFormAsync<UploadThemeModel>()
if isNew || model.DoOverwrite then
// Load the theme to the database
use stream = new MemoryStream()
do! themeFile.CopyToAsync stream
do! loadThemeFromZip themeName stream true data
do! ThemeAssetCache.refreshTheme (ThemeId themeName) data
TemplateCache.invalidateTheme themeName
do! addMessage ctx { UserMessage.success with Message = "Theme updated successfully" }
return! redirectToGet "admin/dashboard" next ctx
let! _ = loadFromZip themeId stream data
do! ThemeAssetCache.refreshTheme themeId data
TemplateCache.invalidateTheme themeId
// Ensure the themes directory exists
let themeDir = Path.Combine(".", "themes")
if not (Directory.Exists themeDir) then Directory.CreateDirectory themeDir |> ignore
// Save the .zip file
use file = new FileStream(Path.Combine(".", "themes", $"{themeId}-theme.zip"), FileMode.Create)
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! redirectToGet "admin/theme/update" 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! redirectToGet "admin/theme/update" next ctx
do! addMessage ctx { UserMessage.Error with Message = message }
return! toAdminDashboard next ctx
else return! RequestErrors.BAD_REQUEST "Bad request" next ctx
}
// -- WEB LOG SETTINGS --
// POST /admin/theme/{id}/delete
let delete themeId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let data = ctx.Data
match themeId with
| "admin" | "default" ->
do! addMessage ctx { UserMessage.Error with Message = $"You may not delete the {themeId} theme" }
return! all 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
}
open System.Collections.Generic
/// ~~~ WEB LOG SETTINGS ~~~
module WebLog =
open System.IO
// GET /admin/settings
let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let settings : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! allPages = data.Page.All ctx.WebLog.Id
let pages =
allPages
|> List.sortBy _.Title.ToLower()
|> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ]
let! themes = data.Theme.All()
let uploads = [ Database; Disk ]
return!
hashForPage "Web Log Settings"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (SettingsModel.fromWebLog ctx.WebLog)
|> addToHash "pages" (
seq {
KeyValuePair.Create ("posts", "- First Page of Posts -")
yield! allPages
|> List.sortBy (fun p -> p.Title.ToLower ())
|> List.map (fun p -> KeyValuePair.Create (PageId.toString p.Id, p.Title))
}
|> Array.ofSeq)
|> addToHash "themes" (
themes
|> Seq.ofList
|> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.Id, $"{it.Name} (v{it.Version})"))
|> Array.ofSeq)
|> addToHash "upload_values" [|
KeyValuePair.Create (UploadDestination.toString Database, "Database")
KeyValuePair.Create (UploadDestination.toString Disk, "Disk")
|]
|> adminView "settings" next ctx
Views.WebLog.webLogSettings
(SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss)
|> adminPage "Web Log Settings" true next ctx
}
// POST /admin/settings
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let saveSettings : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<SettingsModel>()
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let oldSlug = webLog.Slug
let webLog = model.update webLog
let webLog = model.Update webLog
do! data.WebLog.UpdateSettings webLog
// Update cache
@@ -337,7 +486,7 @@ let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
let oldDir = Path.Combine(uploadRoot, oldSlug)
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
| None -> return! Error.notFound next ctx
}

View File

@@ -2,7 +2,6 @@
module MyWebLog.Handlers.Feed
open System
open System.Collections.Generic
open System.IO
open System.Net
open System.ServiceModel.Syndication
@@ -37,19 +36,18 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
| false ->
// Category and tag feeds are handled by defined routes; check for custom feed
match webLog.Rss.CustomFeeds
|> List.tryFind (fun it -> feedPath.EndsWith (Permalink.toString it.Path)) with
|> List.tryFind (fun it -> feedPath.EndsWith(string it.Path)) with
| Some feed ->
debug (fun () -> "Found custom feed")
Some (Custom (feed, feedPath),
feed.Podcast |> Option.map (fun p -> p.ItemsInFeed) |> Option.defaultValue postCount)
Some(Custom(feed, feedPath), feed.Podcast |> Option.map _.ItemsInFeed |> Option.defaultValue postCount)
| None ->
debug (fun () -> $"No matching feed found")
debug (fun () -> "No matching feed found")
None
/// Determine the function to retrieve posts for the given feed
let private getFeedPosts ctx feedType =
let childIds catId =
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.Id = CategoryId.toString catId)
let childIds (catId: CategoryId) =
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.Id = string catId)
getCategoryIds cat.Slug ctx
let data = ctx.Data
match feedType with
@@ -87,16 +85,16 @@ module private Namespace =
let rawVoice = "http://www.rawvoice.com/rawvoiceRssModule/"
/// Create a feed item from the given post
let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (tagMaps : TagMap list)
let private toFeedItem (webLog: WebLog) (authors: MetaItem list) (cats: DisplayCategory array) (tagMaps: TagMap list)
(post: Post) =
let plainText =
let endingP = post.Text.IndexOf "</p>"
stripHtml <| if endingP >= 0 then post.Text[..(endingP - 1)] else post.Text
let item = SyndicationItem(
Id = WebLog.absoluteUrl webLog post.Permalink,
Id = webLog.AbsoluteUrl post.Permalink,
Title = TextSyndicationContent.CreateHtmlContent post.Title,
PublishDate = DateTimeOffset post.PublishedOn.Value,
LastUpdatedTime = DateTimeOffset post.UpdatedOn,
PublishDate = post.PublishedOn.Value.ToDateTimeOffset(),
LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset(),
Content = TextSyndicationContent.CreatePlaintextContent plainText)
item.AddPermalink (Uri item.Id)
@@ -112,38 +110,38 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[
it
item.ElementExtensions.Add encoded
item.Authors.Add (SyndicationPerson (
Name = (authors |> List.find (fun a -> a.Name = WebLogUserId.toString post.AuthorId)).Value))
item.Authors.Add(SyndicationPerson(Name = (authors |> List.find (fun a -> a.Name = string post.AuthorId)).Value))
[ post.CategoryIds
|> List.map (fun catId ->
let cat = cats |> Array.find (fun c -> c.Id = CategoryId.toString catId)
SyndicationCategory (cat.Name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.Slug}/"), cat.Name))
let cat = cats |> Array.find (fun c -> c.Id = string catId)
SyndicationCategory(cat.Name, webLog.AbsoluteUrl(Permalink $"category/{cat.Slug}/"), cat.Name))
post.Tags
|> List.map (fun tag ->
let urlTag =
match tagMaps |> List.tryFind (fun tm -> tm.Tag = tag) with
| Some tm -> tm.UrlValue
| None -> tag.Replace (" ", "+")
SyndicationCategory (tag, WebLog.absoluteUrl webLog (Permalink $"tag/{urlTag}/"), $"{tag} (tag)"))
SyndicationCategory(tag, webLog.AbsoluteUrl(Permalink $"tag/{urlTag}/"), $"{tag} (tag)"))
]
|> List.concat
|> List.iter item.Categories.Add
item
/// Convert non-absolute URLs to an absolute URL for this web log
let toAbsolute webLog (link : string) =
if link.StartsWith "http" then link else WebLog.absoluteUrl webLog (Permalink link)
let toAbsolute (webLog: WebLog) (link: string) =
if link.StartsWith "http" then link else webLog.AbsoluteUrl(Permalink link)
/// Add episode information to a podcast feed item
let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (post : Post) (item : SyndicationItem) =
let private addEpisode (webLog: WebLog) (podcast: PodcastOptions) (episode: Episode) (post: Post)
(item: SyndicationItem) =
let epMediaUrl =
match episode.Media with
| link when link.StartsWith "http" -> link
| link when Option.isSome podcast.MediaBaseUrl -> $"{podcast.MediaBaseUrl.Value}{link}"
| link -> WebLog.absoluteUrl webLog (Permalink link)
| link -> webLog.AbsoluteUrl(Permalink link)
let epMediaType = [ episode.MediaType; podcast.DefaultMediaType ] |> List.tryFind Option.isSome |> Option.flatten
let epImageUrl = defaultArg episode.ImageUrl (Permalink.toString podcast.ImageUrl) |> toAbsolute webLog
let epExplicit = defaultArg episode.Explicit podcast.Explicit |> ExplicitRating.toString
let epImageUrl = defaultArg episode.ImageUrl (string podcast.ImageUrl) |> toAbsolute webLog
let epExplicit = string (defaultArg episode.Explicit podcast.Explicit)
let xmlDoc = XmlDocument()
let enclosure =
@@ -163,20 +161,26 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
item.ElementExtensions.Add("author", Namespace.iTunes, podcast.DisplayedAuthor)
item.ElementExtensions.Add("explicit", Namespace.iTunes, epExplicit)
episode.Subtitle |> Option.iter (fun it -> item.ElementExtensions.Add("subtitle", Namespace.iTunes, it))
episode.Duration
|> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it.ToString """hh\:mm\:ss"""))
episode.FormatDuration() |> Option.iter (fun it -> item.ElementExtensions.Add("duration", Namespace.iTunes, it))
match episode.ChapterFile with
| Some chapters ->
let url = toAbsolute webLog chapters
let chapterUrl, chapterMimeType =
match episode.Chapters, episode.ChapterFile with
| Some _, _ ->
Some $"{webLog.AbsoluteUrl post.Permalink}?chapters", Some JSON_CHAPTERS
| None, Some chapters ->
let typ =
match episode.ChapterType with
| Some mime -> Some mime
| None when chapters.EndsWith ".json" -> Some "application/json+chapters"
| None when chapters.EndsWith ".json" -> Some JSON_CHAPTERS
| None -> None
Some (toAbsolute webLog chapters), typ
| None, None -> None, None
match chapterUrl with
| Some url ->
let elt = xmlDoc.CreateElement("podcast", "chapters", Namespace.podcast)
elt.SetAttribute("url", url)
typ |> Option.iter (fun it -> elt.SetAttribute ("type", it))
chapterMimeType |> Option.iter (fun it -> elt.SetAttribute("type", it))
item.ElementExtensions.Add elt
| None -> ()
@@ -187,8 +191,7 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
elt.SetAttribute("url", url)
elt.SetAttribute("type", Option.get episode.TranscriptType)
episode.TranscriptLang |> Option.iter (fun it -> elt.SetAttribute("language", it))
if defaultArg episode.TranscriptCaptions false then
elt.SetAttribute ("rel", "captions")
if defaultArg episode.TranscriptCaptions false then elt.SetAttribute("rel", "captions")
item.ElementExtensions.Add elt
| None -> ()
@@ -221,8 +224,7 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
post.Metadata
|> List.filter (fun it -> it.Name = "chapter")
|> List.map (fun it ->
TimeSpan.Parse (it.Value.Split(" ")[0]), it.Value.Substring (it.Value.IndexOf(" ") + 1))
|> List.map (fun it -> TimeSpan.Parse(it.Value.Split(" ")[0]), it.Value[it.Value.IndexOf(" ") + 1..])
|> List.sortBy fst
|> List.iter (fun chap ->
let chapter = xmlDoc.CreateElement("psc", "chapter", Namespace.psc)
@@ -239,7 +241,7 @@ let private addNamespace (feed : SyndicationFeed) alias nsUrl =
feed.AttributeExtensions.Add(XmlQualifiedName(alias, "http://www.w3.org/2000/xmlns/"), nsUrl)
/// Add items to the top of the feed required for podcasts
let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
let private addPodcast (webLog: WebLog) (rssFeed: SyndicationFeed) (feed: CustomFeed) =
let addChild (doc: XmlDocument) ns prefix name value (elt: XmlElement) =
let child =
if ns = "" then doc.CreateElement name else doc.CreateElement(prefix, name, ns)
@@ -248,11 +250,11 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
elt
let podcast = Option.get feed.Podcast
let feedUrl = WebLog.absoluteUrl webLog feed.Path
let feedUrl = webLog.AbsoluteUrl feed.Path
let imageUrl =
match podcast.ImageUrl with
| Permalink link when link.StartsWith "http" -> link
| Permalink _ -> WebLog.absoluteUrl webLog podcast.ImageUrl
| Permalink _ -> webLog.AbsoluteUrl podcast.ImageUrl
let xmlDoc = XmlDocument()
@@ -302,7 +304,7 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
rssFeed.ElementExtensions.Add rawVoice
rssFeed.ElementExtensions.Add("summary", Namespace.iTunes, podcast.Summary)
rssFeed.ElementExtensions.Add("author", Namespace.iTunes, podcast.DisplayedAuthor)
rssFeed.ElementExtensions.Add ("explicit", Namespace.iTunes, ExplicitRating.toString podcast.Explicit)
rssFeed.ElementExtensions.Add("explicit", Namespace.iTunes, string podcast.Explicit)
podcast.Subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add("subtitle", Namespace.iTunes, sub))
podcast.FundingUrl
|> Option.iter (fun url ->
@@ -313,8 +315,7 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
podcast.PodcastGuid
|> Option.iter (fun guid ->
rssFeed.ElementExtensions.Add("guid", Namespace.podcast, guid.ToString().ToLowerInvariant()))
podcast.Medium
|> Option.iter (fun med -> rssFeed.ElementExtensions.Add ("medium", Namespace.podcast, PodcastMedium.toString med))
podcast.Medium |> Option.iter (fun med -> rssFeed.ElementExtensions.Add("medium", Namespace.podcast, string med))
/// Get the feed's self reference and non-feed link
let private selfAndLink webLog feedType ctx =
@@ -373,7 +374,7 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
match podcast, post.Episode with
| Some feed, Some episode -> addEpisode webLog (Option.get feed.Podcast) episode post item
| Some _, _ ->
warn "Feed" ctx $"[{webLog.Name} {Permalink.toString self}] \"{stripHtml post.Title}\" has no media"
warn "Feed" ctx $"[{webLog.Name} {self}] \"{stripHtml post.Title}\" has no media"
item
| _ -> item
@@ -381,15 +382,15 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
addNamespace feed "content" Namespace.content
setTitleAndDescription feedType webLog cats feed
feed.LastUpdatedTime <- (List.head posts).UpdatedOn |> DateTimeOffset
feed.LastUpdatedTime <- (List.head posts).UpdatedOn.ToDateTimeOffset()
feed.Generator <- ctx.Generator
feed.Items <- posts |> Seq.ofList |> Seq.map toItem
feed.Language <- "en"
feed.Id <- WebLog.absoluteUrl webLog link
feed.Id <- webLog.AbsoluteUrl link
webLog.Rss.Copyright |> Option.iter (fun copy -> feed.Copyright <- TextSyndicationContent copy)
feed.Links.Add (SyndicationLink (Uri (WebLog.absoluteUrl webLog self), "self", "", "application/rss+xml", 0L))
feed.ElementExtensions.Add ("link", "", WebLog.absoluteUrl webLog link)
feed.Links.Add(SyndicationLink(Uri(webLog.AbsoluteUrl self), "self", "", "application/rss+xml", 0L))
feed.ElementExtensions.Add("link", "", webLog.AbsoluteUrl link)
podcast |> Option.iter (addPodcast webLog feed)
@@ -414,17 +415,6 @@ let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> bac
// ~~ FEED ADMINISTRATION ~~
// GET /admin/settings/rss
let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
hashForPage "RSS Settings"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditRssModel.fromRssOptions ctx.WebLog.Rss)
|> addToHash "custom_feeds" (
ctx.WebLog.Rss.CustomFeeds
|> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx))
|> Array.ofList)
|> adminView "rss-settings" next ctx
// POST /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
@@ -434,8 +424,8 @@ let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with Message = "RSS settings updated successfully" }
return! redirectToGet "admin/settings/rss" next ctx
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
}
@@ -443,24 +433,27 @@ let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let customFeed =
match feedId with
| "new" -> Some { CustomFeed.empty with Id = CustomFeedId "new" }
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId "new" }
| _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId)
match customFeed with
| Some f ->
hashForPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed"""
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditCustomFeedModel.fromFeed f)
|> addToHash "medium_values" [|
KeyValuePair.Create ("", "&ndash; Unspecified &ndash;")
KeyValuePair.Create (PodcastMedium.toString Podcast, "Podcast")
KeyValuePair.Create (PodcastMedium.toString Music, "Music")
KeyValuePair.Create (PodcastMedium.toString Video, "Video")
KeyValuePair.Create (PodcastMedium.toString Film, "Film")
KeyValuePair.Create (PodcastMedium.toString Audiobook, "Audiobook")
KeyValuePair.Create (PodcastMedium.toString Newsletter, "Newsletter")
KeyValuePair.Create (PodcastMedium.toString Blog, "Blog")
|]
|> adminView "custom-feed-edit" next ctx
let ratings = [
{ Name = string Yes; Value = "Yes" }
{ Name = string No; Value = "No" }
{ Name = string Clean; Value = "Clean" }
]
let mediums = [
{ Name = ""; Value = "&ndash; Unspecified &ndash;" }
{ Name = string Podcast; Value = "Podcast" }
{ Name = string Music; Value = "Music" }
{ Name = string Video; Value = "Video" }
{ Name = string Film; Value = "Film" }
{ Name = string Audiobook; Value = "Audiobook" }
{ Name = string Newsletter; Value = "Newsletter" }
{ Name = string Blog; Value = "Blog" }
]
Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums
|> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" true next ctx
| None -> Error.notFound next ctx
// POST /admin/settings/rss/save
@@ -471,42 +464,39 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let! model = ctx.BindFormAsync<EditCustomFeedModel>()
let theFeed =
match model.Id with
| "new" -> Some { CustomFeed.empty with Id = CustomFeedId.create () }
| _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> CustomFeedId.toString it.Id = model.Id)
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() }
| _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> string it.Id = model.Id)
match theFeed with
| Some feed ->
let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun it -> it.Id <> feed.Id))
let webLog = { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } }
let webLog = { webLog with Rss.CustomFeeds = feeds }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx {
UserMessage.success with
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed"""
}
return! redirectToGet $"admin/settings/rss/{CustomFeedId.toString 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
}
// POST /admin/settings/rss/{id}/delete
// DELETE /admin/settings/rss/{id}
let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let customId = CustomFeedId feedId
if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then
let webLog = {
webLog with
Rss = {
webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId)
}
}
let webLog =
{ webLog with
Rss =
{ webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with Message = "Custom feed deleted successfully" }
do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" }
else
do! addMessage ctx { UserMessage.warning with Message = "Custom feed not found; no action taken" }
return! redirectToGet "admin/settings/rss" 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
}

View File

@@ -3,6 +3,7 @@ module private MyWebLog.Handlers.Helpers
open System.Text.Json
open Microsoft.AspNetCore.Http
open MyWebLog.Views
/// Session extensions to get and set objects
type ISession with
@@ -25,6 +26,10 @@ module ViewContext =
[<Literal>]
let AntiCsrfTokens = "csrf"
/// The unified application view context
[<Literal>]
let AppViewContext = "app"
/// The categories for this web log
[<Literal>]
let Categories = "categories"
@@ -122,7 +127,6 @@ module ViewContext =
let WebLog = "web_log"
/// The HTTP item key for loading the session
let private sessionLoadedKey = "session-loaded"
@@ -174,10 +178,6 @@ let addToHash key (value : obj) (hash : Hash) =
if hash.ContainsKey key then hash[key] <- value else hash.Add(key, value)
hash
/// Add anti-CSRF tokens to the given hash
let withAntiCsrf (ctx : HttpContext) =
addToHash ViewContext.AntiCsrfTokens ctx.CsrfTokenSet
open System.Security.Claims
open Giraffe
open Giraffe.Htmx
@@ -186,55 +186,68 @@ open Giraffe.ViewEngine
/// htmx script tag
let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified
/// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash : Hash) = task {
/// Get the current user messages, and commit the session so that they are preserved
let private getCurrentMessages ctx = task {
let! messages = messages ctx
do! commitSession ctx
return
if hash.ContainsKey ViewContext.HtmxScript && hash.ContainsKey ViewContext.Messages then
// We have already populated everything; just update messages
hash[ViewContext.Messages] <- Array.concat [ hash[ViewContext.Messages] :?> UserMessage[]; messages ]
hash
else
ctx.User.Claims
return messages
}
/// Generate the view context for a response
let private generateViewContext pageTitle messages includeCsrf (ctx: HttpContext) =
{ WebLog = ctx.WebLog
UserId = ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> addToHash ViewContext.UserId claim.Value hash)
|> Option.defaultValue hash
|> addToHash ViewContext.WebLog ctx.WebLog
|> addToHash ViewContext.PageList (PageListCache.get ctx)
|> addToHash ViewContext.Categories (CategoryCache.get ctx)
|> addToHash ViewContext.CurrentPage ctx.Request.Path.Value[1..]
|> addToHash ViewContext.Messages messages
|> addToHash ViewContext.Generator ctx.Generator
|> addToHash ViewContext.HtmxScript htmxScript
|> addToHash ViewContext.IsLoggedOn ctx.User.Identity.IsAuthenticated
|> addToHash ViewContext.IsAuthor (ctx.HasAccessLevel Author)
|> addToHash ViewContext.IsEditor (ctx.HasAccessLevel Editor)
|> addToHash ViewContext.IsWebLogAdmin (ctx.HasAccessLevel WebLogAdmin)
|> addToHash ViewContext.IsAdministrator (ctx.HasAccessLevel Administrator)
|> Option.map (fun claim -> WebLogUserId claim.Value)
PageTitle = pageTitle
Csrf = if includeCsrf then Some ctx.CsrfTokenSet else None
PageList = PageListCache.get ctx
Categories = CategoryCache.get ctx
CurrentPage = ctx.Request.Path.Value[1..]
Messages = messages
Generator = ctx.Generator
HtmxScript = htmxScript
IsAuthor = ctx.HasAccessLevel Author
IsEditor = ctx.HasAccessLevel Editor
IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin
IsAdministrator = ctx.HasAccessLevel Administrator }
/// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash: Hash) = task {
let! messages = getCurrentMessages ctx
if hash.ContainsKey ViewContext.AppViewContext then
let oldApp = hash[ViewContext.AppViewContext] :?> AppViewContext
let newApp = { oldApp with Messages = Array.concat [ oldApp.Messages; messages ] }
return
hash
|> addToHash ViewContext.AppViewContext newApp
|> addToHash ViewContext.Messages newApp.Messages
else
let app =
generateViewContext (string hash[ViewContext.PageTitle]) messages
(hash.ContainsKey ViewContext.AntiCsrfTokens) ctx
return
hash
|> addToHash ViewContext.UserId (app.UserId |> Option.map string |> Option.defaultValue "")
|> addToHash ViewContext.WebLog app.WebLog
|> addToHash ViewContext.PageList app.PageList
|> addToHash ViewContext.Categories app.Categories
|> addToHash ViewContext.CurrentPage app.CurrentPage
|> addToHash ViewContext.Messages app.Messages
|> addToHash ViewContext.Generator app.Generator
|> addToHash ViewContext.HtmxScript app.HtmxScript
|> addToHash ViewContext.IsLoggedOn app.IsLoggedOn
|> addToHash ViewContext.IsAuthor app.IsAuthor
|> addToHash ViewContext.IsEditor app.IsEditor
|> addToHash ViewContext.IsWebLogAdmin app.IsWebLogAdmin
|> addToHash ViewContext.IsAdministrator app.IsAdministrator
}
/// Is the request from htmx?
let isHtmx (ctx: HttpContext) =
ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme themeId template next ctx (hash : Hash) = task {
let! hash = addViewContext ctx hash
let (ThemeId theme) = themeId
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
// the net effect is a "layout" capability similar to Razor or Pug
// Render view content...
let! contentTemplate = TemplateCache.get theme template ctx.Data
let _ = addToHash ViewContext.Content (contentTemplate.Render hash) hash
// ...then render that content with its layout
let! layoutTemplate = TemplateCache.get theme (if isHtmx ctx then "layout-partial" else "layout") ctx.Data
return! htmlString (layoutTemplate.Render hash) next ctx
}
/// Convert messages to headers (used for htmx responses)
let messagesToHeaders (messages: UserMessage array) : HttpHandler =
seq {
@@ -249,49 +262,14 @@ let messagesToHeaders (messages : UserMessage array) : HttpHandler =
}
|> Seq.reduce (>=>)
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme themeId template next ctx (hash : Hash) = task {
let! hash = addViewContext ctx hash
let (ThemeId theme) = themeId
if not (hash.ContainsKey ViewContext.Content) then
let! contentTemplate = TemplateCache.get theme template ctx.Data
addToHash ViewContext.Content (contentTemplate.Render hash) hash |> ignore
// Bare templates are rendered with layout-bare
let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Data
return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[])
>=> htmlString (layoutTemplate.Render hash))
next ctx
}
/// Return a view for the web log's default theme
let themedView template next ctx hash = task {
let! hash = addViewContext ctx hash
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
}
/// Display a view for the admin theme
let adminView template =
viewForTheme (ThemeId "admin") template
/// Display a bare view for the admin theme
let adminBareView template =
bareForTheme (ThemeId "admin") template
/// Redirect after doing some action; commits session and issues a temporary redirect
let redirectToGet url : HttpHandler = fun _ ctx -> task {
do! commitSession ctx
return! redirectTo false (WebLog.relativeUrl ctx.WebLog (Permalink url)) earlyReturn ctx
return! redirectTo false (ctx.WebLog.RelativeUrl(Permalink url)) earlyReturn ctx
}
/// Validate the anti cross-site request forgery token in the current request
let validateCsrf : HttpHandler = fun next ctx -> task {
match! ctx.AntiForgery.IsRequestValidAsync ctx with
| true -> return! next ctx
| false -> return! RequestErrors.BAD_REQUEST "CSRF token invalid" earlyReturn ctx
}
/// The MIME type for podcast episode JSON chapters
let JSON_CHAPTERS = "application/json+chapters"
/// Handlers for error conditions
@@ -303,29 +281,106 @@ module Error =
let notAuthorized : HttpHandler = fun next ctx ->
if ctx.Request.Method = "GET" then
let redirectUrl = $"user/log-on?returnUrl={WebUtility.UrlEncode ctx.Request.Path}"
if isHtmx ctx then (withHxRedirect redirectUrl >=> redirectToGet redirectUrl) next ctx
else redirectToGet redirectUrl next ctx
(next, ctx)
||> if isHtmx ctx then withHxRedirect redirectUrl >=> withHxRetarget "body" >=> redirectToGet redirectUrl
else redirectToGet redirectUrl
else
if isHtmx ctx then
let messages = [|
{ UserMessage.error with
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}"
}
{ UserMessage.Error with
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" }
|]
(messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx
else setStatusCode 401 earlyReturn ctx
/// Handle 404s from the API, sending known URL paths to the Vue app so that they can be handled there
/// Handle 404s
let notFound : HttpHandler =
handleContext (fun ctx ->
if isHtmx ctx then
let messages = [|
{ UserMessage.error with Message = $"The URL {ctx.Request.Path.Value} was not found" }
{ UserMessage.Error with Message = $"The URL {ctx.Request.Path.Value} was not found" }
|]
(messagesToHeaders messages >=> setStatusCode 404) earlyReturn ctx
else
(setStatusCode 404 >=> text "Not found") earlyReturn ctx)
RequestErrors.notFound (messagesToHeaders messages) earlyReturn ctx
else RequestErrors.NOT_FOUND "Not found" earlyReturn ctx)
let server message : HttpHandler =
handleContext (fun ctx ->
if isHtmx ctx then
let messages = [| { UserMessage.Error with Message = message } |]
ServerErrors.internalError (messagesToHeaders messages) earlyReturn ctx
else ServerErrors.INTERNAL_ERROR message earlyReturn ctx)
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
// the net effect is a "layout" capability similar to Razor or Pug
// Render view content...
match! TemplateCache.get themeId template ctx.Data with
| Ok contentTemplate ->
let _ = addToHash ViewContext.Content (contentTemplate.Render hash) hash
// ...then render that content with its layout
match! TemplateCache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with
| Ok layoutTemplate -> return! htmlString (layoutTemplate.Render hash) next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
}
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
let withContent = task {
if hash.ContainsKey ViewContext.Content then return Ok hash
else
match! TemplateCache.get themeId template ctx.Data with
| Ok contentTemplate -> return Ok(addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Error message -> return Error message
}
match! withContent with
| Ok completeHash ->
// Bare templates are rendered with layout-bare
match! TemplateCache.get themeId "layout-bare" ctx.Data with
| Ok layoutTemplate ->
return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array)
>=> htmlString (layoutTemplate.Render completeHash))
next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
}
/// Return a view for the web log's default theme
let themedView template next ctx hash = task {
let! hash = addViewContext ctx hash
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
}
/// Display a page for an admin endpoint
let adminPage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
let layout = if isHtmx ctx then Layout.partial else Layout.full
return! htmlString (layout content appCtx |> RenderView.AsString.htmlDocument) next ctx
}
/// Display a bare page for an admin endpoint
let adminBarePage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
return!
( messagesToHeaders appCtx.Messages
>=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx
}
/// Validate the anti cross-site request forgery token in the current request
let validateCsrf : HttpHandler = fun next ctx -> task {
match! ctx.AntiForgery.IsRequestValidAsync ctx with
| true -> return! next ctx
| false -> return! RequestErrors.BAD_REQUEST "CSRF token invalid" earlyReturn ctx
}
/// Require a user to be logged on
let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized
@@ -333,17 +388,16 @@ let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized
/// Require a specific level of access for a route
let requireAccess level : HttpHandler = fun next ctx -> task {
match ctx.UserAccessLevel with
| Some userLevel when AccessLevel.hasAccess level userLevel -> return! next ctx
| Some userLevel when userLevel.HasAccess level -> return! next ctx
| Some userLevel ->
do! addMessage ctx
{ UserMessage.warning with
Message = $"The page you tried to access requires {AccessLevel.toString level} privileges"
Detail = Some $"Your account only has {AccessLevel.toString userLevel} privileges"
}
{ UserMessage.Warning with
Message = $"The page you tried to access requires {level} privileges"
Detail = Some $"Your account only has {userLevel} privileges" }
return! Error.notAuthorized next ctx
| None ->
do! addMessage ctx
{ UserMessage.warning with Message = "The page you tried to access required you to be logged on" }
{ UserMessage.Warning with Message = "The page you tried to access required you to be logged on" }
return! Error.notAuthorized next ctx
}
@@ -356,36 +410,39 @@ open System.Threading.Tasks
/// Create a Task with a Some result for the given object
let someTask<'T> (it: 'T) = Task.FromResult(Some it)
open System.Collections.Generic
/// Create an absolute URL from a string that may already be an absolute URL
let absoluteUrl (url: string) (ctx: HttpContext) =
if url.StartsWith "http" then url else ctx.WebLog.AbsoluteUrl(Permalink url)
open MyWebLog.Data
/// Get the templates available for the current web log's theme (in a key/value pair list)
/// Get the templates available for the current web log's theme (in a meta item list)
let templatesForTheme (ctx: HttpContext) (typ: string) = backgroundTask {
match! ctx.Data.Theme.FindByIdWithoutText ctx.WebLog.ThemeId with
| Some theme ->
return seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
{ Name = ""; Value = $"- Default (single-{typ}) -" }
yield!
theme.Templates
|> Seq.ofList
|> Seq.filter (fun it -> it.Name.EndsWith $"-{typ}" && it.Name <> $"single-{typ}")
|> Seq.map (fun it -> KeyValuePair.Create (it.Name, it.Name))
|> Seq.map (fun it -> { Name = it.Name; Value = it.Name })
}
|> Array.ofSeq
| None -> return [| KeyValuePair.Create ("", $"- Default (single-{typ}) -") |]
| None -> return seq { { Name = ""; Value = $"- Default (single-{typ}) -" } }
}
/// Get all authors for a list of posts as metadata items
let getAuthors (webLog: WebLog) (posts: Post list) (data: IData) =
posts
|> List.map (fun p -> p.AuthorId)
|> List.map _.AuthorId
|> List.distinct
|> data.WebLogUser.FindNames webLog.Id
/// Get all tag mappings for a list of posts as metadata items
let getTagMappings (webLog: WebLog) (posts: Post list) (data: IData) =
posts
|> List.map (fun p -> p.Tags)
|> List.map _.Tags
|> List.concat
|> List.distinct
|> fun tags -> data.TagMap.FindMappingForTags tags webLog.Id
@@ -401,12 +458,12 @@ let getCategoryIds slug ctx =
|> Seq.map (fun c -> CategoryId c.Id)
|> List.ofSeq
open System
open System.Globalization
open NodaTime
/// Parse a date/time to UTC
let parseToUtc (date : string) =
DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal)
let parseToUtc (date: string) : Instant =
let result = roundTrip.Parse date
if result.Success then result.Value else raise result.Exception
open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Logging
@@ -436,4 +493,3 @@ let warn (name : string) (ctx : HttpContext) msg =
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
log.LogWarning msg

View File

@@ -9,21 +9,22 @@ open MyWebLog.ViewModels
// GET /admin/pages/page/{pageNbr}
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr
let displayPages =
pages
|> Seq.ofList
|> Seq.truncate 25
|> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog)
|> List.ofSeq
return!
hashForPage "Pages"
|> withAntiCsrf ctx
|> addToHash "pages" (pages |> List.map (DisplayPage.fromPageMinimal ctx.WebLog))
|> addToHash "page_nbr" pageNbr
|> addToHash "prev_page" (if pageNbr = 2 then "" else $"/page/{pageNbr - 1}")
|> addToHash "next_page" $"/page/{pageNbr + 1}"
|> adminView "page-list" next ctx
Views.Page.pageList displayPages pageNbr (pages.Length > 25)
|> adminPage "Pages" true next ctx
}
// GET /admin/page/{id}/edit
let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! result = task {
match pgId with
| "new" -> return Some ("Add a New Page", { Page.empty with Id = PageId "new"; AuthorId = ctx.UserId })
| "new" -> return Some ("Add a New Page", { Page.Empty with Id = PageId "new"; AuthorId = ctx.UserId })
| _ ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some page -> return Some ("Edit Page", page)
@@ -31,29 +32,21 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
}
match result with
| Some (title, page) when canEdit page.AuthorId ctx ->
let model = EditPageModel.fromPage page
let model = EditPageModel.FromPage page
let! templates = templatesForTheme ctx "page"
return!
hashForPage title
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> addToHash "metadata" (
Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]))
|> addToHash "templates" templates
|> adminView "page-edit" next ctx
return! adminPage title true next ctx (Views.Page.pageEdit model templates)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/delete
// DELETE /admin/page/{id}
let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Page.Delete (PageId pgId) ctx.WebLog.Id with
| true ->
do! PageListCache.update 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! redirectToGet "admin/pages" 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
@@ -61,10 +54,9 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
return!
hashForPage "Manage Prior Permalinks"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManagePermalinksModel.fromPage pg)
|> adminView "permalinks" next ctx
ManagePermalinksModel.FromPage pg
|> Views.Helpers.managePermalinks
|> adminPage "Manage Prior Permalinks" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -78,7 +70,7 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task
let links = model.Prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.Id links with
| true ->
do! addMessage ctx { UserMessage.success with Message = "Page permalinks saved successfully" }
do! addMessage ctx { UserMessage.Success with Message = "Page permalinks saved successfully" }
return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx
| false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
@@ -90,22 +82,21 @@ let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
return!
hashForPage "Manage Page Revisions"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManageRevisionsModel.fromPage ctx.WebLog pg)
|> adminView "revisions" next ctx
ManageRevisionsModel.FromPage pg
|> Views.Helpers.manageRevisions
|> adminPage "Manage Page Revisions" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/page/{id}/revisions/purge
// DELETE /admin/page/{id}/revisions
let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg ->
do! data.Page.Update { pg with Revisions = [ List.head pg.Revisions ] }
do! addMessage ctx { UserMessage.success with Message = "Prior revisions purged successfully" }
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" }
return! editRevisions pgId next ctx
| None -> return! Error.notFound next ctx
}
@@ -124,40 +115,33 @@ let private findPageRevision pgId revDate (ctx : HttpContext) = task {
let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
return! {|
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>"""
|}
|> makeHash |> adminBareView "" next ctx
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev)
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
open System
// POST /admin/page/{id}/revision/{revision-date}/restore
let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
do! ctx.Data.Page.Update
{ pg with
Revisions = { rev with AsOf = DateTime.UtcNow }
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
Revisions = { rev with AsOf = Noda.now () }
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/revision/{revision-date}/delete
// DELETE /admin/page/{id}/revision/{revision-date}
let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" }
return! adminBareView "" next ctx (makeHash {| content = "" |})
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
return! adminBarePage "" false next ctx (fun _ -> [])
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
@@ -167,24 +151,24 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel>()
let data = ctx.Data
let now = DateTime.UtcNow
let now = Noda.now ()
let tryPage =
if model.IsNew then
{ Page.empty with
Id = PageId.create ()
{ Page.Empty with
Id = PageId.Create()
WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId
PublishedOn = now
} |> someTask
else data.Page.FindFullById (PageId model.PageId) ctx.WebLog.Id
else data.Page.FindFullById (PageId model.Id) ctx.WebLog.Id
match! tryPage with
| Some page when canEdit page.AuthorId ctx ->
let updateList = page.IsInPageList <> model.IsShownInPageList
let updatedPage = model.UpdatePage page now
do! (if model.IsNew then data.Page.Add else data.Page.Update) updatedPage
if updateList then do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Page saved successfully" }
return! redirectToGet $"admin/page/{PageId.toString page.Id}/edit" 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
}

View File

@@ -27,6 +27,7 @@ let private parseSlugAndPage webLog (slugAndPage : string seq) =
pageNbr, String.Join("/", slugParts), isFeed
/// The type of post list being prepared
[<Struct>]
type ListType =
| AdminList
| CategoryList
@@ -42,23 +43,23 @@ open MyWebLog.ViewModels
let preparePostList webLog posts listType (url: string) pageNbr perPage (data: IData) = task {
let! authors = getAuthors webLog posts data
let! tagMappings = getTagMappings webLog posts data
let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it)
let relUrl it = Some <| webLog.RelativeUrl(Permalink it)
let postItems =
posts
|> Seq.ofList
|> Seq.truncate perPage
|> Seq.map (PostListItem.fromPost webLog)
|> Seq.map (PostListItem.FromPost webLog)
|> Array.ofSeq
let! olderPost, newerPost =
match listType with
| SinglePost ->
let post = List.head posts
let dateTime = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id dateTime
let target = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id target
| _ -> Task.FromResult(None, None)
let newerLink =
match listType, pageNbr with
| SinglePost, _ -> newerPost |> Option.map (fun p -> Permalink.toString p.Permalink)
| SinglePost, _ -> newerPost |> Option.map (fun it -> string it.Permalink)
| _, 1 -> None
| PostList, 2 when webLog.DefaultPage = "posts" -> Some ""
| PostList, _ -> relUrl $"page/{pageNbr - 1}"
@@ -70,7 +71,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data :
| AdminList, _ -> relUrl $"admin/posts/page/{pageNbr - 1}"
let olderLink =
match listType, List.length posts > perPage with
| SinglePost, _ -> olderPost |> Option.map (fun p -> Permalink.toString p.Permalink)
| SinglePost, _ -> olderPost |> Option.map (fun it -> string it.Permalink)
| _, false -> None
| PostList, true -> relUrl $"page/{pageNbr + 1}"
| CategoryList, true -> relUrl $"category/{url}/page/{pageNbr + 1}"
@@ -81,9 +82,9 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data :
Authors = authors
Subtitle = None
NewerLink = newerLink
NewerName = newerPost |> Option.map (fun p -> p.Title)
NewerName = newerPost |> Option.map _.Title
OlderLink = olderLink
OlderName = olderPost |> Option.map (fun p -> p.Title)
OlderName = olderPost |> Option.map _.Title
}
return
makeHash {||}
@@ -115,7 +116,7 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
// GET /page/{pageNbr}/
let redirectToPageOfPosts (pageNbr: int) : HttpHandler = fun next ctx ->
redirectTo true (WebLog.relativeUrl ctx.WebLog (Permalink $"page/{pageNbr}")) next ctx
redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx
// GET /category/{slug}/
// GET /category/{slug}/page/{pageNbr}
@@ -184,7 +185,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}"
return!
redirectTo true
(WebLog.relativeUrl webLog (Permalink $"""tag/{spacedTag.Replace (" ", "+")}/{endUrl}"""))
(webLog.RelativeUrl(Permalink $"""tag/{spacedTag.Replace (" ", "+")}/{endUrl}"""))
next ctx
| _ -> return! Error.notFound next ctx
| None, _, _ -> return! Error.notFound next ctx
@@ -200,22 +201,60 @@ let home : HttpHandler = fun next ctx -> task {
| Some page ->
return!
hashForPage page.Title
|> addToHash "page" (DisplayPage.fromPage webLog page)
|> addToHash "page" (DisplayPage.FromPage webLog page)
|> addToHash ViewContext.IsHome true
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> return! Error.notFound next ctx
}
// GET /{post-permalink}?chapters
let chapters (post: Post) : HttpHandler = fun next ctx ->
match post.Episode with
| Some ep ->
match ep.Chapters with
| Some chapters ->
let chapterData =
chapters
|> Seq.ofList
|> Seq.map (fun it ->
let dic = Dictionary<string, obj>()
dic["startTime"] <- Math.Round(it.StartTime.TotalSeconds, 2)
it.Title |> Option.iter (fun ttl -> dic["title"] <- ttl)
it.ImageUrl |> Option.iter (fun img -> dic["img"] <- absoluteUrl img ctx)
it.Url |> Option.iter (fun url -> dic["url"] <- absoluteUrl url ctx)
it.IsHidden |> Option.iter (fun toc -> dic["toc"] <- not toc)
it.EndTime |> Option.iter (fun ent -> dic["endTime"] <- Math.Round(ent.TotalSeconds, 2))
it.Location |> Option.iter (fun loc ->
let locData = Dictionary<string, obj>()
locData["name"] <- loc.Name
locData["geo"] <- loc.Geo
loc.Osm |> Option.iter (fun osm -> locData["osm"] <- osm)
dic["location"] <- locData)
dic)
|> ResizeArray
let jsonFile = Dictionary<string, obj>()
jsonFile["version"] <- "1.2.0"
jsonFile["title"] <- post.Title
jsonFile["fileName"] <- absoluteUrl ep.Media ctx
if defaultArg ep.ChapterWaypoints false then jsonFile["waypoints"] <- true
jsonFile["chapters"] <- chapterData
(setContentType JSON_CHAPTERS >=> json jsonFile) next ctx
| None ->
match ep.ChapterFile with
| Some file -> redirectTo true file next ctx
| None -> Error.notFound next ctx
| None -> Error.notFound next ctx
// ~~ ADMINISTRATION ~~
// GET /admin/posts
// GET /admin/posts/page/{pageNbr}
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25
let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data
return!
addToHash ViewContext.PageTitle "Posts" hash
|> withAntiCsrf ctx
|> adminView "post-list" next ctx
return! adminPage "Posts" true next ctx (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay))
}
// GET /admin/post/{id}/edit
@@ -223,7 +262,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
let! result = task {
match postId with
| "new" -> return Some ("Write a New Post", { Post.empty with Id = PostId "new" })
| "new" -> return Some ("Write a New Post", { Post.Empty with Id = PostId "new" })
| _ ->
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post -> return Some ("Edit Post", post)
@@ -232,32 +271,25 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match result with
| Some (title, post) when canEdit post.AuthorId ctx ->
let! templates = templatesForTheme ctx "post"
let model = EditPostModel.fromPost ctx.WebLog post
return!
hashForPage title
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> addToHash "metadata" (
Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]))
|> addToHash "templates" templates
|> addToHash "explicit_values" [|
KeyValuePair.Create ("", "&ndash; Default &ndash;")
KeyValuePair.Create (ExplicitRating.toString Yes, "Yes")
KeyValuePair.Create (ExplicitRating.toString No, "No")
KeyValuePair.Create (ExplicitRating.toString Clean, "Clean")
|]
|> adminView "post-edit" next ctx
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
}
// POST /admin/post/{id}/delete
// DELETE /admin/post/{id}
let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Post.Delete (PostId postId) ctx.WebLog.Id with
| true -> do! addMessage ctx { UserMessage.success with Message = "Post deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Post not found; nothing deleted" }
return! redirectToGet "admin/posts" next ctx
| true -> do! addMessage ctx { UserMessage.Success with Message = "Post deleted successfully" }
| false -> do! addMessage ctx { UserMessage.Error with Message = "Post not found; nothing deleted" }
//return! redirectToGet "admin/posts" next ctx
return! all 1 next ctx
}
// GET /admin/post/{id}/permalinks
@@ -265,10 +297,9 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
return!
hashForPage "Manage Prior Permalinks"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManagePermalinksModel.fromPost post)
|> adminView "permalinks" next ctx
ManagePermalinksModel.FromPost post
|> Views.Helpers.managePermalinks
|> adminPage "Manage Prior Permalinks" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -282,7 +313,7 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task
let links = model.Prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.Id links with
| true ->
do! addMessage ctx { UserMessage.success with Message = "Post permalinks saved successfully" }
do! addMessage ctx { UserMessage.Success with Message = "Post permalinks saved successfully" }
return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx
| false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
@@ -294,22 +325,21 @@ let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
return!
hashForPage "Manage Post Revisions"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManageRevisionsModel.fromPost ctx.WebLog post)
|> adminView "revisions" next ctx
ManageRevisionsModel.FromPost post
|> Views.Helpers.manageRevisions
|> adminPage "Manage Post Revisions" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/revisions/purge
// DELETE /admin/post/{id}/revisions
let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
do! data.Post.Update { post with Revisions = [ List.head post.Revisions ] }
do! addMessage ctx { UserMessage.success with Message = "Prior revisions purged successfully" }
return! redirectToGet $"admin/post/{postId}/revisions" next ctx
do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" }
return! editRevisions postId next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -329,13 +359,9 @@ let private findPostRevision postId revDate (ctx : HttpContext) = task {
let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.AuthorId ctx ->
return! {|
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>"""
|}
|> makeHash |> adminBareView "" next ctx
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev)
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/revision/{revision-date}/restore
@@ -344,46 +370,130 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
| Some post, Some rev when canEdit post.AuthorId ctx ->
do! ctx.Data.Post.Update
{ post with
Revisions = { rev with AsOf = DateTime.UtcNow }
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
Revisions = { rev with AsOf = Noda.now () }
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/post/{postId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/revision/{revision-date}/delete
// DELETE /admin/post/{id}/revision/{revision-date}
let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.AuthorId ctx ->
do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" }
return! adminBareView "" next ctx (makeHash {| content = "" |})
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
return! adminBarePage "" false next ctx (fun _ -> [])
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/chapters
let manageChapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
return!
Views.Post.chapters false (ManageChaptersModel.Create post)
|> adminPage "Manage Chapters" true next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/chapter/{idx}
let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
let chapter =
if index = -1 then Some Chapter.Empty
else
let chapters = post.Episode.Value.Chapters.Value
if index < List.length chapters then Some chapters[index] else None
match chapter with
| Some chap ->
return!
Views.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)
|> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") true next ctx
| None -> return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/chapter/{idx}
let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
let! form = ctx.BindFormAsync<EditChapterModel>()
let chapters = post.Episode.Value.Chapters.Value
if index >= -1 && index < List.length chapters then
try
let chapter = form.ToChapter()
let existing = if index = -1 then chapters else List.removeAt index chapters
let updatedPost =
{ post with
Episode = Some
{ post.Episode.Value with
Chapters = Some (chapter :: existing |> List.sortBy _.StartTime) } }
do! data.Post.Update updatedPost
do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" }
return!
Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)
|> adminBarePage "Manage Chapters" true next ctx
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}
let deleteChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Post.FindById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
let chapters = post.Episode.Value.Chapters.Value
if index >= 0 && index < List.length chapters then
let updatedPost =
{ post with
Episode = Some { post.Episode.Value with Chapters = Some (List.removeAt index chapters) } }
do! data.Post.Update updatedPost
do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" }
return!
Views.Post.chapterList false (ManageChaptersModel.Create updatedPost)
|> adminPage "Manage Chapters" true next ctx
else return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// POST /admin/post/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPostModel>()
let data = ctx.Data
let now = DateTime.UtcNow
let tryPost =
if model.IsNew then
{ Post.empty with
Id = PostId.create ()
{ Post.Empty with
Id = PostId.Create()
WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId
} |> someTask
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id
AuthorId = ctx.UserId }
|> someTask
else data.Post.FindFullById (PostId model.Id) ctx.WebLog.Id
match! tryPost with
| Some post when canEdit post.AuthorId ctx ->
let priorCats = post.CategoryIds
let updatedPost =
model.UpdatePost post now
model.UpdatePost post (Noda.now ())
|> function
| post ->
if model.SetPublished then
@@ -392,11 +502,10 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
{ post with
PublishedOn = Some dt
UpdatedOn = dt
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ]
}
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ] }
else { post with PublishedOn = Some dt }
else post
do! (if model.PostId = "new" then data.Post.Add else data.Post.Update) updatedPost
do! (if model.IsNew then data.Post.Add else data.Post.Update) updatedPost
// If the post was published or its categories changed, refresh the category cache
if model.DoPublish
|| not (priorCats
@@ -404,8 +513,8 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> List.distinct
|> List.length = List.length priorCats) then
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Post saved successfully" }
return! redirectToGet $"admin/post/{PostId.toString post.Id}/edit" 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
}

View File

@@ -16,22 +16,27 @@ module CatchAll =
let data = ctx.Data
let debug = debug "Routes.CatchAll" ctx
let textLink =
let _, extra = WebLog.hostAndPath webLog
let extra = webLog.ExtraPath
let url = string ctx.Request.Path
(if extra = "" then url else url.Substring extra.Length).ToLowerInvariant ()
(if extra = "" then url else url[extra.Length..]).ToLowerInvariant()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
seq {
debug (fun () -> $"Considering URL {textLink}")
// Home page directory without the directory slash
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
let permalink = Permalink (textLink.Substring 1)
if textLink = "" then yield redirectTo true (webLog.RelativeUrl Permalink.Empty)
let permalink = Permalink textLink[1..]
// Current post
match data.Post.FindByPermalink permalink webLog.Id |> await with
| Some post ->
debug (fun () -> "Found post by permalink")
let hash = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data |> await
if post.Status = Published || Option.isSome ctx.UserAccessLevel then
if ctx.Request.Query.ContainsKey "chapters" then
yield Post.chapters post
else
yield fun next ctx ->
addToHash ViewContext.PageTitle post.Title hash
Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data
|> await
|> addToHash ViewContext.PageTitle post.Title
|> themedView (defaultArg post.Template "single-post") next ctx
| None -> ()
// Current page
@@ -40,7 +45,7 @@ module CatchAll =
debug (fun () -> "Found page by permalink")
yield fun next ctx ->
hashForPage page.Title
|> addToHash "page" (DisplayPage.fromPage webLog page)
|> addToHash "page" (DisplayPage.FromPage webLog page)
|> addToHash ViewContext.IsPage true
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> ()
@@ -56,25 +61,25 @@ module CatchAll =
match data.Post.FindByPermalink altLink webLog.Id |> await with
| Some post ->
debug (fun () -> "Found post by trailing-slash-agnostic permalink")
yield redirectTo true (WebLog.relativeUrl webLog post.Permalink)
yield redirectTo true (webLog.RelativeUrl post.Permalink)
| None -> ()
// Page differing only by trailing slash
match data.Page.FindByPermalink altLink webLog.Id |> await with
| Some page ->
debug (fun () -> "Found page by trailing-slash-agnostic permalink")
yield redirectTo true (WebLog.relativeUrl webLog page.Permalink)
yield redirectTo true (webLog.RelativeUrl page.Permalink)
| None -> ()
// Prior post
match data.Post.FindCurrentPermalink [ permalink; altLink ] webLog.Id |> await with
| Some link ->
debug (fun () -> "Found post by prior permalink")
yield redirectTo true (WebLog.relativeUrl webLog link)
yield redirectTo true (webLog.RelativeUrl link)
| None -> ()
// Prior page
match data.Page.FindCurrentPermalink [ permalink; altLink ] webLog.Id |> await with
| Some link ->
debug (fun () -> "Found page by prior permalink")
yield redirectTo true (WebLog.relativeUrl webLog link)
yield redirectTo true (webLog.RelativeUrl link)
| None -> ()
debug (fun () -> "No content found")
}
@@ -90,11 +95,11 @@ module Asset =
// GET /theme/{theme}/{**path}
let serve (urlParts: string seq) : HttpHandler = fun next ctx -> task {
let path = urlParts |> Seq.skip 1 |> Seq.head
match! ctx.Data.ThemeAsset.FindById (ThemeAssetId.ofString path) with
match! ctx.Data.ThemeAsset.FindById(ThemeAssetId.Parse path) with
| Some asset ->
match Upload.checkModified asset.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! Upload.sendFile asset.UpdatedOn path asset.Data next ctx
| None -> return! Upload.sendFile (asset.UpdatedOn.ToDateTimeUtc()) path asset.Data next ctx
| None -> return! Error.notFound next ctx
}
@@ -106,12 +111,13 @@ let router : HttpHandler = choose [
]
subRoute "/admin" (requireUser >=> choose [
GET_HEAD >=> choose [
subRoute "/categor" (choose [
route "ies" >=> Admin.listCategories
route "ies/bare" >=> Admin.listCategoriesBare
routef "y/%s/edit" Admin.editCategory
route "/administration" >=> Admin.Dashboard.admin
subRoute "/categor" (requireAccess WebLogAdmin >=> choose [
route "ies" >=> Admin.Category.all
routef "y/%s/edit" Admin.Category.edit
])
route "/dashboard" >=> Admin.dashboard
route "/dashboard" >=> Admin.Dashboard.user
route "/my-info" >=> User.myInfo
subRoute "/page" (choose [
route "s" >=> Page.all 1
routef "s/page/%i" Page.all
@@ -127,74 +133,97 @@ let router : HttpHandler = choose [
routef "/%s/permalinks" Post.editPermalinks
routef "/%s/revision/%s/preview" Post.previewRevision
routef "/%s/revisions" Post.editRevisions
routef "/%s/chapter/%i" Post.editChapter
routef "/%s/chapters" Post.manageChapters
])
subRoute "/settings" (choose [
route "" >=> Admin.settings
subRoute "/rss" (choose [
route "" >=> Feed.editSettings
routef "/%s/edit" Feed.editCustomFeed
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [
route "" >=> Admin.WebLog.settings
routef "/rss/%s/edit" Feed.editCustomFeed
subRoute "/redirect-rules" (choose [
route "" >=> Admin.RedirectRules.all
routef "/%i" Admin.RedirectRules.edit
])
subRoute "/tag-mapping" (choose [
route "s" >=> Admin.tagMappings
route "s/bare" >=> Admin.tagMappingsBare
routef "/%s/edit" Admin.editMapping
route "s" >=> Admin.TagMapping.all
routef "/%s/edit" Admin.TagMapping.edit
])
subRoute "/user" (choose [
route "s" >=> User.all
routef "/%s/edit" User.edit
])
])
route "/theme/update" >=> Admin.themeUpdatePage
subRoute "/theme" (choose [
route "/list" >=> Admin.Theme.all
route "/new" >=> Admin.Theme.add
])
subRoute "/upload" (choose [
route "s" >=> Upload.list
route "/new" >=> Upload.showNew
])
subRoute "/user" (choose [
route "s" >=> User.all
route "s/bare" >=> User.bare
route "/my-info" >=> User.myInfo
routef "/%s/edit" User.edit
])
]
POST >=> validateCsrf >=> choose [
subRoute "/category" (choose [
route "/save" >=> Admin.saveCategory
routef "/%s/delete" Admin.deleteCategory
subRoute "/cache" (choose [
routef "/theme/%s/refresh" Admin.Cache.refreshTheme
routef "/web-log/%s/refresh" Admin.Cache.refreshWebLog
])
subRoute "/category" (requireAccess WebLogAdmin >=> choose [
route "/save" >=> Admin.Category.save
routef "/%s/delete" Admin.Category.delete
])
route "/my-info" >=> User.saveMyInfo
subRoute "/page" (choose [
route "/save" >=> Page.save
route "/permalinks" >=> Page.savePermalinks
routef "/%s/delete" Page.delete
routef "/%s/revision/%s/delete" Page.deleteRevision
routef "/%s/revision/%s/restore" Page.restoreRevision
routef "/%s/revisions/purge" Page.purgeRevisions
])
subRoute "/post" (choose [
route "/save" >=> Post.save
route "/permalinks" >=> Post.savePermalinks
routef "/%s/delete" Post.delete
routef "/%s/revision/%s/delete" Post.deleteRevision
routef "/%s/chapter/%i" Post.saveChapter
routef "/%s/revision/%s/restore" Post.restoreRevision
routef "/%s/revisions/purge" Post.purgeRevisions
])
subRoute "/settings" (choose [
route "" >=> Admin.saveSettings
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [
route "" >=> Admin.WebLog.saveSettings
subRoute "/rss" (choose [
route "" >=> Feed.saveSettings
route "/save" >=> Feed.saveCustomFeed
routef "/%s/delete" Feed.deleteCustomFeed
])
subRoute "/tag-mapping" (choose [
route "/save" >=> Admin.saveMapping
routef "/%s/delete" Admin.deleteMapping
subRoute "/redirect-rules" (choose [
routef "/%i" Admin.RedirectRules.save
routef "/%i/up" Admin.RedirectRules.moveUp
routef "/%i/down" Admin.RedirectRules.moveDown
])
route "/tag-mapping/save" >=> Admin.TagMapping.save
route "/user/save" >=> User.save
])
route "/theme/update" >=> Admin.updateTheme
subRoute "/upload" (choose [
route "/save" >=> Upload.save
routexp "/delete/(.*)" Upload.deleteFromDisk
routef "/%s/delete" Upload.deleteFromDb
subRoute "/theme" (choose [
route "/new" >=> Admin.Theme.save
routef "/%s/delete" Admin.Theme.delete
])
subRoute "/user" (choose [
route "/my-info" >=> User.saveMyInfo
route "/save" >=> User.save
routef "/%s/delete" User.delete
route "/upload/save" >=> Upload.save
]
DELETE >=> validateCsrf >=> choose [
routef "/category/%s" Admin.Category.delete
subRoute "/page" (choose [
routef "/%s" Page.delete
routef "/%s/revision/%s" Page.deleteRevision
routef "/%s/revisions" Page.purgeRevisions
])
subRoute "/post" (choose [
routef "/%s" Post.delete
routef "/%s/chapter/%i" Post.deleteChapter
routef "/%s/revision/%s" Post.deleteRevision
routef "/%s/revisions" Post.purgeRevisions
])
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [
routef "/redirect-rules/%i" Admin.RedirectRules.delete
routef "/rss/%s" Feed.deleteCustomFeed
routef "/tag-mapping/%s" Admin.TagMapping.delete
routef "/user/%s" User.delete
])
subRoute "/upload" (requireAccess WebLogAdmin >=> choose [
routexp "/disk/(.*)" Upload.deleteFromDisk
routef "/%s" Upload.deleteFromDb
])
]
])
@@ -223,7 +252,7 @@ let routerWithPath extraPath : HttpHandler =
/// Handler to apply Giraffe routing with a possible sub-route
let handleRoute : HttpHandler = fun next ctx ->
let _, extraPath = WebLog.hostAndPath ctx.WebLog
let extraPath = ctx.WebLog.ExtraPath
(if extraPath = "" then router else routerWithPath extraPath) next ctx

View File

@@ -29,15 +29,17 @@ module private Helpers =
// ~~ SERVING UPLOADS ~~
open System.Globalization
open Giraffe
open Microsoft.AspNetCore.Http
open NodaTime
/// Determine if the file has been modified since the date/time specified by the If-Modified-Since header
let checkModified since (ctx: HttpContext) : HttpHandler option =
match ctx.Request.Headers.IfModifiedSince with
| it when it.Count < 1 -> None
| it when since > DateTime.Parse it[0] -> None
| _ -> Some (setStatusCode 304 >=> setBodyFromString "Not Modified")
| it when since > Instant.FromDateTimeUtc(DateTime.Parse(it[0], null, DateTimeStyles.AdjustToUniversal)) -> None
| _ -> Some (setStatusCode 304)
open Microsoft.AspNetCore.Http.Headers
@@ -73,7 +75,7 @@ let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
| Some upload ->
match checkModified upload.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! sendFile upload.UpdatedOn path upload.Data next ctx
| None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc()) path upload.Data next ctx
| None -> return! Error.notFound next ctx
else
return! Error.notFound next ctx
@@ -85,7 +87,7 @@ open System.Text.RegularExpressions
open MyWebLog.ViewModels
/// Turn a string into a lowercase URL-safe slug
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
let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
@@ -105,37 +107,25 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
Name = name
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/')
UpdatedOn = create
Source = UploadDestination.toString Disk
})
|> List.ofSeq
Source = string Disk })
with
| :? DirectoryNotFoundException -> [] // This is fine
| ex ->
warn "Upload" ctx $"Encountered {ex.GetType().Name} listing uploads for {path}:\n{ex.Message}"
[]
let allFiles =
dbUploads
|> List.map (DisplayUpload.fromUpload webLog Database)
|> List.append diskUploads
|> List.sortByDescending (fun file -> file.UpdatedOn, file.Path)
return!
hashForPage "Uploaded Files"
|> withAntiCsrf ctx
|> addToHash "files" allFiles
|> adminView "upload-list" next ctx
dbUploads
|> Seq.ofList
|> Seq.map (DisplayUpload.FromUpload webLog Database)
|> Seq.append diskUploads
|> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path)
|> Views.WebLog.uploadList
|> adminPage "Uploaded Files" true next ctx
}
// GET /admin/upload/new
let showNew : HttpHandler = requireAccess Author >=> fun next ctx ->
hashForPage "Upload a File"
|> withAntiCsrf ctx
|> addToHash "destination" (UploadDestination.toString ctx.WebLog.Uploads)
|> adminView "upload-new" next ctx
/// Redirect to the upload list
let showUploads : HttpHandler =
redirectToGet "admin/uploads"
adminPage "Upload a File" true next ctx Views.WebLog.uploadNew
// POST /admin/upload/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
@@ -143,22 +133,22 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let upload = Seq.head ctx.Request.Form.Files
let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName),
Path.GetExtension(upload.FileName).ToLowerInvariant())
let localNow = WebLog.localTime ctx.WebLog DateTime.Now
let now = Noda.now ()
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 ->
use stream = new MemoryStream()
do! upload.CopyToAsync stream
let file =
{ Id = UploadId.create ()
{ Id = UploadId.Create()
WebLogId = ctx.WebLog.Id
Path = Permalink $"{year}/{month}/{fileName}"
UpdatedOn = DateTime.UtcNow
Data = stream.ToArray ()
}
UpdatedOn = now
Data = stream.ToArray() }
do! ctx.Data.Upload.Add file
| Disk ->
let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month)
@@ -166,18 +156,18 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
use stream = new FileStream(Path.Combine(fullPath, fileName), FileMode.Create)
do! upload.CopyToAsync stream
do! addMessage ctx { UserMessage.success with Message = $"File uploaded to {form.Destination} successfully" }
return! showUploads next ctx
do! addMessage ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" }
return! redirectToGet "admin/uploads" next ctx
else
return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx
}
// POST /admin/upload/{id}/delete
let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// DELETE /admin/upload/{id}
let deleteFromDb upId : HttpHandler = fun next ctx -> task {
match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.Id with
| Ok fileName ->
do! addMessage ctx { UserMessage.success with Message = $"{fileName} deleted successfully" }
return! showUploads next ctx
do! addMessage ctx { UserMessage.Success with Message = $"{fileName} deleted successfully" }
return! list next ctx
| Error _ -> return! Error.notFound next ctx
}
@@ -192,14 +182,14 @@ let removeEmptyDirectories (webLog : WebLog) (filePath : string) =
path <- String.Join(slash, path.Split slash |> Array.rev |> Array.skip 1 |> Array.rev)
else finished <- true
// POST /admin/upload/delete/{**path}
let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// DELETE /admin/upload/disk/{**path}
let deleteFromDisk urlParts : HttpHandler = fun next ctx -> task {
let filePath = urlParts |> Seq.skip 1 |> Seq.head
let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath)
if File.Exists path then
File.Delete path
removeEmptyDirectories ctx.WebLog filePath
do! addMessage ctx { UserMessage.success with Message = $"{filePath} deleted successfully" }
return! showUploads next ctx
do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" }
return! list next ctx
else return! Error.notFound next ctx
}

View File

@@ -2,19 +2,31 @@
module MyWebLog.Handlers.User
open System
open System.Security.Cryptography
open System.Text
open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Identity
open MyWebLog
// ~~ LOG ON / LOG OFF ~~
/// Hash a password for a given user
let hashedPassword (plainText : string) (email : string) (salt : Guid) =
let allSalt = Array.concat [ salt.ToByteArray (); Encoding.UTF8.GetBytes email ]
use alg = new Rfc2898DeriveBytes (plainText, allSalt, 2_048)
Convert.ToBase64String (alg.GetBytes 64)
/// Create a password hash a password for a given user
let createPasswordHash user password =
PasswordHasher<WebLogUser>().HashPassword(user, password)
/// Verify whether a password is valid
let verifyPassword user password (ctx: HttpContext) = backgroundTask {
match user with
| Some usr ->
let hasher = PasswordHasher<WebLogUser>()
match hasher.VerifyHashedPassword(usr, usr.PasswordHash, password) with
| PasswordVerificationResult.Success -> return Ok ()
| PasswordVerificationResult.SuccessRehashNeeded ->
do! ctx.Data.WebLogUser.Update { usr with PasswordHash = hasher.HashPassword(usr, password) }
return Ok ()
| _ -> return Error "Log on attempt unsuccessful"
| None -> return Error "Log on attempt unsuccessful"
}
open Giraffe
open MyWebLog
open MyWebLog.ViewModels
// GET /user/log-on
@@ -23,10 +35,7 @@ let logOn returnUrl : HttpHandler = fun next ctx ->
match returnUrl with
| Some _ -> returnUrl
| None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None
hashForPage "Log On"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model { LogOnModel.empty with ReturnTo = returnTo }
|> adminView "log-on" next ctx
adminPage "Log On" true next ctx (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo })
open System.Security.Claims
@@ -37,13 +46,15 @@ open Microsoft.AspNetCore.Authentication.Cookies
let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel>()
let data = ctx.Data
match! data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.Id with
| Some user when user.PasswordHash = hashedPassword model.Password user.Email user.Salt ->
let! tryUser = data.WebLogUser.FindByEmail (model.EmailAddress.ToLowerInvariant()) ctx.WebLog.Id
match! verifyPassword tryUser model.Password ctx with
| Ok _ ->
let user = tryUser.Value
let claims = seq {
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.Id)
Claim(ClaimTypes.NameIdentifier, string user.Id)
Claim(ClaimTypes.Name, $"{user.FirstName} {user.LastName}")
Claim(ClaimTypes.GivenName, user.PreferredName)
Claim (ClaimTypes.Role, AccessLevel.toString user.AccessLevel)
Claim(ClaimTypes.Role, string user.AccessLevel)
}
let identity = ClaimsIdentity(claims, CookieAuthenticationDefaults.AuthenticationScheme)
@@ -51,122 +62,56 @@ let doLogOn : HttpHandler = fun next ctx -> task {
AuthenticationProperties(IssuedUtc = DateTimeOffset.UtcNow))
do! data.WebLogUser.SetLastSeen user.Id user.WebLogId
do! addMessage ctx
{ UserMessage.success with Message = $"Logged on successfully | Welcome to {ctx.WebLog.Name}!" }
{ UserMessage.Success with
Message = "Log on successful"
Detail = Some $"Welcome to {ctx.WebLog.Name}!" }
return!
match model.ReturnTo with
| Some url -> redirectTo false url next ctx
| Some url -> redirectTo false url next ctx // TODO: change to redirectToGet?
| None -> redirectToGet "admin/dashboard" next ctx
| _ ->
do! addMessage ctx { UserMessage.error with Message = "Log on attempt unsuccessful" }
| Error msg ->
do! addMessage ctx { UserMessage.Error with Message = msg }
return! logOn model.ReturnTo next ctx
}
// GET /user/log-off
let logOff : HttpHandler = fun next ctx -> task {
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" }
return! redirectToGet "" next ctx
}
// ~~ ADMINISTRATION ~~
open System.Collections.Generic
open Giraffe.Htmx
open Microsoft.AspNetCore.Http
/// Create the hash needed to display the user list
let private userListHash (ctx : HttpContext) = task {
let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id
return!
hashForPage "User Administration"
|> withAntiCsrf ctx
|> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList)
|> addViewContext ctx
}
/// Got no time for URL/form manipulators...
let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?"
// GET /admin/users
let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = userListHash ctx
let! tmpl = TemplateCache.get "admin" "user-list-body" ctx.Data
return!
addToHash "user_list" (tmpl.Render hash) hash
|> adminView "user-list" next ctx
}
// GET /admin/users/bare
let bare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = userListHash ctx
return! adminBareView "user-list-body" next ctx hash
// GET /admin/settings/users
let all : HttpHandler = fun next ctx -> task {
let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id
return! adminBarePage "User Administration" true next ctx (Views.User.userList users)
}
/// Show the edit user page
let private showEdit (model: EditUserModel) : HttpHandler = fun next ctx ->
hashForPage (if model.IsNew then "Add a New User" else "Edit User")
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> addToHash "access_levels" [|
KeyValuePair.Create (AccessLevel.toString Author, "Author")
KeyValuePair.Create (AccessLevel.toString Editor, "Editor")
KeyValuePair.Create (AccessLevel.toString WebLogAdmin, "Web Log Admin")
if ctx.HasAccessLevel Administrator then
KeyValuePair.Create (AccessLevel.toString Administrator, "Administrator")
|]
|> adminBareView "user-edit" next ctx
adminBarePage (if model.IsNew then "Add a New User" else "Edit User") true next ctx (Views.User.edit model)
// GET /admin/user/{id}/edit
let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// GET /admin/settings/user/{id}/edit
let edit usrId : HttpHandler = fun next ctx -> task {
let isNew = usrId = "new"
let userId = WebLogUserId usrId
let tryUser =
if isNew then someTask { WebLogUser.empty with Id = userId }
if isNew then someTask { WebLogUser.Empty with Id = userId }
else ctx.Data.WebLogUser.FindById userId ctx.WebLog.Id
match! tryUser with
| Some user -> return! showEdit (EditUserModel.fromUser user) next ctx
| Some user -> return! showEdit (EditUserModel.FromUser user) next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/user/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> ()
let data = ctx.Data
let tryUser =
if model.IsNew then
{ WebLogUser.empty with
Id = WebLogUserId.create ()
WebLogId = ctx.WebLog.Id
CreatedOn = DateTime.UtcNow
} |> someTask
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
match! tryUser with
| Some user when model.Password = model.PasswordConfirm ->
let updatedUser = model.UpdateUser user
if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then
return! goAway next ctx
else
let updatedUser =
if model.Password = "" then updatedUser
else
let salt = Guid.NewGuid ()
{ updatedUser with PasswordHash = hashedPassword model.Password model.Email salt; Salt = salt }
do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) updatedUser
do! addMessage ctx
{ UserMessage.success with
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully"""
}
return! bare next ctx
| Some _ ->
do! addMessage ctx { UserMessage.error with Message = "The passwords did not match; nothing saved" }
return!
(withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" })
next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/user/{id}/delete
let delete userId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// DELETE /admin/settings/user/{id}
let delete userId : HttpHandler = fun next ctx -> task {
let data = ctx.Data
match! data.WebLogUser.FindById (WebLogUserId userId) ctx.WebLog.Id with
| Some user ->
@@ -176,64 +121,86 @@ let delete userId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
match! data.WebLogUser.Delete user.Id user.WebLogId with
| Ok _ ->
do! addMessage ctx
{ UserMessage.success with
Message = $"User {WebLogUser.displayName user} deleted successfully"
}
return! bare next ctx
{ UserMessage.Success with
Message = $"User {user.DisplayName} deleted successfully" }
return! all next ctx
| Error msg ->
do! addMessage ctx
{ UserMessage.error with
Message = $"User {WebLogUser.displayName user} was not deleted"
Detail = Some msg
}
return! bare next ctx
{ UserMessage.Error with
Message = $"User {user.DisplayName} was not deleted"
Detail = Some msg }
return! all next ctx
| None -> return! Error.notFound next ctx
}
/// Display the user "my info" page, with information possibly filled in
let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandler = fun next ctx ->
hashForPage "Edit Your Information"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> addToHash "access_level" (AccessLevel.toString user.AccessLevel)
|> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn)
|> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch))
|> adminView "my-info" next ctx
// GET /admin/user/my-info
// GET /admin/my-info
let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user -> return! showMyInfo (EditMyInfoModel.fromUser user) user next ctx
| Some user ->
return!
Views.User.myInfo (EditMyInfoModel.FromUser user) user
|> adminPage "Edit Your Information" true next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/user/my-info
// POST /admin/my-info
let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditMyInfoModel>()
let data = ctx.Data
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user when model.NewPassword = model.NewPasswordConfirm ->
let pw, salt =
if model.NewPassword = "" then
user.PasswordHash, user.Salt
else
let newSalt = Guid.NewGuid ()
hashedPassword model.NewPassword user.Email newSalt, newSalt
let pw = if model.NewPassword = "" then user.PasswordHash else createPasswordHash user model.NewPassword
let user =
{ user with
FirstName = model.FirstName
LastName = model.LastName
PreferredName = model.PreferredName
PasswordHash = pw
Salt = salt
}
PasswordHash = pw }
do! data.WebLogUser.Update user
let pwMsg = if model.NewPassword = "" then "" else " and updated your password"
do! addMessage ctx { UserMessage.success with Message = $"Saved your information{pwMsg} successfully" }
return! redirectToGet "admin/user/my-info" next ctx
do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" }
return! redirectToGet "admin/my-info" next ctx
| Some user ->
do! addMessage ctx { UserMessage.error with Message = "Passwords did not match; no updates made" }
return! showMyInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user next ctx
do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" }
return!
Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user
|> adminPage "Edit Your Information" true next ctx
| None -> return! Error.notFound next ctx
}
// User save is not statically compilable; not sure why, but we'll revisit it at some point
#nowarn "3511"
// POST /admin/settings/user/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel>()
let data = ctx.Data
let tryUser =
if model.IsNew then
{ WebLogUser.Empty with
Id = WebLogUserId.Create()
WebLogId = ctx.WebLog.Id
CreatedOn = Noda.now () }
|> someTask
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
match! tryUser with
| Some user when model.Password = model.PasswordConfirm ->
let updatedUser = model.UpdateUser user
if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then
return! goAway next ctx
else
let toUpdate =
if model.Password = "" then updatedUser
else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password }
do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate
do! addMessage ctx
{ UserMessage.Success with
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully""" }
return! all next ctx
| Some _ ->
do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" }
return!
(withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" })
next ctx
| None -> return! Error.notFound next ctx
}

View File

@@ -4,6 +4,7 @@ open System
open System.IO
open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data
open NodaTime
/// Create the web log information
let private doCreateWebLog (args: string[]) (sp: IServiceProvider) = task {
@@ -19,51 +20,44 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
| true, ianaId -> ianaId
| false, _ -> raise <| TimeZoneNotFoundException $"Cannot find IANA timezone for {local}"
// Create the web log
let webLogId = WebLogId.create ()
let userId = WebLogUserId.create ()
let homePageId = PageId.create ()
let slug = Handlers.Upload.makeSlug args[2]
// If this is the first web log being created, the user will be an installation admin; otherwise, they will be an
// admin just over their web log
let! webLogs = data.WebLog.All()
let accessLevel = if List.isEmpty webLogs then Administrator else WebLogAdmin
do! data.WebLog.Add
{ WebLog.empty with
Id = webLogId
let homePageId = PageId.Create()
// Create the web log
let webLog =
{ WebLog.Empty with
Id = WebLogId.Create()
Name = args[2]
Slug = slug
UrlBase = args[1]
DefaultPage = PageId.toString homePageId
TimeZone = timeZone
}
Slug = Handlers.Upload.makeSlug args[2]
UrlBase = args[1].ToLowerInvariant()
DefaultPage = string homePageId
TimeZone = timeZone }
do! data.WebLog.Add webLog
// Create the admin user
let salt = Guid.NewGuid ()
let now = DateTime.UtcNow
do! data.WebLogUser.Add
{ WebLogUser.empty with
Id = userId
WebLogId = webLogId
Email = args[3]
let now = Noda.now ()
let user =
{ WebLogUser.Empty with
Id = WebLogUserId.Create()
WebLogId = webLog.Id
Email = args[3].ToLowerInvariant()
FirstName = "Admin"
LastName = "User"
PreferredName = "Admin"
PasswordHash = Handlers.User.hashedPassword args[4] args[3] salt
Salt = salt
AccessLevel = accessLevel
CreatedOn = now
}
CreatedOn = now }
do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] }
// Create the default home page
do! data.Page.Add
{ Page.empty with
{ Page.Empty with
Id = homePageId
WebLogId = webLogId
AuthorId = userId
WebLogId = webLog.Id
AuthorId = user.Id
Title = "Welcome to myWebLog!"
Permalink = Permalink "welcome-to-myweblog.html"
PublishedOn = now
@@ -71,16 +65,14 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
Text = "<p>This is your default home page.</p>"
Revisions = [
{ AsOf = now
Text = Html "<p>This is your default home page.</p>"
}
]
}
Text = Html "<p>This is your default home page.</p>" }
] }
printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}"
printfn $"Successfully initialized database for {webLog.Name} with URL base {webLog.UrlBase}"
match accessLevel with
| Administrator -> printfn $" ({args[3]} is an installation administrator)"
| Administrator -> printfn $" ({user.Email} is an installation administrator)"
| WebLogAdmin ->
printfn $" ({args[3]} is a web log administrator;"
printfn $" ({user.Email} is a web log administrator;"
printfn """ use "upgrade-user" to promote to installation administrator)"""
| _ -> ()
}
@@ -89,7 +81,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
let createWebLog args sp = task {
match args |> Array.length with
| 5 -> do! doCreateWebLog args sp
| _ -> eprintfn "Usage: MyWebLog init [url] [name] [admin-email] [admin-pw]"
| _ -> eprintfn "Usage: myWebLog init [url] [name] [admin-email] [admin-pw]"
}
/// Import prior permalinks from a text files with lines in the format "[old] [new]"
@@ -112,8 +104,8 @@ let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
let! withLinks = data.Post.FindFullById post.Id post.WebLogId
let! _ = data.Post.UpdatePriorPermalinks post.Id post.WebLogId
(old :: withLinks.Value.PriorPermalinks)
printfn $"{Permalink.toString old} -> {Permalink.toString current}"
| None -> eprintfn $"Cannot find current post for {Permalink.toString current}"
printfn $"{old} -> {current}"
| None -> eprintfn $"Cannot find current post for {current}"
printfn "Done!"
| None -> eprintfn $"No web log found at {urlBase}"
}
@@ -122,38 +114,39 @@ let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
let importLinks args sp = task {
match args |> Array.length with
| 3 -> do! importPriorPermalinks args[1] args[2] sp
| _ -> eprintfn "Usage: MyWebLog import-links [url] [file-name]"
| _ -> eprintfn "Usage: myWebLog import-links [url] [file-name]"
}
// Loading a theme and restoring a backup are not statically compilable; this is OK
#nowarn "3511"
open Microsoft.Extensions.Logging
/// Load a theme from the given ZIP file
let loadTheme (args: string[]) (sp: IServiceProvider) = task {
if args.Length > 1 then
if args.Length = 2 then
let fileName =
match args[1].LastIndexOf Path.DirectorySeparatorChar with
| -1 -> args[1]
| it -> args[1][(it + 1)..]
match Handlers.Admin.getThemeName fileName with
| Ok themeName ->
match Handlers.Admin.Theme.deriveIdFromFileName fileName with
| Ok themeId ->
let data = sp.GetRequiredService<IData>()
let clean = if args.Length > 2 then bool.Parse args[2] else true
use stream = File.Open(args[1], FileMode.Open)
use copy = new MemoryStream()
do! stream.CopyToAsync copy
do! Handlers.Admin.loadThemeFromZip themeName copy clean data
printfn $"Theme {themeName} loaded successfully"
let! theme = Handlers.Admin.Theme.loadFromZip themeId copy data
let fac = sp.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger "MyWebLog.Themes"
log.LogInformation $"{theme.Name} v{theme.Version} ({theme.Id}) loaded"
| Error message -> eprintfn $"{message}"
else
eprintfn "Usage: MyWebLog load-theme [theme-zip-file-name] [*clean-load]"
eprintfn " * optional, defaults to true"
eprintfn "Usage: myWebLog load-theme [theme-zip-file-name]"
}
/// Back up a web log's data
module Backup =
open System.Threading.Tasks
open MyWebLog.Converters
open Newtonsoft.Json
@@ -163,25 +156,22 @@ module Backup =
Id: ThemeAssetId
/// The updated date for this asset
UpdatedOn : DateTime
UpdatedOn: Instant
/// The data for this asset, base-64 encoded
Data : string
}
Data: string }
/// Create an encoded theme asset from the original theme asset
static member fromAsset (asset: ThemeAsset) =
{ Id = asset.Id
UpdatedOn = asset.UpdatedOn
Data = Convert.ToBase64String asset.Data
}
Data = Convert.ToBase64String asset.Data }
/// Create a theme asset from an encoded theme asset
static member toAsset (encoded: EncodedAsset) : ThemeAsset =
{ Id = encoded.Id
UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data
}
Data = Convert.FromBase64String encoded.Data }
/// An uploaded file, with the data base-64 encoded
type EncodedUpload =
@@ -195,11 +185,10 @@ module Backup =
Path: Permalink
/// The date/time this upload was last updated (file time)
UpdatedOn : DateTime
UpdatedOn: Instant
/// The data for the upload, base-64 encoded
Data : string
}
Data: string }
/// Create an encoded uploaded file from the original uploaded file
static member fromUpload (upload: Upload) : EncodedUpload =
@@ -207,8 +196,7 @@ module Backup =
WebLogId = upload.WebLogId
Path = upload.Path
UpdatedOn = upload.UpdatedOn
Data = Convert.ToBase64String upload.Data
}
Data = Convert.ToBase64String upload.Data }
/// Create an uploaded file from an encoded uploaded file
static member toUpload (encoded: EncodedUpload) : Upload =
@@ -216,8 +204,7 @@ module Backup =
WebLogId = encoded.WebLogId
Path = encoded.Path
UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data
}
Data = Convert.FromBase64String encoded.Data }
/// A unified archive for a web log
type Archive =
@@ -246,13 +233,11 @@ module Backup =
Posts: Post list
/// The uploaded files for this web log
Uploads : EncodedUpload list
}
Uploads: EncodedUpload list }
/// Create a JSON serializer (uses RethinkDB data implementation's JSON converters)
/// Create a JSON serializer
let private getSerializer prettyOutput =
let serializer = JsonSerializer.CreateDefault ()
Json.all () |> Seq.iter serializer.Converters.Add
let serializer = Json.configure (JsonSerializer.CreateDefault())
if prettyOutput then serializer.Formatting <- Formatting.Indented
serializer
@@ -314,8 +299,7 @@ module Backup =
TagMappings = tagMaps
Pages = pages |> List.map (fun p -> { p with Revisions = List.truncate 1 p.Revisions })
Posts = posts |> List.map (fun p -> { p with Revisions = List.truncate 1 p.Revisions })
Uploads = uploads |> List.map EncodedUpload.fromUpload
}
Uploads = uploads |> List.map EncodedUpload.fromUpload }
// Write the structure to the backup file
if File.Exists fileName then File.Delete fileName
@@ -327,21 +311,21 @@ module Backup =
displayStats $"{fileName} (for <>NAME<>) contains:" webLog archive
}
let private doRestore archive newUrlBase (data : IData) = task {
let private doRestore archive newUrlBase isInteractive (data: IData) = task {
let! restore = task {
match! data.WebLog.FindById archive.WebLog.Id with
| Some webLog when defaultArg newUrlBase webLog.UrlBase = webLog.UrlBase ->
do! data.WebLog.Delete webLog.Id
return { archive with WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase webLog.UrlBase } }
return { archive with Archive.WebLog.UrlBase = defaultArg newUrlBase webLog.UrlBase }
| Some _ ->
// Err'body gets new IDs...
let newWebLogId = WebLogId.create ()
let newCatIds = archive.Categories |> List.map (fun cat -> cat.Id, CategoryId.create ()) |> dict
let newMapIds = archive.TagMappings |> List.map (fun tm -> tm.Id, TagMapId.create ()) |> dict
let newPageIds = archive.Pages |> List.map (fun page -> page.Id, PageId.create ()) |> dict
let newPostIds = archive.Posts |> List.map (fun post -> post.Id, PostId.create ()) |> dict
let newUserIds = archive.Users |> List.map (fun user -> user.Id, WebLogUserId.create ()) |> dict
let newUpIds = archive.Uploads |> List.map (fun up -> up.Id, UploadId.create ()) |> dict
let newWebLogId = WebLogId.Create()
let newCatIds = archive.Categories |> List.map (fun cat -> cat.Id, CategoryId.Create() ) |> dict
let newMapIds = archive.TagMappings |> List.map (fun tm -> tm.Id, TagMapId.Create() ) |> dict
let newPageIds = archive.Pages |> List.map (fun page -> page.Id, PageId.Create() ) |> dict
let newPostIds = archive.Posts |> List.map (fun post -> post.Id, PostId.Create() ) |> dict
let newUserIds = archive.Users |> List.map (fun user -> user.Id, WebLogUserId.Create()) |> dict
let newUpIds = archive.Uploads |> List.map (fun up -> up.Id, UploadId.Create() ) |> dict
return
{ archive with
WebLog = { archive.WebLog with Id = newWebLogId; UrlBase = Option.get newUrlBase }
@@ -356,60 +340,61 @@ module Backup =
{ page with
Id = newPageIds[page.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[page.AuthorId]
})
AuthorId = newUserIds[page.AuthorId] })
Posts = archive.Posts
|> List.map (fun post ->
{ post with
Id = newPostIds[post.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[post.AuthorId]
CategoryIds = post.CategoryIds |> List.map (fun c -> newCatIds[c])
})
CategoryIds = post.CategoryIds |> List.map (fun c -> newCatIds[c]) })
Uploads = archive.Uploads
|> List.map (fun u -> { u with Id = newUpIds[u.Id]; WebLogId = newWebLogId })
}
|> List.map (fun u -> { u with Id = newUpIds[u.Id]; WebLogId = newWebLogId }) }
| None ->
return
{ archive with
WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
return { archive with Archive.WebLog.UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
// Restore theme and assets (one at a time, as assets can be large)
if isInteractive then
printfn ""
printfn "- Importing theme..."
do! data.Theme.Save restore.Theme
let! _ = restore.Assets |> List.map (EncodedAsset.toAsset >> data.ThemeAsset.Save) |> Task.WhenAll
restore.Assets
|> List.iter (EncodedAsset.toAsset >> data.ThemeAsset.Save >> Async.AwaitTask >> Async.RunSynchronously)
// Restore web log data
printfn "- Restoring web log..."
do! data.WebLog.Add restore.WebLog
if isInteractive then printfn "- Restoring web log..."
// v2.0 backups will not have redirect rules; fix that if restoring to v2.1 or later
let webLog =
if isNull (box restore.WebLog.RedirectRules) then { restore.WebLog with RedirectRules = [] }
else restore.WebLog
do! data.WebLog.Add webLog
printfn "- Restoring users..."
if isInteractive then printfn "- Restoring users..."
do! data.WebLogUser.Restore restore.Users
printfn "- Restoring categories and tag mappings..."
do! data.TagMap.Restore restore.TagMappings
do! data.Category.Restore restore.Categories
if isInteractive then printfn "- Restoring categories and tag mappings..."
if not (List.isEmpty restore.TagMappings) then do! data.TagMap.Restore restore.TagMappings
if not (List.isEmpty restore.Categories) then do! data.Category.Restore restore.Categories
printfn "- Restoring pages..."
do! data.Page.Restore restore.Pages
if isInteractive then printfn "- Restoring pages..."
if not (List.isEmpty restore.Pages) then do! data.Page.Restore restore.Pages
printfn "- Restoring posts..."
do! data.Post.Restore restore.Posts
if isInteractive then printfn "- Restoring posts..."
if not (List.isEmpty restore.Posts) then do! data.Post.Restore restore.Posts
// TODO: comments not yet implemented
printfn "- Restoring uploads..."
if isInteractive then printfn "- Restoring uploads..."
if not (List.isEmpty restore.Uploads) then
do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload)
displayStats "Restored for <>NAME<>:" restore.WebLog restore
if isInteractive then displayStats "Restored for <>NAME<>:" restore.WebLog restore
}
/// Decide whether to restore a backup
let private restoreBackup (fileName : string) newUrlBase promptForOverwrite data = task {
let internal restoreBackup fileName newUrlBase promptForOverwrite isInteractive data = task {
let serializer = getSerializer false
use stream = new FileStream(fileName, FileMode.Open)
@@ -424,10 +409,10 @@ module Backup =
printfn " theme in either case."
printfn ""
printf "Continue? [Y/n] "
doOverwrite <- not ((Console.ReadKey ()).Key = ConsoleKey.N)
doOverwrite <- not (Console.ReadKey().Key = ConsoleKey.N)
if doOverwrite then
do! doRestore archive newUrlBase data
do! doRestore archive newUrlBase isInteractive data
else
printfn $"{archive.WebLog.Name} backup restoration canceled"
}
@@ -435,8 +420,9 @@ module Backup =
/// Generate a backup archive
let generateBackup (args: string[]) (sp: IServiceProvider) = task {
if args.Length > 1 && args.Length < 5 then
let url = args[1].ToLowerInvariant()
let data = sp.GetRequiredService<IData>()
match! data.WebLog.FindByHost args[1] with
match! data.WebLog.FindByHost url with
| Some webLog ->
let fileName =
if args.Length = 2 || (args.Length = 3 && args[2] = "pretty") then
@@ -447,9 +433,9 @@ module Backup =
$"{args[2]}.json"
let prettyOutput = (args.Length = 3 && args[2] = "pretty") || (args.Length = 4 && args[3] = "pretty")
do! createBackup webLog fileName prettyOutput data
| None -> eprintfn $"Error: no web log found for {args[1]}"
| None -> eprintfn $"Error: no web log found for {url}"
else
eprintfn """Usage: MyWebLog backup [url-base] [*backup-file-name] [**"pretty"]"""
eprintfn """Usage: myWebLog backup [url-base] [*backup-file-name] [**"pretty"]"""
eprintfn """ * optional - default is [web-log-slug].json"""
eprintfn """ ** optional - default is non-pretty JSON output"""
}
@@ -458,10 +444,10 @@ module Backup =
let restoreFromBackup (args: string[]) (sp: IServiceProvider) = task {
if args.Length = 2 || args.Length = 3 then
let data = sp.GetRequiredService<IData>()
let newUrlBase = if args.Length = 3 then Some args[2] else None
do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") data
let newUrlBase = if args.Length = 3 then Some (args[2].ToLowerInvariant()) else None
do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") true data
else
eprintfn "Usage: MyWebLog restore [backup-file-name] [*url-base]"
eprintfn "Usage: myWebLog restore [backup-file-name] [*url-base]"
eprintfn " * optional - will restore to original URL base if omitted"
eprintfn " (use do-restore to skip confirmation prompt)"
}
@@ -477,7 +463,7 @@ let private doUserUpgrade urlBase email (data : IData) = task {
| WebLogAdmin ->
do! data.WebLogUser.Update { user with AccessLevel = Administrator }
printfn $"{email} is now an Administrator user"
| other -> eprintfn $"ERROR: {email} is an {AccessLevel.toString other}, not a WebLogAdmin"
| other -> eprintfn $"ERROR: {email} is an {other}, not a WebLogAdmin"
| None -> eprintfn $"ERROR: no user {email} found at {urlBase}"
| None -> eprintfn $"ERROR: no web log found for {urlBase}"
}
@@ -485,6 +471,27 @@ let private doUserUpgrade urlBase email (data : IData) = task {
/// Upgrade a WebLogAdmin user to an Administrator user if the command-line arguments are good
let upgradeUser (args: string[]) (sp: IServiceProvider) = task {
match args.Length with
| 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService<IData> ())
| _ -> eprintfn "Usage: MyWebLog upgrade-user [web-log-url-base] [email-address]"
| 3 -> do! doUserUpgrade (args[1].ToLowerInvariant()) (args[2].ToLowerInvariant()) (sp.GetRequiredService<IData>())
| _ -> eprintfn "Usage: myWebLog upgrade-user [web-log-url-base] [email-address]"
}
/// Set a user's password
let doSetPassword urlBase email password (data: IData) = task {
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with
| Some user ->
do! data.WebLogUser.Update { user with PasswordHash = Handlers.User.createPasswordHash user password }
printfn $"Password for user {email} at {webLog.Name} set successfully"
| None -> eprintfn $"ERROR: no user {email} found at {urlBase}"
| None -> eprintfn $"ERROR: no web log found for {urlBase}"
}
/// Set a user's password if the command-line arguments are good
let setPassword (args: string[]) (sp: IServiceProvider) = task {
match args.Length with
| 4 ->
do! doSetPassword
(args[1].ToLowerInvariant()) (args[2].ToLowerInvariant()) args[3] (sp.GetRequiredService<IData>())
| _ -> eprintfn "Usage: myWebLog set-password [web-log-url-base] [email-address] [password]"
}

View File

@@ -2,16 +2,19 @@
<PropertyGroup>
<OutputType>Exe</OutputType>
<TargetFramework>net6.0</TargetFramework>
<PublishSingleFile>true</PublishSingleFile>
<SelfContained>false</SelfContained>
<DebugType>embedded</DebugType>
<NoWarn>3391</NoWarn>
</PropertyGroup>
<ItemGroup>
<Content Include="appsettings*.json" CopyToOutputDirectory="Always" />
<Compile Include="Caches.fs" />
<Compile Include="Views\Helpers.fs" />
<Compile Include="Views\Admin.fs" />
<Compile Include="Views\Page.fs" />
<Compile Include="Views\Post.fs" />
<Compile Include="Views\User.fs" />
<Compile Include="Views\WebLog.fs" />
<Compile Include="Handlers\Helpers.fs" />
<Compile Include="Handlers\Admin.fs" />
<Compile Include="Handlers\Feed.fs" />
@@ -26,14 +29,15 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="DotLiquid" Version="2.2.656" />
<PackageReference Include="Giraffe" Version="6.0.0" />
<PackageReference Include="Giraffe.Htmx" Version="1.8.0" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="1.8.0" />
<PackageReference Include="NeoSmart.Caching.Sqlite" Version="6.0.1" />
<PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.0.0" />
<PackageReference Include="DotLiquid" Version="2.2.692" />
<PackageReference Include="Giraffe" Version="6.4.0" />
<PackageReference Include="Giraffe.Htmx" Version="2.0.0" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="2.0.0" />
<PackageReference Include="NeoSmart.Caching.Sqlite.AspNetCore" Version="8.0.0" />
<PackageReference Include="RethinkDB.DistributedCache" Version="1.0.0-rc1" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
<PackageReference Include="System.ServiceModel.Syndication" Version="6.0.0" />
<PackageReference Include="System.ServiceModel.Syndication" Version="8.0.0" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
</ItemGroup>
<ItemGroup>
@@ -45,4 +49,10 @@
<None Include=".\wwwroot\upload\*" CopyToOutputDirectory="Always" />
</ItemGroup>
<ItemGroup>
<AssemblyAttribute Include="System.Runtime.CompilerServices.InternalsVisibleToAttribute">
<_Parameter1>MyWebLog.Tests</_Parameter1>
</AssemblyAttribute>
</ItemGroup>
</Project>

View File

@@ -10,12 +10,12 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
/// Is the debug level enabled on the logger?
let isDebug = log.IsEnabled LogLevel.Debug
member this.InvokeAsync (ctx : HttpContext) = task {
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 {WebLogId.toString webLog.Id} for {path}"
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
@@ -26,9 +26,36 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
}
/// 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 =
@@ -37,29 +64,43 @@ module DataImplementation =
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 =
let createSQLite connStr : IData =
Sqlite.Configuration.useConnectionString connStr
let log = sp.GetRequiredService<ILogger<SQLiteData>>()
let conn = new SqliteConnection (connStr)
let conn = Sqlite.Configuration.dbConn ()
log.LogInformation $"Using SQLite database {conn.DataSource}"
await (SQLiteData.setUpConnection conn)
SQLiteData (conn, log)
SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault()))
if hasConnStr "SQLite" then
upcast createSQLite (connStr "SQLite")
createSQLite (connStr "SQLite")
elif hasConnStr "RethinkDB" then
let log = sp.GetRequiredService<ILogger<RethinkDbData>>()
Json.all () |> Seq.iter Converter.Serializer.Converters.Add
let _ = Json.configure Converter.Serializer
let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log)
upcast RethinkDbData (conn, rethinkCfg, 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
upcast createSQLite "Data Source=./myweblog.db;Cache=Shared"
if not (Directory.Exists "./data") then Directory.CreateDirectory "./data" |> ignore
createSQLite "Data Source=./data/myweblog.db;Cache=Shared"
open System.Threading.Tasks
@@ -76,22 +117,25 @@ let showHelp () =
printfn "init Initializes a new web log"
printfn "load-theme Load a theme"
printfn "restore Restore a JSON file backup (prompt before overwriting)"
printfn "set-password Set a password for a specific user"
printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator"
printfn " "
printfn "For more information on a particular command, run it with no options."
Task.FromResult()
open BitBadger.AspNetCore.CanonicalDomains
open Giraffe
open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.HttpOverrides
open NeoSmart.Caching.Sqlite
open Microsoft.Extensions.Caching.Distributed
open NeoSmart.Caching.Sqlite.AspNetCore
open RethinkDB.DistributedCache
[<EntryPoint>]
let rec main args =
let main args =
let builder = WebApplication.CreateBuilder(args)
let _ = builder.Services.Configure<ForwardedHeadersOptions>(fun (opts : ForwardedHeadersOptions) ->
@@ -109,6 +153,7 @@ let rec main args =
let sp = builder.Services.BuildServiceProvider()
let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task {
do! data.StartUp()
@@ -120,23 +165,29 @@ let rec main args =
match data with
| :? RethinkDbData as rethink ->
// A RethinkDB connection is designed to work as a singleton
builder.Services.AddSingleton<IData> data |> ignore
let _ = builder.Services.AddSingleton<IData> data
let _ =
builder.Services.AddDistributedRethinkDBCache(fun opts ->
opts.TableName <- "Session"
opts.Connection <- rethink.Conn)
|> ignore
| :? SQLiteData as sql ->
()
| :? SQLiteData ->
// ADO.NET connections are designed to work as per-request instantiation
let cfg = sp.GetRequiredService<IConfiguration>()
builder.Services.AddScoped<SqliteConnection> (fun sp ->
let conn = new SqliteConnection (sql.Conn.ConnectionString)
SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously
conn)
|> ignore
builder.Services.AddScoped<IData, SQLiteData> () |> ignore
let _ = builder.Services.AddScoped<SqliteConnection>(fun sp -> Sqlite.Configuration.dbConn ())
let _ = builder.Services.AddScoped<IData, SQLiteData>()
// Use SQLite for caching as well
let cachePath = Option.ofObj (cfg.GetConnectionString "SQLiteCachePath") |> Option.defaultValue "./session.db"
builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath) |> ignore
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./data/session.db"
let _ = builder.Services.AddSqliteCache(fun o -> o.CachePath <- cachePath)
()
| :? PostgresData as postgres ->
// ADO.NET Data Sources are designed to work as singletons
let _ = builder.Services.AddSingleton<NpgsqlDataSource>(Postgres.Configuration.dataSource ())
let _ = builder.Services.AddSingleton<IData> postgres
let _ =
builder.Services.AddSingleton<IDistributedCache>(fun _ ->
Postgres.DistributedCache() :> IDistributedCache)
()
| _ -> ()
let _ = builder.Services.AddSession(fun opts ->
@@ -158,21 +209,37 @@ let rec main args =
| Some it when it = "restore" -> Maintenance.Backup.restoreFromBackup args app.Services
| Some it when it = "do-restore" -> Maintenance.Backup.restoreFromBackup args app.Services
| Some it when it = "upgrade-user" -> Maintenance.upgradeUser args app.Services
| Some it when it = "set-password" -> Maintenance.setPassword args app.Services
| Some it when it = "help" -> showHelp ()
| Some it ->
printfn $"""Unrecognized command "{it}" - valid commands are:"""
showHelp ()
| None ->
| None -> task {
// Load admin and default themes, and all themes in the /themes directory
do! Maintenance.loadTheme [| ""; "./admin-theme.zip" |] app.Services
do! Maintenance.loadTheme [| ""; "./default-theme.zip" |] app.Services
let themePath = Path.Combine(".", "themes")
if Directory.Exists themePath then
for themeFile in Directory.EnumerateFiles(themePath, "*-theme.zip") do
do! Maintenance.loadTheme [| ""; themeFile |] app.Services
let _ = app.UseForwardedHeaders()
(app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value
|> (isNull >> not)
|> function true -> app.UseCanonicalDomains() |> ignore | false -> ()
let _ = app.UseCookiePolicy(CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware>()
let _ = app.UseMiddleware<RedirectRuleMiddleware>()
let _ = app.UseAuthentication()
let _ = app.UseStaticFiles()
let _ = app.UseRouting()
let _ = app.UseSession()
let _ = app.UseGiraffe Handlers.Routes.endpoint
Task.FromResult (app.Run ())
app.Run()
}
|> Async.AwaitTask |> Async.RunSynchronously
0 // Exit code

190
src/MyWebLog/Views/Admin.fs Normal file
View File

@@ -0,0 +1,190 @@
module MyWebLog.Views.Admin
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// The administrator dashboard
let dashboard (themes: Theme list) app = [
let templates = TemplateCache.allNames ()
let cacheBaseUrl = relUrl app "admin/cache/"
let webLogCacheUrl = $"{cacheBaseUrl}web-log/"
let themeCacheUrl = $"{cacheBaseUrl}theme/"
let webLogDetail (webLog: WebLog) =
let refreshUrl = $"{webLogCacheUrl}{webLog.Id}/refresh"
div [ _class "row mwl-table-detail" ] [
div [ _class "col" ] [
txt webLog.Name; br []
small [] [
span [ _class "text-muted" ] [ raw webLog.UrlBase ]; br []
a [ _href refreshUrl; _hxPost refreshUrl ] [ raw "Refresh" ]
]
]
]
let themeDetail (theme: Theme) =
let refreshUrl = $"{themeCacheUrl}{theme.Id}/refresh"
div [ _class "row mwl-table-detail" ] [
div [ _class "col-8" ] [
txt theme.Name; br []
small [] [
span [ _class "text-muted" ] [ txt (string theme.Id); raw " &bull; " ]
a [ _href refreshUrl; _hxPost refreshUrl ] [ raw "Refresh" ]
]
]
div [ _class "col-4" ] [
raw (templates |> List.filter _.StartsWith(string theme.Id) |> List.length |> string)
]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Themes" ]
span [ _hxGet (relUrl app "admin/theme/list"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
]
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Caches" ]
p [ _class "pb-2" ] [
raw "myWebLog uses a few caches to ensure that it serves pages as fast as possible. ("
a [ _href "https://bitbadger.solutions/open-source/myweblog/advanced.html#cache-management"
_target "_blank" ] [
raw "more information"
]; raw ")"
]
div [ _class "row" ] [
div [ _class "col-12 col-lg-6 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-secondary" ] [ raw "Web Logs" ]
div [ _class "card-body pb-0" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
raw "These caches include the page list and categories for each web log"
]
let webLogUrl = $"{cacheBaseUrl}web-log/"
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body"
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [
antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{webLogUrl}all/refresh" ] [
raw "Refresh All"
]
div [ _class "row mwl-table-heading" ] [ div [ _class "col" ] [ raw "Web Log" ] ]
yield! WebLogCache.all () |> List.sortBy _.Name |> List.map webLogDetail
]
]
]
]
div [ _class "col-12 col-lg-6 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-secondary" ] [ raw "Themes" ]
div [ _class "card-body pb-0" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
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"
]
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body"
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [
antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{themeCacheUrl}all/refresh" ] [
raw "Refresh All"
]
div [ _class "row mwl-table-heading" ] [
div [ _class "col-8" ] [ raw "Theme" ]; div [ _class "col-4" ] [ raw "Cached" ]
]
yield! themes |> List.filter (fun t -> t.Id <> ThemeId "admin") |> List.map themeDetail
]
]
]
]
]
]
]
]
/// Display a list of themes
let themeList (model: DisplayTheme list) app =
let themeCol = "col-12 col-md-6"
let slugCol = "d-none d-md-block col-md-3"
let tmplCol = "d-none d-md-block col-md-3"
div [ _id "theme_panel" ] [
a [ _href (relUrl app "admin/theme/new"); _class "btn btn-primary btn-sm mb-3"; _hxTarget "#theme_new" ] [
raw "Upload a New Theme"
]
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class themeCol ] [ raw "Theme" ]
div [ _class slugCol ] [ raw "Slug" ]
div [ _class tmplCol ] [ raw "Templates" ]
]
]
div [ _class "row mwl-table-detail"; _id "theme_new" ] []
form [ _method "post"; _id "themeList"; _class "container g-0"; _hxTarget "#theme_panel"
_hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
for theme in model do
let url = relUrl app $"admin/theme/{theme.Id}"
div [ _class "row mwl-table-detail"; _id $"theme_{theme.Id}" ] [
div [ _class $"{themeCol} no-wrap" ] [
txt theme.Name
if theme.IsInUse then span [ _class "badge bg-primary ms-2" ] [ raw "IN USE" ]
if not theme.IsOnDisk then
span [ _class "badge bg-warning text-dark ms-2" ] [ raw "NOT ON DISK" ]
br []
small [] [
span [ _class "text-muted" ] [ txt $"v{theme.Version}" ]
if not (theme.IsInUse || theme.Id = "default") then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href url; _hxDelete url; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the theme “{theme.Name}”? This action cannot be undone." ] [
raw "Delete"
]
span [ _class "d-md-none text-muted" ] [
br []; raw "Slug: "; txt theme.Id; raw $" &bull; {theme.TemplateCount} Templates"
]
]
]
div [ _class slugCol ] [ txt (string theme.Id) ]
div [ _class tmplCol ] [ txt (string theme.TemplateCount) ]
]
]
]
|> List.singleton
/// Form to allow a theme to be uploaded
let themeUpload app =
div [ _class "col" ] [
h5 [ _class "mt-2" ] [ raw app.PageTitle ]
form [ _action (relUrl app "admin/theme/new"); _method "post"; _class "container"
_enctype "multipart/form-data"; _hxNoBoost ] [
antiCsrf app
div [ _class "row " ] [
div [ _class "col-12 col-sm-6 pb-3" ] [
div [ _class "form-floating" ] [
input [ _type "file"; _id "file"; _name "file"; _class "form-control"; _accept ".zip"
_placeholder "Theme File"; _required ]
label [ _for "file" ] [ raw "Theme File" ]
]
]
div [ _class "col-12 col-sm-6 pb-3 d-flex justify-content-center align-items-center" ] [
div [ _class "form-check form-switch pb-2" ] [
input [ _type "checkbox"; _name "DoOverwrite"; _id "doOverwrite"; _class "form-check-input"
_value "true" ]
label [ _for "doOverwrite"; _class "form-check-label" ] [ raw "Overwrite" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Upload Theme" ]; raw " &nbsp; "
button [ _type "button"; _class "btn btn-sm btn-secondary ms-3"
_onclick "document.getElementById('theme_new').innerHTML = ''" ] [
raw "Cancel"
]
]
]
]
]
|> List.singleton

View File

@@ -0,0 +1,527 @@
[<AutoOpen>]
module MyWebLog.Views.Helpers
open Microsoft.AspNetCore.Antiforgery
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
open NodaTime
open NodaTime.Text
/// The rendering context for this application
[<NoComparison; NoEquality>]
type AppViewContext = {
/// The web log for this request
WebLog: WebLog
/// The ID of the current user
UserId: WebLogUserId option
/// The title of the page being rendered
PageTitle: string
/// The anti-Cross Site Request Forgery (CSRF) token set to use when rendering a form
Csrf: AntiforgeryTokenSet option
/// The page list for the web log
PageList: DisplayPage array
/// Categories and post counts for the web log
Categories: DisplayCategory array
/// The URL of the page being rendered
CurrentPage: string
/// User messages
Messages: UserMessage array
/// The generator string for the rendered page
Generator: string
/// A string to load the minified htmx script
HtmxScript: string
/// Whether the current user is an author
IsAuthor: bool
/// Whether the current user is an editor (implies author)
IsEditor: bool
/// Whether the current user is a web log administrator (implies author and editor)
IsWebLogAdmin: bool
/// Whether the current user is an installation administrator (implies all web log rights)
IsAdministrator: bool
} with
/// Whether there is a user logged on
member this.IsLoggedOn = Option.isSome this.UserId
/// Create a relative URL for the current web log
let relUrl app =
Permalink >> app.WebLog.RelativeUrl
/// Add a hidden input with the anti-Cross Site Request Forgery (CSRF) token
let antiCsrf app =
input [ _type "hidden"; _name app.Csrf.Value.FormFieldName; _value app.Csrf.Value.RequestToken ]
/// Shorthand for encoded text in a template
let txt = encodedText
/// Shorthand for raw text in a template
let raw = rawText
/// Rel attribute to prevent opener information from being provided to the new window
let _relNoOpener = _rel "noopener"
/// The pattern for a long date
let longDatePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("MMMM d, yyyy", DateTimeZoneProviders.Tzdb)
/// Create a long date
let longDate app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj
|> Option.map (fun tz -> longDatePattern.Format(instant.InZone(tz)))
|> Option.defaultValue "--"
|> txt
/// The pattern for a short time
let shortTimePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("h:mmtt", DateTimeZoneProviders.Tzdb)
/// Create a short time
let shortTime app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj
|> Option.map (fun tz -> shortTimePattern.Format(instant.InZone(tz)).ToLowerInvariant())
|> Option.defaultValue "--"
|> txt
/// Display "Yes" or "No" based on the state of a boolean value
let yesOrNo value =
raw (if value then "Yes" else "No")
/// Extract an attribute value from a list of attributes, remove that attribute if it is found
let extractAttrValue name attrs =
let valueAttr = attrs |> List.tryFind (fun x -> match x with KeyValue (key, _) when key = name -> true | _ -> false)
match valueAttr with
| Some (KeyValue (_, value)) ->
Some value,
attrs |> List.filter (fun x -> match x with KeyValue (key, _) when key = name -> false | _ -> true)
| Some _ | None -> None, attrs
/// Create a text input field
let inputField fieldType attrs name labelText value extra =
let fieldId, attrs = extractAttrValue "id" attrs
let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-floating {defaultArg cssClass ""}""" ] [
[ _type fieldType; _name name; _id (defaultArg fieldId name); _class "form-control"; _placeholder labelText
_value value ]
|> List.append attrs
|> input
label [ _for (defaultArg fieldId name) ] [ raw labelText ]
yield! extra
]
/// Create a text input field
let textField attrs name labelText value extra =
inputField "text" attrs name labelText value extra
/// Create a number input field
let numberField attrs name labelText value extra =
inputField "number" attrs name labelText value extra
/// Create an e-mail input field
let emailField attrs name labelText value extra =
inputField "email" attrs name labelText value extra
/// Create a password input field
let passwordField attrs name labelText value extra =
inputField "password" attrs name labelText value extra
/// Create a select (dropdown) field
let selectField<'T, 'a>
attrs name labelText value (values: 'T seq) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra =
let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-floating {defaultArg cssClass ""}""" ] [
select ([ _name name; _id name; _class "form-control" ] |> List.append attrs) [
for item in values do
let itemId = string (idFunc item)
option [ _value itemId; if value = itemId then _selected ] [ raw (displayFunc item) ]
]
label [ _for name ] [ raw labelText ]
yield! extra
]
/// Create a checkbox input styled as a switch
let checkboxSwitch attrs name labelText (value: bool) extra =
let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-check form-switch {defaultArg cssClass ""}""" ] [
[ _type "checkbox"; _name name; _id name; _class "form-check-input"; _value "true"; if value then _checked ]
|> List.append attrs
|> input
label [ _for name; _class "form-check-label" ] [ raw labelText ]
yield! extra
]
/// A standard save button
let saveButton =
button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ]
/// A spacer bullet to use between action links
let actionSpacer =
span [ _class "text-muted" ] [ raw " &bull; " ]
/// Functions for generating content in varying layouts
module Layout =
/// Generate the title tag for a page
let private titleTag (app: AppViewContext) =
title [] [ txt app.PageTitle; raw " &laquo; Admin &laquo; "; txt app.WebLog.Name ]
/// Create a navigation link
let private navLink app name url =
let extraPath = app.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
let active = if app.CurrentPage.StartsWith $"{path}{url}" then " active" else ""
li [ _class "nav-item" ] [
a [ _class $"nav-link{active}"; _href (relUrl app url) ] [ txt name ]
]
/// Create a page view for the given content
let private pageView (content: AppViewContext -> XmlNode list) app = [
header [] [
nav [ _class "navbar navbar-dark bg-dark navbar-expand-md justify-content-start px-2 position-fixed top-0 w-100" ] [
div [ _class "container-fluid" ] [
a [ _class "navbar-brand"; _href (relUrl app ""); _hxNoBoost ] [ txt app.WebLog.Name ]
button [ _type "button"; _class "navbar-toggler"; _data "bs-toggle" "collapse"
_data "bs-target" "#navbarText"; _ariaControls "navbarText"; _ariaExpanded "false"
_ariaLabel "Toggle navigation" ] [
span [ _class "navbar-toggler-icon" ] []
]
div [ _class "collapse navbar-collapse"; _id "navbarText" ] [
if app.IsLoggedOn then
ul [ _class "navbar-nav" ] [
navLink app "Dashboard" "admin/dashboard"
if app.IsAuthor then
navLink app "Pages" "admin/pages"
navLink app "Posts" "admin/posts"
navLink app "Uploads" "admin/uploads"
if app.IsWebLogAdmin then
navLink app "Categories" "admin/categories"
navLink app "Settings" "admin/settings"
if app.IsAdministrator then navLink app "Admin" "admin/administration"
]
ul [ _class "navbar-nav flex-grow-1 justify-content-end" ] [
if app.IsLoggedOn then navLink app "My Info" "admin/my-info"
li [ _class "nav-item" ] [
a [ _class "nav-link"
_href "https://bitbadger.solutions/open-source/myweblog/#how-to-use-myweblog"
_target "_blank" ] [
raw "Docs"
]
]
if app.IsLoggedOn then
li [ _class "nav-item" ] [
a [ _class "nav-link"; _href (relUrl app "user/log-off"); _hxNoBoost ] [
raw "Log Off"
]
]
else
navLink app "Log On" "user/log-on"
]
]
]
]
]
div [ _id "toastHost"; _class "position-fixed top-0 w-100"; _ariaLive "polite"; _ariaAtomic "true" ] [
div [ _id "toasts"; _class "toast-container position-absolute p-3 mt-5 top-0 end-0" ] [
for msg in app.Messages do
let textColor = if msg.Level = "warning" then "" else " text-white"
div [ _class "toast"; _roleAlert; _ariaLive "assertive"; _ariaAtomic "true"
if msg.Level <> "success" then _data "bs-autohide" "false" ] [
div [ _class $"toast-header bg-{msg.Level}{textColor}" ] [
strong [ _class "me-auto text-uppercase" ] [
raw (if msg.Level = "danger" then "error" else msg.Level)
]
button [ _type "button"; _class "btn-close"; _data "bs-dismiss" "toast"
_ariaLabel "Close" ] []
]
div [ _class $"toast-body bg-{msg.Level} bg-opacity-25" ] [
txt msg.Message
if Option.isSome msg.Detail then
hr []
txt msg.Detail.Value
]
]
]
]
main [ _class "mx-3 mt-3" ] [
div [ _class "load-overlay p-5"; _id "loadOverlay" ] [ h1 [ _class "p-3" ] [ raw "Loading&hellip;" ] ]
yield! content app
]
footer [ _class "position-fixed bottom-0 w-100" ] [
div [ _class "text-end text-white me-2" ] [
let version = app.Generator.Split ' '
small [ _class "me-1 align-baseline"] [ raw $"v{version[1]}" ]
img [ _src (relUrl app "themes/admin/logo-light.png"); _alt "myWebLog"; _width "120"; _height "34" ]
]
]
]
/// Render a page with a partial layout (htmx request)
let partial content app =
html [ _lang "en" ] [
titleTag app
yield! pageView content app
]
/// Render a page with a full layout
let full content app =
html [ _lang "en" ] [
meta [ _name "viewport"; _content "width=device-width, initial-scale=1" ]
meta [ _name "generator"; _content app.Generator ]
titleTag app
link [ _rel "stylesheet"; _href "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/css/bootstrap.min.css"
_integrity "sha384-1BmE4kWBq78iYhFldvKuhfTAU6auU8tT94WrHftjDbrCEXSU1oBoqyl2QvZ6jIW3"
_crossorigin "anonymous" ]
link [ _rel "stylesheet"; _href (relUrl app "themes/admin/admin.css") ]
body [ _hxBoost; _hxIndicator "#loadOverlay" ] [
yield! pageView content app
script [ _src "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/js/bootstrap.bundle.min.js"
_integrity "sha384-ka7Sk0Gln4gmtz2MlQnikT1wXgYsOg+OMhuP+IlRH9sENBO0LRn5q+8nbTov4+1p"
_crossorigin "anonymous" ] []
Script.minified
script [ _src (relUrl app "themes/admin/admin.js") ] []
]
]
/// Render a bare layout
let bare (content: AppViewContext -> XmlNode list) app =
html [ _lang "en" ] [
title [] []
yield! content app
]
// ~~ SHARED TEMPLATES BETWEEN POSTS AND PAGES
open Giraffe.Htmx.Common
/// The round-trip instant pattern
let roundTrip = InstantPattern.CreateWithInvariantCulture "uuuu'-'MM'-'dd'T'HH':'mm':'ss'.'fffffff"
/// Capitalize the first letter in the given string
let private capitalize (it: string) =
$"{(string it[0]).ToUpper()}{it[1..]}"
/// The common edit form shared by pages and posts
let commonEdit (model: EditCommonModel) app = [
textField [ _class "mb-3"; _required; _autofocus ] (nameof model.Title) "Title" model.Title []
textField [ _class "mb-3"; _required ] (nameof model.Permalink) "Permalink" model.Permalink [
if not model.IsNew then
let urlBase = relUrl app $"admin/{model.Entity}/{model.Id}"
span [ _class "form-text" ] [
a [ _href $"{urlBase}/permalinks" ] [ raw "Manage Permalinks" ]; actionSpacer
a [ _href $"{urlBase}/revisions" ] [ raw "Manage Revisions" ]
if model.IncludeChapterLink then
span [ _id "chapterEditLink" ] [
actionSpacer; a [ _href $"{urlBase}/chapters" ] [ raw "Manage Chapters" ]
]
]
]
div [ _class "mb-2" ] [
label [ _for "text" ] [ raw "Text" ]; raw " &nbsp; &nbsp; "
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"
_value "HTML"; if model.Source = "HTML" then _checked ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "source_html" ] [ raw "HTML" ]
input [ _type "radio"; _name (nameof model.Source); _id "source_md"; _class "btn-check"
_value "Markdown"; if model.Source = "Markdown" then _checked ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "source_md" ] [ raw "Markdown" ]
]
]
div [ _class "mb-3" ] [
textarea [ _name (nameof model.Text); _id (nameof model.Text); _class "form-control"; _rows "20" ] [
raw model.Text
]
]
]
/// Display a common template list
let commonTemplates (model: EditCommonModel) (templates: MetaItem seq) =
selectField [ _class "mb-3" ] (nameof model.Template) $"{capitalize model.Entity} Template" model.Template templates
(_.Name) (_.Value) []
/// Display the metadata item edit form
let commonMetaItems (model: EditCommonModel) =
let items = Array.zip model.MetaNames model.MetaValues
let metaDetail idx (name, value) =
div [ _id $"meta_%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({idx})" ] [
raw "&minus;"
]
]
div [ _class "col-3" ] [ textField [ _id $"MetaNames_{idx}" ] (nameof model.MetaNames) "Name" name [] ]
div [ _class "col-8" ] [ textField [ _id $"MetaValues_{idx}" ] (nameof model.MetaValues) "Value" value [] ]
]
fieldset [] [
legend [] [
raw "Metadata "
button [ _type "button"; _class "btn btn-sm btn-secondary"; _data "bs-toggle" "collapse"
_data "bs-target" "#meta_item_container" ] [
raw "show"
]
]
div [ _id "meta_item_container"; _class "collapse" ] [
div [ _id "meta_items"; _class "container" ] (items |> Array.mapi metaDetail |> List.ofArray)
button [ _type "button"; _class "btn btn-sm btn-secondary"; _onclick "Admin.addMetaItem()" ] [
raw "Add an Item"
]
script [] [
raw """document.addEventListener("DOMContentLoaded", """
raw $"() => Admin.setNextMetaIndex({items.Length}))"
]
]
]
/// Revision preview template
let commonPreview (rev: Revision) app =
div [ _class "mwl-revision-preview mb-3" ] [
rev.Text.AsHtml() |> addBaseToRelativeUrls app.WebLog.ExtraPath |> raw
]
|> List.singleton
/// Form to manage permalinks for pages or posts
let managePermalinks (model: ManagePermalinksModel) app = [
let baseUrl = relUrl app $"admin/{model.Entity}/"
let linkDetail idx link =
div [ _id $"link_%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.removePermalink({idx})" ] [
raw "&minus;"
]
]
div [ _class "col-11" ] [
div [ _class "form-floating" ] [
input [ _type "text"; _name "Prior"; _id $"prior_{idx}"; _class "form-control"; _placeholder "Link"
_value link ]
label [ _for $"prior_{idx}" ] [ raw "Link" ]
]
]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action $"{baseUrl}permalinks"; _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row" ] [
div [ _class "col" ] [
p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.CurrentTitle ]; br []
small [ _class "text-muted" ] [
span [ _class "fst-italic" ] [ txt model.CurrentPermalink ]; br []
a [ _href $"{baseUrl}{model.Id}/edit" ] [
raw $"&laquo; Back to Edit {capitalize model.Entity}"
]
]
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col" ] [
button [ _type "button"; _class "btn btn-sm btn-secondary"; _onclick "Admin.addPermalink()" ] [
raw "Add a Permalink"
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col" ] [
div [ _id "permalinks"; _class "container g-0" ] [
yield! Array.mapi linkDetail model.Prior
script [] [
raw """document.addEventListener("DOMContentLoaded", """
raw $"() => Admin.setPermalinkIndex({model.Prior.Length}))"
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col " ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ]
]
]
]
]
]
/// Form to manage revisions for pages or posts
let manageRevisions (model: ManageRevisionsModel) app = [
let revUrlBase = relUrl app $"admin/{model.Entity}/{model.Id}/revision"
let revDetail idx (rev: Revision) =
let asOfString = roundTrip.Format rev.AsOf
let asOfId = $"""rev_{asOfString.Replace(".", "_").Replace(":", "-")}"""
div [ _id asOfId; _class "row pb-3 mwl-table-detail" ] [
div [ _class "col-12 mb-1" ] [
longDate app rev.AsOf; raw " at "; shortTime app rev.AsOf; raw " "
span [ _class "badge bg-secondary text-uppercase ms-2" ] [ txt (string rev.Text.SourceType) ]
if idx = 0 then span [ _class "badge bg-primary text-uppercase ms-2" ] [ raw "Current Revision" ]
br []
if idx > 0 then
let revUrlPrefix = $"{revUrlBase}/{asOfString}"
let revRestore = $"{revUrlPrefix}/restore"
small [] [
a [ _href $"{revUrlPrefix}/preview"; _hxTarget $"#{asOfId}_preview" ] [ raw "Preview" ]
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href revRestore; _hxPost revRestore ] [ raw "Restore as Current" ]
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href revUrlPrefix; _hxDelete revUrlPrefix; _hxTarget $"#{asOfId}"
_hxSwap HxSwap.OuterHtml; _class "text-danger" ] [
raw "Delete"
]
]
]
if idx > 0 then div [ _id $"{asOfId}_preview"; _class "col-12" ] []
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _method "post"; _hxTarget "body"; _class "container mb-3" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row" ] [
div [ _class "col" ] [
p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.CurrentTitle ]; br []
small [ _class "text-muted" ] [
a [ _href (relUrl app $"admin/{model.Entity}/{model.Id}/edit") ] [
raw $"&laquo; Back to Edit {(string model.Entity[0]).ToUpper()}{model.Entity[1..]}"
]
]
]
]
]
if model.Revisions.Length > 1 then
div [ _class "row mb-3" ] [
div [ _class "col" ] [
button [ _type "button"; _class "btn btn-sm btn-danger"; _hxDelete $"{revUrlBase}s"
_hxConfirm "This will remove all revisions but the current one; are you sure this is what you wish to do?" ] [
raw "Delete All Prior Revisions"
]
]
]
div [ _class "row mwl-table-heading" ] [ div [ _class "col" ] [ raw "Revision" ] ]
yield! List.mapi revDetail model.Revisions
]
]
]

105
src/MyWebLog/Views/Page.fs Normal file
View File

@@ -0,0 +1,105 @@
module MyWebLog.Views.Page
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// The form to edit pages
let pageEdit (model: EditPageModel) templates app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/page/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [
div [ _class "col-9" ] (commonEdit model app)
div [ _class "col-3" ] [
commonTemplates model templates
checkboxSwitch [] (nameof model.IsShownInPageList) "Show in Page List" model.IsShownInPageList []
]
]
div [ _class "row mb-3" ] [ div [ _class "col" ] [ saveButton ] ]
div [ _class "row mb-3" ] [ div [ _class "col" ] [ commonMetaItems model ] ]
]
]
]
/// Display a list of pages for this web log
let pageList (pages: DisplayPage list) pageNbr hasNext app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/page/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Create a New Page" ]
if pages.Length = 0 then
p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no pages" ]
else
let titleCol = "col-12 col-md-5"
let linkCol = "col-12 col-md-5"
let upd8Col = "col-12 col-md-2"
form [ _method "post"; _class "container mb-3"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row mwl-table-heading" ] [
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
let pageLink = if pg.IsDefault then "" else pg.Permalink
div [ _class "row mwl-table-detail" ] [
div [ _class titleCol ] [
txt pg.Title
if pg.IsDefault then
raw " &nbsp; "; span [ _class "badge bg-success" ] [ raw "HOME PAGE" ]
if pg.IsInPageList then
raw " &nbsp; "; span [ _class "badge bg-primary" ] [ raw "IN PAGE LIST" ]
br [] ; small [] [
let adminUrl = relUrl app $"admin/page/{pg.Id}"
a [ _href (relUrl app pageLink); _target "_blank" ] [ raw "View Page" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId pg.AuthorId) then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href $"{adminUrl}/edit" ] [ raw "Edit" ]
if app.IsWebLogAdmin then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href adminUrl; _hxDelete adminUrl; _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") ]
]
]
]
if pageNbr > 1 || hasNext then
div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [
if pageNbr > 1 then
let prevPage = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
p [] [
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages{prevPage}") ] [
raw "&laquo; Previous"
]
]
]
div [ _class "text-right" ] [
if hasNext then
p [] [
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages/page/{pageNbr + 1}") ] [
raw "Next &raquo;"
]
]
]
]
]
]

524
src/MyWebLog/Views/Post.fs Normal file
View File

@@ -0,0 +1,524 @@
module MyWebLog.Views.Post
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
open NodaTime.Text
/// The pattern for chapter start times
let startTimePattern = DurationPattern.CreateWithInvariantCulture "H:mm:ss.FF"
/// The form to add or edit a chapter
let chapterEdit (model: EditChapterModel) app = [
let postUrl = relUrl app $"admin/post/{model.PostId}/chapter/{model.Index}"
h3 [ _class "my-3" ] [ raw (if model.Index < 0 then "Add" else "Edit"); raw " Chapter" ]
p [ _class "form-text" ] [
raw "Times may be entered as seconds; minutes and seconds; or hours, minutes and seconds. Fractional seconds "
raw "are supported to two decimal places."
]
form [ _method "post"; _action postUrl; _hxPost postUrl; _hxTarget "#chapter_list"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "PostId"; _value model.PostId ]
input [ _type "hidden"; _name "Index"; _value (string model.Index) ]
div [ _class "row" ] [
div [ _class "col-6 col-lg-3 mb-3" ] [
textField [ _required; _autofocus ] (nameof model.StartTime) "Start Time"
(if model.Index < 0 then "" else model.StartTime) []
]
div [ _class "col-6 col-lg-3 mb-3" ] [
textField [] (nameof model.EndTime) "End Time" model.EndTime [
span [ _class "form-text" ] [ raw "Optional; ends when next starts" ]
]
]
div [ _class "col-12 col-lg-6 mb-3" ] [
textField [] (nameof model.Title) "Chapter Title" model.Title [
span [ _class "form-text" ] [ raw "Optional" ]
]
]
div [ _class "col-12 col-lg-6 col-xl-5 mb-3" ] [
textField [] (nameof model.ImageUrl) "Image URL" model.ImageUrl [
span [ _class "form-text" ] [
raw "Optional; a separate image to display while this chapter is playing"
]
]
]
div [ _class "col-12 col-lg-6 col-xl-5 mb-3" ] [
textField [] (nameof model.Url) "URL" model.Url [
span [ _class "form-text" ] [ raw "Optional; informational link for this chapter" ]
]
]
div [ _class "col-12 col-lg-6 offset-lg-3 col-xl-2 offset-xl-0 mb-3 align-self-end d-flex flex-column" ] [
checkboxSwitch [] (nameof model.IsHidden) "Hidden Chapter" model.IsHidden []
span [ _class "mt-2 form-text" ] [ raw "Not displayed, but may update image and location" ]
]
]
div [ _class "row" ] [
let hasLoc, attrs = if model.LocationName = "" then false, [ _disabled ] else true, []
div [ _class "col-12 col-md-4 col-lg-3 offset-lg-1 mb-3 align-self-end" ] [
checkboxSwitch [ _onclick "Admin.checkChapterLocation()" ] "has_location" "Associate Location" hasLoc []
]
div [ _class "col-12 col-md-8 col-lg-6 offset-lg-1 mb-3" ] [
textField (_required :: attrs) (nameof model.LocationName) "Name" model.LocationName []
]
div [ _class "col-6 col-lg-4 offset-lg-2 mb-3" ] [
textField (_required :: attrs) (nameof model.LocationGeo) "Geo URL" model.LocationGeo [
em [ _class "form-text" ] [
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/location/location.md#geo-recommended"
_target "_blank"; _relNoOpener ] [
raw "see spec"
]
]
]
]
div [ _class "col-6 col-lg-4 mb-3" ] [
textField attrs (nameof model.LocationOsm) "OpenStreetMap ID" model.LocationOsm [
em [ _class "form-text" ] [
raw "Optional; "
a [ _href "https://www.openstreetmap.org/"; _target "_blank"; _relNoOpener ] [ raw "get ID" ]
raw ", "
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/location/location.md#osm-recommended"
_target "_blank"; _relNoOpener ] [
raw "see spec"
]
]
]
]
]
div [ _class "row" ] [
div [ _class "col" ] [
let cancelLink = relUrl app $"admin/post/{model.PostId}/chapters"
if model.Index < 0 then
checkboxSwitch [ _checked ] (nameof model.AddAnother) "Add Another New Chapter" true []
else
input [ _type "hidden"; _name "AddAnother"; _value "false" ]
saveButton; raw " &nbsp; "
a [ _href cancelLink; _hxGet cancelLink; _class "btn btn-secondary"; _hxTarget "body" ] [ raw "Cancel" ]
]
]
]
]
/// Display a list of chapters
let chapterList withNew (model: ManageChaptersModel) app =
form [ _method "post"; _id "chapter_list"; _class "container mb-3"; _hxTarget "this"; _hxSwap HxSwap.OuterHtml ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row mwl-table-heading" ] [
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-2 col-lg-1 text-center" ] [ raw "Image?" ]
div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ raw "Location?" ]
]
yield! model.Chapters |> List.mapi (fun idx chapter ->
div [ _class "row mwl-table-detail"; _id $"chapter{idx}" ] [
div [ _class "col-3 col-md-2" ] [ txt (startTimePattern.Format chapter.StartTime) ]
div [ _class "col-3 col-md-6 col-lg-8" ] [
match chapter.Title with
| Some title -> txt title
| None -> em [ _class "text-muted" ] [ raw "no title" ]
br []
small [] [
if withNew then
raw "&nbsp;"
else
let chapterUrl = relUrl app $"admin/post/{model.Id}/chapter/{idx}"
a [ _href chapterUrl; _hxGet chapterUrl; _hxTarget $"#chapter{idx}"
_hxSwap $"{HxSwap.InnerHtml} show:#chapter{idx}:top" ] [
raw "Edit"
]
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href chapterUrl; _hxDelete chapterUrl; _class "text-danger" ] [
raw "Delete"
]
]
]
div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ yesOrNo (Option.isSome chapter.ImageUrl) ]
div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ yesOrNo (Option.isSome chapter.Location) ]
])
div [ _class "row pb-3"; _id "chapter-1" ] [
let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1"
if withNew then
span [ _hxGet newLink; _hxTarget "#chapter-1"; _hxTrigger "load"; _hxSwap "show:#chapter-1:top" ] []
else
div [ _class "row pb-3 mwl-table-detail" ] [
div [ _class "col-12" ] [
a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1"
_hxSwap "show:#chapter-1:top" ] [
raw "Add a New Chapter"
]
]
]
]
]
|> List.singleton
/// Manage Chapters page
let chapters withNew (model: ManageChaptersModel) app = [
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.Title ]; br []
small [ _class "text-muted" ] [
a [ _href (relUrl app $"admin/post/{model.Id}/edit") ] [
raw "&laquo; Back to Edit Post"
]
]
]
yield! chapterList withNew model app
]
]
/// Display a list of posts
let list (model: PostDisplay) app = [
let dateCol = "col-xs-12 col-md-3 col-lg-2"
let titleCol = "col-xs-12 col-md-7 col-lg-6 col-xl-5 col-xxl-4"
let authorCol = "col-xs-12 col-md-2 col-lg-1"
let tagCol = "col-lg-3 col-xl-4 col-xxl-5 d-none d-lg-inline-block"
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/post/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Write a New Post" ]
if model.Posts.Length > 0 then
form [ _method "post"; _class "container mb-3"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row mwl-table-heading" ] [
div [ _class dateCol ] [
span [ _class "d-md-none" ] [ raw "Post" ]; span [ _class "d-none d-md-inline" ] [ raw "Date" ]
]
div [ _class $"{titleCol} d-none d-md-inline-block" ] [ raw "Title" ]
div [ _class $"{authorCol} d-none d-md-inline-block" ] [ raw "Author" ]
div [ _class tagCol ] [ raw "Tags" ]
]
for post in model.Posts do
div [ _class "row mwl-table-detail" ] [
div [ _class $"{dateCol} no-wrap" ] [
small [ _class "d-md-none" ] [
if post.PublishedOn.HasValue then
raw "Published "; txt (post.PublishedOn.Value.ToString "MMMM d, yyyy")
else raw "Not Published"
if post.PublishedOn.HasValue && post.PublishedOn.Value <> post.UpdatedOn then
em [ _class "text-muted" ] [
raw " (Updated "; txt (post.UpdatedOn.ToString "MMMM d, yyyy"); raw ")"
]
]
span [ _class "d-none d-md-inline" ] [
if post.PublishedOn.HasValue then txt (post.PublishedOn.Value.ToString "MMMM d, yyyy")
else raw "Not Published"
if not post.PublishedOn.HasValue || post.PublishedOn.Value <> post.UpdatedOn then
br []
small [ _class "text-muted" ] [
em [] [ txt (post.UpdatedOn.ToString "MMMM d, yyyy") ]
]
]
]
div [ _class titleCol ] [
if Option.isSome post.Episode then
span [ _class "badge bg-success float-end text-uppercase mt-1" ] [ raw "Episode" ]
raw post.Title; br []
small [] [
let postUrl = relUrl app $"admin/post/{post.Id}"
a [ _href (relUrl app post.Permalink); _target "_blank" ] [ raw "View Post" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId post.AuthorId) then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href $"{postUrl}/edit" ] [ raw "Edit" ]
if app.IsWebLogAdmin then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href postUrl; _hxDelete postUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the post “{post.Title}”? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class authorCol ] [
let author =
model.Authors
|> List.tryFind (fun a -> a.Name = post.AuthorId)
|> Option.map _.Value
|> Option.defaultValue "--"
|> txt
small [ _class "d-md-none" ] [
raw "Authored by "; author; raw " | "
raw (if post.Tags.Length = 0 then "No" else string post.Tags.Length)
raw " Tag"; if post.Tags.Length <> 0 then raw "s"
]
span [ _class "d-none d-md-inline" ] [ author ]
]
div [ _class tagCol ] [
let tags =
post.Tags |> List.mapi (fun idx tag -> idx, span [ _class "no-wrap" ] [ txt tag ])
for tag in tags do
snd tag
if fst tag < tags.Length - 1 then raw ", "
]
]
]
if Option.isSome model.NewerLink || Option.isSome model.OlderLink then
div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [
if Option.isSome model.NewerLink then
p [] [
a [ _href model.NewerLink.Value; _class "btn btn-secondary"; ] [
raw "&laquo; Newer Posts"
]
]
]
div [ _class "text-right" ] [
if Option.isSome model.OlderLink then
p [] [
a [ _href model.OlderLink.Value; _class "btn btn-secondary" ] [
raw "Older Posts &raquo;"
]
]
]
]
else
p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no posts" ]
]
]
let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/post/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-lg-9" ] [
yield! commonEdit model app
textField [ _class "mb-3" ] (nameof model.Tags) "Tags" model.Tags [
div [ _class "form-text" ] [ raw "comma-delimited" ]
]
if model.Status = string Draft then
checkboxSwitch [ _class "mb-2" ] (nameof model.DoPublish) "Publish This Post" model.DoPublish []
saveButton
hr [ _class "mb-3" ]
fieldset [ _class "mb-3" ] [
legend [] [
span [ _class "form-check form-switch" ] [
small [] [
input [ _type "checkbox"; _name (nameof model.IsEpisode)
_id (nameof model.IsEpisode); _class "form-check-input"; _value "true"
_data "bs-toggle" "collapse"; _data "bs-target" "#episode_items"
_onclick "Admin.toggleEpisodeFields()"; if model.IsEpisode then _checked ]
]
label [ _for (nameof model.IsEpisode) ] [ raw "Podcast Episode" ]
]
]
div [ _id "episode_items"
_class $"""container p-0 collapse{if model.IsEpisode then " show" else ""}""" ] [
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [ _required ] (nameof model.Media) "Media File" model.Media [
div [ _class "form-text" ] [
raw "Relative URL will be appended to base media path (if set) "
raw "or served from this web log"
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [] (nameof model.MediaType) "Media MIME Type" model.MediaType [
div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
numberField [ _required ] (nameof model.Length) "Media Length (bytes)"
(string model.Length) [
div [ _class "form-text" ] [ raw "TODO: derive from above file name" ]
]
]
div [ _class "col" ] [
textField [] (nameof model.Duration) "Duration" model.Duration [
div [ _class "form-text" ] [
raw "Recommended; enter in "; code [] [ raw "HH:MM:SS"]; raw " format"
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
textField [] (nameof model.Subtitle) "Subtitle" model.Subtitle [
div [ _class "form-text" ] [ raw "Optional; a subtitle for this episode" ]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [] (nameof model.ImageUrl) "Image URL" model.ImageUrl [
div [ _class "form-text" ] [
raw "Optional; overrides podcast default; "
raw "relative URL served from this web log"
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
selectField [] (nameof model.Explicit) "Explicit Rating" model.Explicit ratings
(_.Name) (_.Value) [
div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
div [ _class "form-text" ] [ raw "Chapters" ]
div [ _class "form-check form-check-inline" ] [
input [ _type "radio"; _name (nameof model.ChapterSource)
_id "chapter_source_none"; _value "none"; _class "form-check-input"
if model.ChapterSource = "none" then _checked
_onclick "Admin.setChapterSource('none')" ]
label [ _for "chapter_source_none" ] [ raw "None" ]
]
div [ _class "form-check form-check-inline" ] [
input [ _type "radio"; _name (nameof model.ChapterSource)
_id "chapter_source_internal"; _value "internal"
_class "form-check-input"
if model.ChapterSource= "internal" then _checked
_onclick "Admin.setChapterSource('internal')" ]
label [ _for "chapter_source_internal" ] [ raw "Defined Here" ]
]
div [ _class "form-check form-check-inline" ] [
input [ _type "radio"; _name (nameof model.ChapterSource)
_id "chapter_source_external"; _value "external"
_class "form-check-input"
if model.ChapterSource = "external" then _checked
_onclick "Admin.setChapterSource('external')" ]
label [ _for "chapter_source_external" ] [ raw "Separate File" ]
]
]
div [ _class "col-md-4 d-flex justify-content-center" ] [
checkboxSwitch [ _class "align-self-center pb-3" ] (nameof model.ContainsWaypoints)
"Chapters contain waypoints" model.ContainsWaypoints []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [] (nameof model.ChapterFile) "Chapter File" model.ChapterFile [
div [ _class "form-text" ] [ raw "Relative URL served from this web log" ]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [] (nameof model.ChapterType) "Chapter MIME Type" model.ChapterType [
div [ _class "form-text" ] [
raw "Optional; "; code [] [ raw "application/json+chapters" ]
raw " assumed if chapter file ends with "; code [] [ raw ".json" ]
]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [ _onkeyup "Admin.requireTranscriptType()" ] (nameof model.TranscriptUrl)
"Transcript URL" model.TranscriptUrl [
div [ _class "form-text" ] [
raw "Optional; relative URL served from this web log"
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [ if model.TranscriptUrl <> "" then _required ]
(nameof model.TranscriptType) "Transcript MIME Type"
model.TranscriptType [
div [ _class "form-text" ] [ raw "Required if transcript URL provided" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
textField [] (nameof model.TranscriptLang) "Transcript Language"
model.TranscriptLang [
div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ]
]
]
div [ _class "col d-flex justify-content-center" ] [
checkboxSwitch [ _class "align-self-center pb-3" ] (nameof model.TranscriptCaptions)
"This is a captions file" model.TranscriptCaptions []
]
]
div [ _class "row pb-3" ] [
div [ _class "col col-md-4" ] [
numberField [] (nameof model.SeasonNumber) "Season Number"
(string model.SeasonNumber) [
div [ _class "form-text" ] [ raw "Optional" ]
]
]
div [ _class "col col-md-8" ] [
textField [ _maxlength "128" ] (nameof model.SeasonDescription) "Season Description"
model.SeasonDescription [
div [ _class "form-text" ] [ raw "Optional" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col col-md-4" ] [
numberField [ _step "0.01" ] (nameof model.EpisodeNumber) "Episode Number"
model.EpisodeNumber [
div [ _class "form-text" ] [ raw "Optional; up to 2 decimal points" ]
]
]
div [ _class "col col-md-8" ] [
textField [ _maxlength "128" ] (nameof model.EpisodeDescription)
"Episode Description" model.EpisodeDescription [
div [ _class "form-text" ] [ raw "Optional" ]
]
]
]
]
script [] [
raw """document.addEventListener("DOMContentLoaded", () => Admin.toggleEpisodeFields())"""
]
]
commonMetaItems model
if model.Status = string Published then
fieldset [ _class "pb-3" ] [
legend [] [ raw "Maintenance" ]
div [ _class "container" ] [
div [ _class "row" ] [
div [ _class "col align-self-center" ] [
checkboxSwitch [ _class "pb-2" ] (nameof model.SetPublished)
"Set Published Date" model.SetPublished []
]
div [ _class "col-4" ] [
div [ _class "form-floating" ] [
input [ _type "datetime-local"; _name (nameof model.PubOverride)
_id (nameof model.PubOverride); _class "form-control"
_placeholder "Override Date"
if model.PubOverride.HasValue then
_value (model.PubOverride.Value.ToString "yyyy-MM-dd\THH:mm") ]
label [ _for (nameof model.PubOverride); _class "form-label" ] [
raw "Published On"
]
]
]
div [ _class "col-5 align-self-center" ] [
checkboxSwitch [ _class "pb-2" ] (nameof model.SetUpdated)
"Purge revisions and<br>set as updated date as well"
model.SetUpdated []
]
]
]
]
]
div [ _class "col-12 col-lg-3" ] [
commonTemplates model templates
fieldset [] [
legend [] [ raw "Categories" ]
for cat in app.Categories do
div [ _class "form-check" ] [
input [ _type "checkbox"; _name (nameof model.CategoryIds); _id $"category_{cat.Id}"
_class "form-check-input"; _value cat.Id
if model.CategoryIds |> Array.contains cat.Id then _checked ]
label [ _for $"category_{cat.Id}"; _class "form-check-label"
match cat.Description with Some it -> _title it | None -> () ] [
yield! cat.ParentNames |> Array.map (fun _ -> raw "&nbsp; &rang; &nbsp;")
txt cat.Name
]
]
]
]
]
]
]
script [] [ raw "window.setTimeout(() => Admin.toggleEpisodeFields(), 500)" ]
]

258
src/MyWebLog/Views/User.fs Normal file
View File

@@ -0,0 +1,258 @@
module MyWebLog.Views.User
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// User edit form
let edit (model: EditUserModel) app =
let levelOption value name =
option [ _value value; if model.AccessLevel = value then _selected ] [ txt name ]
div [ _class "col-12" ] [
h5 [ _class "my-3" ] [ txt app.PageTitle ]
form [ _hxPost (relUrl app "admin/settings/user/save"); _method "post"; _class "container"
_hxTarget "#user_panel"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row" ] [
div [ _class "col-12 col-md-5 col-lg-3 col-xxl-2 offset-xxl-1 mb-3" ] [
div [ _class "form-floating" ] [
select [ _name "AccessLevel"; _id "accessLevel"; _class "form-control"; _required
_autofocus ] [
levelOption (string Author) "Author"
levelOption (string Editor) "Editor"
levelOption (string WebLogAdmin) "Web Log Admin"
if app.IsAdministrator then levelOption (string Administrator) "Administrator"
]
label [ _for "accessLevel" ] [ raw "Access Level" ]
]
]
div [ _class "col-12 col-md-7 col-lg-4 col-xxl-3 mb-3" ] [
emailField [ _required ] (nameof model.Email) "E-mail Address" model.Email []
]
div [ _class "col-12 col-lg-5 mb-3" ] [
textField [] (nameof model.Url) "User&rsquo;s Personal URL" model.Url []
]
]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-md-6 col-lg-4 col-xl-3 offset-xl-1 pb-3" ] [
textField [ _required ] (nameof model.FirstName) "First Name" model.FirstName []
]
div [ _class "col-12 col-md-6 col-lg-4 col-xl-3 pb-3" ] [
textField [ _required ] (nameof model.LastName) "Last Name" model.LastName []
]
div [ _class "col-12 col-md-6 offset-md-3 col-lg-4 offset-lg-0 col-xl-3 offset-xl-1 pb-3" ] [
textField [ _required ] (nameof model.PreferredName) "Preferred Name" model.PreferredName []
]
]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-xl-10 offset-xl-1" ] [
fieldset [ _class "p-2" ] [
legend [ _class "ps-1" ] [
if not model.IsNew then raw "Change "
raw "Password"
]
if not model.IsNew then
div [ _class "row" ] [
div [ _class "col" ] [
p [ _class "form-text" ] [
raw "Optional; leave blank not change the user&rsquo;s password"
]
]
]
div [ _class "row" ] [
let attrs, newLbl = if model.IsNew then [ _required ], "" else [], "New "
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField attrs (nameof model.Password) $"{newLbl}Password" "" []
]
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField attrs (nameof model.PasswordConfirm) $"Confirm {newLbl}Password" "" []
]
]
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton; raw " &nbsp; "
if model.IsNew then
button [ _type "button"; _class "btn btn-sm btn-secondary ms-3"
_onclick "document.getElementById('user_new').innerHTML = ''" ] [
raw "Cancel"
]
else
a [ _href (relUrl app "admin/settings/users"); _class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel"
]
]
]
]
]
|> List.singleton
/// User log on form
let logOn (model: LogOnModel) (app: AppViewContext) = [
h2 [ _class "my-3" ] [ rawText "Log On to "; encodedText app.WebLog.Name ]
article [ _class "py-3" ] [
form [ _action (relUrl app "user/log-on"); _method "post"; _class "container"; _hxPushUrl "true" ] [
antiCsrf app
if Option.isSome model.ReturnTo then input [ _type "hidden"; _name "ReturnTo"; _value model.ReturnTo.Value ]
div [ _class "row" ] [
div [ _class "col-12 col-md-6 col-lg-4 offset-lg-2 pb-3" ] [
emailField [ _required; _autofocus ] (nameof model.EmailAddress) "E-mail Address" "" []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
passwordField [ _required ] (nameof model.Password) "Password" "" []
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ rawText "Log On" ]
]
]
]
]
]
/// The list of users for a web log (part of web log settings page)
let userList (model: WebLogUser list) app =
let userCol = "col-12 col-md-4 col-xl-3"
let emailCol = "col-12 col-md-4 col-xl-4"
let cre8Col = "d-none d-xl-block col-xl-2"
let lastCol = "col-12 col-md-4 col-xl-3"
let badge = "ms-2 badge bg"
let userDetail (user: WebLogUser) =
div [ _class "row mwl-table-detail"; _id $"user_{user.Id}" ] [
div [ _class $"{userCol} no-wrap" ] [
txt user.PreferredName; raw " "
match user.AccessLevel with
| Administrator -> span [ _class $"{badge}-success" ] [ raw "ADMINISTRATOR" ]
| WebLogAdmin -> span [ _class $"{badge}-primary" ] [ raw "WEB LOG ADMIN" ]
| Editor -> span [ _class $"{badge}-secondary" ] [ raw "EDITOR" ]
| Author -> span [ _class $"{badge}-dark" ] [ raw "AUTHOR" ]
br []
if app.IsAdministrator || (app.IsWebLogAdmin && not (user.AccessLevel = Administrator)) then
let userUrl = relUrl app $"admin/settings/user/{user.Id}"
small [] [
a [ _href $"{userUrl}/edit"; _hxTarget $"#user_{user.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#user_{user.Id}:top" ] [
raw "Edit"
]
if app.UserId.Value <> user.Id then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href userUrl; _hxDelete userUrl; _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.)" ] [
raw "Delete"
]
]
]
div [ _class emailCol ] [
txt $"{user.FirstName} {user.LastName}"; br []
small [ _class "text-muted" ] [
txt user.Email
if Option.isSome user.Url then
br []; txt user.Url.Value
]
]
div [ _class "d-none d-xl-block col-xl-2" ] [
if user.CreatedOn = Noda.epoch then raw "N/A" else longDate app user.CreatedOn
]
div [ _class "col-12 col-md-4 col-xl-3" ] [
match user.LastSeenOn with
| Some it -> longDate app it; raw " at "; shortTime app it
| None -> raw "--"
]
]
div [ _id "user_panel" ] [
a [ _href (relUrl app "admin/settings/user/new/edit"); _class "btn btn-primary btn-sm mb-3"
_hxTarget "#user_new" ] [
raw "Add a New User"
]
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class userCol ] [
raw "User"; span [ _class "d-md-none" ] [ raw "; Full Name / E-mail; Last Log On" ]
]
div [ _class $"{emailCol} d-none d-md-inline-block" ] [ raw "Full Name / E-mail" ]
div [ _class cre8Col ] [ raw "Created" ]
div [ _class $"{lastCol} d-none d-md-block" ] [ raw "Last Log On" ]
]
]
div [ _id "userList" ] [
div [ _class "container g-0" ] [
div [ _class "row mwl-table-detail"; _id "user_new" ] []
]
form [ _method "post"; _class "container g-0"; _hxTarget "#user_panel"
_hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
yield! List.map userDetail model
]
]
]
|> List.singleton
/// Edit My Info form
let myInfo (model: EditMyInfoModel) (user: WebLogUser) app = [
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/my-info"); _method "post" ] [
antiCsrf app
div [ _class "d-flex flex-row flex-wrap justify-content-around" ] [
div [ _class "text-center mb-3 lh-sm" ] [
strong [ _class "text-decoration-underline" ] [ raw "Access Level" ]; br []
raw (string user.AccessLevel)
]
div [ _class "text-center mb-3 lh-sm" ] [
strong [ _class "text-decoration-underline" ] [ raw "Created" ]; br []
if user.CreatedOn = Noda.epoch then raw "N/A" else longDate app user.CreatedOn
]
div [ _class "text-center mb-3 lh-sm" ] [
strong [ _class "text-decoration-underline" ] [ raw "Last Log On" ]; br []
longDate app user.LastSeenOn.Value; raw " at "; shortTime app user.LastSeenOn.Value
]
]
div [ _class "container" ] [
div [ _class "row" ] [ div [ _class "col" ] [ hr [ _class "mt-0" ] ] ]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
textField [ _required; _autofocus ] (nameof model.FirstName) "First Name" model.FirstName []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
textField [ _required ] (nameof model.LastName) "Last Name" model.LastName []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
textField [ _required ] (nameof model.PreferredName) "Preferred Name" model.PreferredName []
]
]
div [ _class "row mb-3" ] [
div [ _class "col" ] [
fieldset [ _class "p-2" ] [
legend [ _class "ps-1" ] [ raw "Change Password" ]
div [ _class "row" ] [
div [ _class "col" ] [
p [ _class "form-text" ] [
raw "Optional; leave blank to keep your current password"
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField [] (nameof model.NewPassword) "New Password" "" []
]
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField [] (nameof model.NewPasswordConfirm) "Confirm New Password" "" []
]
]
]
]
]
div [ _class "row" ] [ div [ _class "col text-center mb-3" ] [ saveButton ] ]
]
]
]
]

View File

@@ -0,0 +1,895 @@
module MyWebLog.Views.WebLog
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// Form to add or edit a category
let categoryEdit (model: EditCategoryModel) app =
div [ _class "col-12" ] [
h5 [ _class "my-3" ] [ raw app.PageTitle ]
form [ _action (relUrl app "admin/category/save"); _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.CategoryId); _value model.CategoryId ]
div [ _class "row" ] [
div [ _class "col-12 col-sm-6 col-lg-4 col-xxl-3 offset-xxl-1 mb-3" ] [
textField [ _required; _autofocus ] (nameof model.Name) "Name" model.Name []
]
div [ _class "col-12 col-sm-6 col-lg-4 col-xxl-3 mb-3" ] [
textField [ _required ] (nameof model.Slug) "Slug" model.Slug []
]
div [ _class "col-12 col-lg-4 col-xxl-3 offset-xxl-1 mb-3" ] [
let cats =
app.Categories
|> Seq.ofArray
|> Seq.filter (fun c -> c.Id <> model.CategoryId)
|> Seq.map (fun c ->
let parents =
c.ParentNames
|> Array.map (fun it -> $"{it} &rang; ")
|> String.concat ""
{ Name = c.Id; Value = $"{parents}{c.Name}" })
|> Seq.append [ { Name = ""; Value = "&ndash; None &ndash;" } ]
selectField [] (nameof model.ParentId) "Parent Category" model.ParentId cats (_.Name) (_.Value) []
]
div [ _class "col-12 col-xl-10 offset-xl-1 mb-3" ] [
textField [] (nameof model.Description) "Description" model.Description []
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton
a [ _href (relUrl app "admin/categories"); _class "btn btn-sm btn-secondary ms-3" ] [ raw "Cancel" ]
]
]
]
]
|> List.singleton
/// Category list page
let categoryList includeNew app = [
let catCol = "col-12 col-md-6 col-xl-5 col-xxl-4"
let descCol = "col-12 col-md-6 col-xl-7 col-xxl-8"
let categoryDetail (cat: DisplayCategory) =
div [ _class "row mwl-table-detail"; _id $"cat_{cat.Id}" ] [
div [ _class $"{catCol} no-wrap" ] [
if cat.ParentNames.Length > 0 then
cat.ParentNames
|> Seq.ofArray
|> Seq.map (fun it -> raw $"{it} &rang; ")
|> List.ofSeq
|> small [ _class "text-muted" ]
raw cat.Name; br []
small [] [
let catUrl = relUrl app $"admin/category/{cat.Id}"
if cat.PostCount > 0 then
a [ _href (relUrl app $"category/{cat.Slug}"); _target "_blank" ] [
raw $"View { cat.PostCount} Post"; if cat.PostCount <> 1 then raw "s"
]; actionSpacer
a [ _href $"{catUrl}/edit"; _hxTarget $"#cat_{cat.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#cat_{cat.Id}:top" ] [
raw "Edit"
]; actionSpacer
a [ _href catUrl; _hxDelete catUrl; _hxTarget "body"; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the category “{cat.Name}”? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class descCol ] [
match cat.Description with Some value -> raw value | None -> em [ _class "text-muted" ] [ raw "none" ]
]
]
let loadNew =
span [ _hxGet (relUrl app "admin/category/new/edit"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/category/new/edit"); _class "btn btn-primary btn-sm mb-3"; _hxTarget "#cat_new" ] [
raw "Add a New Category"
]
div [ _id "catList"; _class "container" ] [
if app.Categories.Length = 0 then
if includeNew then loadNew
else
div [ _id "cat_new" ] [
p [ _class "text-muted fst-italic text-center" ] [
raw "This web log has no categories defined"
]
]
else
div [ _class "container" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class catCol ] [ raw "Category"; span [ _class "d-md-none" ] [ 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 ]
yield! app.Categories |> Seq.ofArray |> Seq.map categoryDetail |> List.ofSeq
]
]
]
]
/// The main dashboard
let dashboard (model: DashboardModel) app = [
h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " &bull; Dashboard" ]
article [ _class "container" ] [
div [ _class "row" ] [
section [ _class "col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-primary" ] [ raw "Posts" ]
div [ _class "card-body" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
raw "Published "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Posts) ]
raw "&nbsp; Drafts "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Drafts) ]
]
if app.IsAuthor then
a [ _href (relUrl app "admin/posts"); _class "btn btn-secondary me-2" ] [ raw "View All" ]
a [ _href (relUrl app "admin/post/new/edit"); _class "btn btn-primary" ] [
raw "Write a New Post"
]
]
]
]
section [ _class "col-lg-5 col-xl-4 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-primary" ] [ raw "Pages" ]
div [ _class "card-body" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
raw "All "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Pages) ]
raw "&nbsp; Shown in Page List "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.ListedPages) ]
]
if app.IsAuthor then
a [ _href (relUrl app "admin/pages"); _class "btn btn-secondary me-2" ] [ raw "View All" ]
a [ _href (relUrl app "admin/page/new/edit"); _class "btn btn-primary" ] [
raw "Create a New Page"
]
]
]
]
]
div [ _class "row" ] [
section [ _class "col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-secondary" ] [ raw "Categories" ]
div [ _class "card-body" ] [
h6 [ _class "card-subtitle text-muted pb-3"] [
raw "All "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Categories) ]
raw "&nbsp; Top Level "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.TopLevelCategories) ]
]
if app.IsWebLogAdmin then
a [ _href (relUrl app "admin/categories"); _class "btn btn-secondary me-2" ] [
raw "View All"
]
a [ _href (relUrl app "admin/categories?new"); _class "btn btn-secondary" ] [
raw "Add a New Category"
]
]
]
]
]
if app.IsWebLogAdmin then
div [ _class "row pb-3" ] [
div [ _class "col text-end" ] [
a [ _href (relUrl app "admin/settings"); _class "btn btn-secondary" ] [ raw "Modify Settings" ]
]
]
]
]
/// Custom RSS feed edit form
let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: MetaItem list) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/settings/rss/save"); _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
a [ _href (relUrl app "admin/settings#rss-settings") ] [ raw "&laquo; Back to Settings" ]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-12 col-lg-6" ] [
fieldset [ _class "container pb-0" ] [
legend [] [ raw "Identification" ]
div [ _class "row" ] [
div [ _class "col" ] [
textField [ _required ] (nameof model.Path) "Relative Feed Path" model.Path [
span [ _class "form-text fst-italic" ] [ raw "Appended to "; txt app.WebLog.UrlBase ]
]
]
]
div [ _class "row" ] [
div [ _class "col py-3 d-flex align-self-center justify-content-center" ] [
checkboxSwitch [ _onclick "Admin.checkPodcast()"; if model.IsPodcast then _checked ]
(nameof model.IsPodcast) "This Is a Podcast Feed" model.IsPodcast []
]
]
]
]
div [ _class "col-12 col-lg-6" ] [
fieldset [ _class "container pb-0" ] [
legend [] [ raw "Feed Source" ]
div [ _class "row d-flex align-items-center" ] [
div [ _class "col-1 d-flex justify-content-end pb-3" ] [
div [ _class "form-check form-check-inline me-0" ] [
input [ _type "radio"; _name (nameof model.SourceType); _id "SourceTypeCat"
_class "form-check-input"; _value "category"
if model.SourceType <> "tag" then _checked
_onclick "Admin.customFeedBy('category')" ]
label [ _for "SourceTypeCat"; _class "form-check-label d-none" ] [ raw "Category" ]
]
]
div [ _class "col-11 pb-3" ] [
let cats =
app.Categories
|> Seq.ofArray
|> Seq.map (fun c ->
let parents =
c.ParentNames
|> Array.map (fun it -> $"{it} &rang; ")
|> String.concat ""
{ Name = c.Id; Value = $"{parents}{c.Name}" })
|> Seq.append [ { Name = ""; Value = "&ndash; Select Category &ndash;" } ]
selectField [ _id "SourceValueCat"; _required
if model.SourceType = "tag" then _disabled ]
(nameof model.SourceValue) "Category" model.SourceValue cats (_.Name)
(_.Value) []
]
div [ _class "col-1 d-flex justify-content-end pb-3" ] [
div [ _class "form-check form-check-inline me-0" ] [
input [ _type "radio"; _name (nameof model.SourceType); _id "SourceTypeTag"
_class "form-check-input"; _value "tag"
if model.SourceType= "tag" then _checked
_onclick "Admin.customFeedBy('tag')" ]
label [ _for "sourceTypeTag"; _class "form-check-label d-none" ] [ raw "Tag" ]
]
]
div [ _class "col-11 pb-3" ] [
textField [ _id "SourceValueTag"; _required
if model.SourceType <> "tag" then _disabled ]
(nameof model.SourceValue) "Tag"
(if model.SourceType = "tag" then model.SourceValue else "") []
]
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
fieldset [ _class "container"; _id "podcastFields"; if not model.IsPodcast then _disabled ] [
legend [] [ raw "Podcast Settings" ]
div [ _class "row" ] [
div [ _class "col-12 col-md-5 col-lg-4 offset-lg-1 pb-3" ] [
textField [ _required ] (nameof model.Title) "Title" model.Title []
]
div [ _class "col-12 col-md-4 col-lg-4 pb-3" ] [
textField [] (nameof model.Subtitle) "Podcast Subtitle" model.Subtitle []
]
div [ _class "col-12 col-md-3 col-lg-2 pb-3" ] [
numberField [ _required ] (nameof model.ItemsInFeed) "# Episodes"
(string model.ItemsInFeed) []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-5 col-lg-4 offset-lg-1 pb-3" ] [
textField [ _required ] (nameof model.AppleCategory) "iTunes Category"
model.AppleCategory [
span [ _class "form-text fst-italic" ] [
a [ _href "https://www.thepodcasthost.com/planning/itunes-podcast-categories/"
_target "_blank"; _relNoOpener ] [
raw "iTunes Category / Subcategory List"
]
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [] (nameof model.AppleSubcategory) "iTunes Subcategory" model.AppleSubcategory
[]
]
div [ _class "col-12 col-md-3 col-lg-2 pb-3" ] [
selectField [ _required ] (nameof model.Explicit) "Explicit Rating" model.Explicit
ratings (_.Name) (_.Value) []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-6 col-lg-4 offset-xxl-1 pb-3" ] [
textField [ _required ] (nameof model.DisplayedAuthor) "Displayed Author"
model.DisplayedAuthor []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
emailField [ _required ] (nameof model.Email) "Author E-mail" model.Email [
span [ _class "form-text fst-italic" ] [
raw "For iTunes, must match registered e-mail"
]
]
]
div [ _class "col-12 col-sm-5 col-md-4 col-lg-4 col-xl-3 offset-xl-1 col-xxl-2 offset-xxl-0 pb-3" ] [
textField [] (nameof model.DefaultMediaType) "Default Media Type"
model.DefaultMediaType [
span [ _class "form-text fst-italic" ] [ raw "Optional; blank for no default" ]
]
]
div [ _class "col-12 col-sm-7 col-md-8 col-lg-10 offset-lg-1 pb-3" ] [
textField [ _required ] (nameof model.ImageUrl) "Image URL" model.ImageUrl [
span [ _class "form-text fst-italic"] [
raw "Relative URL will be appended to "; txt app.WebLog.UrlBase; raw "/"
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-12 col-lg-10 offset-lg-1" ] [
textField [ _required ] (nameof model.Summary) "Summary" model.Summary [
span [ _class "form-text fst-italic" ] [ raw "Displayed in podcast directories" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-12 col-lg-10 offset-lg-1" ] [
textField [] (nameof model.MediaBaseUrl) "Media Base URL" model.MediaBaseUrl [
span [ _class "form-text fst-italic" ] [
raw "Optional; prepended to episode media file if present"
]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-lg-5 offset-lg-1 pb-3" ] [
textField [] (nameof model.FundingUrl) "Funding URL" model.FundingUrl [
span [ _class "form-text fst-italic" ] [
raw "Optional; URL describing donation options for this podcast, "
raw "relative URL supported"
]
]
]
div [ _class "col-12 col-lg-5 pb-3" ] [
textField [ _maxlength "128" ] (nameof model.FundingText) "Funding Text"
model.FundingText [
span [ _class "form-text fst-italic" ] [ raw "Optional; text for the funding link" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-8 col-lg-5 offset-lg-1 pb-3" ] [
textField [] (nameof model.PodcastGuid) "Podcast GUID" model.PodcastGuid [
span [ _class "form-text fst-italic" ] [
raw "Optional; v5 UUID uniquely identifying this podcast; "
raw "once entered, do not change this value ("
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#guid"
_target "_blank"; _relNoOpener ] [
raw "documentation"
]; raw ")"
]
]
]
div [ _class "col-4 col-lg-3 offset-lg-2 pb-3" ] [
selectField [] (nameof model.Medium) "Medium" model.Medium mediums (_.Name) (_.Value) [
span [ _class "form-text fst-italic" ] [
raw "Optional; medium of the podcast content ("
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#medium"
_target "_blank"; _relNoOpener ] [
raw "documentation"
]; raw ")"
]
]
]
]
]
]
]
div [ _class "row pb-3" ] [ div [ _class "col text-center" ] [ saveButton ] ]
]
]
]
/// Redirect Rule edit form
let redirectEdit (model: EditRedirectRuleModel) app = [
let url = relUrl app $"admin/settings/redirect-rules/{model.RuleId}"
h3 [] [ raw (if model.RuleId < 0 then "Add" else "Edit"); raw " Redirect Rule" ]
form [ _action url; _hxPost url; _hxTarget "body"; _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "RuleId"; _value (string model.RuleId) ]
div [ _class "row" ] [
div [ _class "col-12 col-lg-5 mb-3" ] [
textField [ _autofocus; _required ] (nameof model.From) "From" model.From [
span [ _class "form-text" ] [ raw "From local URL/pattern" ]
]
]
div [ _class "col-12 col-lg-5 mb-3" ] [
textField [ _required ] (nameof model.To) "To" model.To [
span [ _class "form-text" ] [ raw "To URL/pattern" ]
]
]
div [ _class "col-12 col-lg-2 mb-3" ] [
checkboxSwitch [] (nameof model.IsRegex) "Use RegEx" model.IsRegex []
]
]
if model.RuleId < 0 then
div [ _class "row mb-3" ] [
div [ _class "col-12 text-center" ] [
label [ _class "me-1" ] [ raw "Add Rule" ]
div [ _class "btn-group btn-group-sm"; _roleGroup; _ariaLabel "New rule placement button group" ] [
input [ _type "radio"; _name "InsertAtTop"; _id "at_top"; _class "btn-check"; _value "true" ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "at_top" ] [ raw "Top" ]
input [ _type "radio"; _name "InsertAtTop"; _id "at_bot"; _class "btn-check"; _value "false"
_checked ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "at_bot" ] [ raw "Bottom" ]
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton; raw " &nbsp; "
a [ _href (relUrl app "admin/settings/redirect-rules"); _class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel"
]
]
]
]
]
/// The list of current redirect rules
let redirectList (model: RedirectRule list) app = [
// Generate the detail for a redirect rule
let ruleDetail idx (rule: RedirectRule) =
let ruleId = $"rule_{idx}"
div [ _class "row mwl-table-detail"; _id ruleId ] [
div [ _class "col-5 no-wrap" ] [
txt rule.From; br []
small [] [
let ruleUrl = relUrl app $"admin/settings/redirect-rules/{idx}"
a [ _href ruleUrl; _hxTarget $"#{ruleId}"; _hxSwap $"{HxSwap.InnerHtml} show:#{ruleId}:top" ] [
raw "Edit"
]
if idx > 0 then
actionSpacer; a [ _href $"{ruleUrl}/up"; _hxPost $"{ruleUrl}/up" ] [ raw "Move Up" ]
if idx <> model.Length - 1 then
actionSpacer; a [ _href $"{ruleUrl}/down"; _hxPost $"{ruleUrl}/down" ] [ raw "Move Down" ]
actionSpacer
a [ _class "text-danger"; _href ruleUrl; _hxDelete ruleUrl
_hxConfirm "Are you sure you want to delete this redirect rule?" ] [
raw "Delete"
]
]
]
div [ _class "col-5" ] [ txt rule.To ]
div [ _class "col-2 text-center" ] [ yesOrNo rule.IsRegex ]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
p [ _class "mb-3" ] [
a [ _href (relUrl app "admin/settings") ] [ raw "&laquo; Back to Settings" ]
]
div [ _class "container" ] [
p [] [
a [ _href (relUrl app "admin/settings/redirect-rules/-1"); _class "btn btn-primary btn-sm mb-3"
_hxTarget "#rule_new" ] [
raw "Add Redirect Rule"
]
]
if List.isEmpty model then
div [ _id "rule_new" ] [
p [ _class "text-muted text-center fst-italic" ] [
raw "This web log has no redirect rules defined"
]
]
else
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class "col-5" ] [ raw "From" ]
div [ _class "col-5" ] [ raw "To" ]
div [ _class "col-2 text-center" ] [ raw "RegEx?" ]
]
]
div [ _class "row mwl-table-detail"; _id "rule_new" ] []
form [ _method "post"; _class "container g-0"; _hxTarget "body" ] [
antiCsrf app; yield! List.mapi ruleDetail model
]
]
p [ _class "mt-3 text-muted fst-italic text-center" ] [
raw "This is an advanced feature; please "
a [ _href "https://bitbadger.solutions/open-source/myweblog/advanced.html#redirect-rules"
_target "_blank" ] [
raw "read and understand the documentation on this feature"
]
raw " before adding rules."
]
]
]
/// Edit a tag mapping
let tagMapEdit (model: EditTagMapModel) app = [
h5 [ _class "my-3" ] [ txt app.PageTitle ]
form [ _hxPost (relUrl app "admin/settings/tag-mapping/save"); _method "post"; _class "container"
_hxTarget "#tagList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row mb-3" ] [
div [ _class "col-6 col-lg-4 offset-lg-2" ] [
textField [ _autofocus; _required ] (nameof model.Tag) "Tag" model.Tag []
]
div [ _class "col-6 col-lg-4" ] [
textField [ _required ] (nameof model.UrlValue) "URL Value" model.UrlValue []
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton; raw " &nbsp; "
a [ _href (relUrl app "admin/settings/tag-mappings"); _class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel"
]
]
]
]
]
/// Display a list of the web log's current tag mappings
let tagMapList (model: TagMap list) app =
let tagMapDetail (map: TagMap) =
let url = relUrl app $"admin/settings/tag-mapping/{map.Id}"
div [ _class "row mwl-table-detail"; _id $"tag_{map.Id}" ] [
div [ _class "col no-wrap" ] [
txt map.Tag; br []
small [] [
a [ _href $"{url}/edit"; _hxTarget $"#tag_{map.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#tag_{map.Id}:top" ] [
raw "Edit"
]; actionSpacer
a [ _href url; _hxDelete url; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the mapping for “{map.Tag}”? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class "col" ] [ txt map.UrlValue ]
]
div [ _id "tagList"; _class "container" ] [
if List.isEmpty model then
div [ _id "tag_new" ] [
p [ _class "text-muted text-center fst-italic" ] [ raw "This web log has no tag mappings" ]
]
else
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class "col" ] [ raw "Tag" ]
div [ _class "col" ] [ raw "URL Value" ]
]
]
form [ _method "post"; _class "container g-0"; _hxTarget "#tagList"; _hxSwap HxSwap.OuterHtml ] [
antiCsrf app
div [ _class "row mwl-table-detail"; _id "tag_new" ] []
yield! List.map tagMapDetail model
]
]
|> List.singleton
/// The list of uploaded files for a web log
let uploadList (model: DisplayUpload seq) app = [
let webLogBase = $"upload/{app.WebLog.Slug}/"
let relativeBase = relUrl app $"upload/{app.WebLog.Slug}/"
let absoluteBase = app.WebLog.AbsoluteUrl(Permalink webLogBase)
let uploadDetail (upload: DisplayUpload) =
div [ _class "row mwl-table-detail" ] [
div [ _class "col-6" ] [
let badgeClass = if upload.Source = string Disk then "secondary" else "primary"
let pathAndName = $"{upload.Path}{upload.Name}"
span [ _class $"badge bg-{badgeClass} text-uppercase float-end mt-1" ] [ raw upload.Source ]
raw upload.Name; br []
small [] [
a [ _href $"{relativeBase}{pathAndName}"; _target "_blank" ] [ raw "View File" ]
actionSpacer; span [ _class "text-muted" ] [ raw "Copy " ]
a [ _href $"{absoluteBase}{pathAndName}"; _hxNoBoost
_onclick $"return Admin.copyText('{absoluteBase}{pathAndName}', this)" ] [
raw "Absolute"
]
span [ _class "text-muted" ] [ raw " | " ]
a [ _href $"{relativeBase}{pathAndName}"; _hxNoBoost
_onclick $"return Admin.copyText('{relativeBase}{pathAndName}', this)" ] [
raw "Relative"
]
if app.WebLog.ExtraPath <> "" then
span [ _class "text-muted" ] [ raw " | " ]
a [ _href $"{webLogBase}{pathAndName}"; _hxNoBoost
_onclick $"return Admin.copyText('/{webLogBase}{pathAndName}', this)" ] [
raw "For Post"
]
span [ _class "text-muted" ] [ raw " Link" ]
if app.IsWebLogAdmin then
actionSpacer
let deleteUrl =
if upload.Source = string "Disk" then $"admin/upload/disk/{pathAndName}"
else $"admin/upload/{upload.Id}"
|> relUrl app
a [ _href deleteUrl; _hxDelete deleteUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete {upload.Name}? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class "col-3" ] [ raw upload.Path ]
div [ _class "col-3" ] [
match upload.UpdatedOn with
| Some updated -> updated.ToString("yyyy-MM-dd/h:mmtt").ToLowerInvariant()
| None -> "--"
|> raw
]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/upload/new"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Upload a New File" ]
form [ _method "post"; _class "container"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row" ] [
div [ _class "col text-center" ] [
em [ _class "text-muted" ] [ raw "Uploaded files served from" ]; br []; raw relativeBase
]
]
if Seq.isEmpty model then
div [ _class "row" ] [
div [ _class "col text-muted fst-italic text-center" ] [
br []; raw "This web log has uploaded files"
]
]
else
div [ _class "row mwl-table-heading" ] [
div [ _class "col-6" ] [ raw "File Name" ]
div [ _class "col-3" ] [ raw "Path" ]
div [ _class "col-3" ] [ raw "File Date/Time" ]
]
yield! model |> Seq.map uploadDetail
]
]
]
/// Form to upload a new file
let uploadNew app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/upload/save"); _method "post"; _class "container"
_enctype "multipart/form-data"; _hxNoBoost ] [
antiCsrf app
div [ _class "row" ] [
div [ _class "col-12 col-md-6 pb-3" ] [
div [ _class "form-floating" ] [
input [ _type "file"; _id "file"; _name "File"; _class "form-control"; _placeholder "File"
_required ]
label [ _for "file" ] [ raw "File to Upload" ]
]
]
div [ _class "col-12 col-md-6 pb-3 d-flex align-self-center justify-content-around" ] [
div [ _class "text-center" ] [
raw "Destination"; br []
div [ _class "btn-group"; _roleGroup; _ariaLabel "Upload destination button group" ] [
input [ _type "radio"; _name "Destination"; _id "destination_db"; _class "btn-check"
_value (string Database); if app.WebLog.Uploads = Database then _checked ]
label [ _class "btn btn-outline-primary"; _for "destination_db" ] [ raw (string Database) ]
input [ _type "radio"; _name "Destination"; _id "destination_disk"; _class "btn-check"
_value (string Disk); if app.WebLog.Uploads= Disk then _checked ]
label [ _class "btn btn-outline-secondary"; _for "destination_disk" ] [ raw "Disk" ]
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Upload File" ]
]
]
]
]
]
/// Web log settings page
let webLogSettings
(model: SettingsModel) (themes: Theme list) (pages: Page list) (uploads: UploadDestination list)
(rss: EditRssModel) (app: AppViewContext) = [
let feedDetail (feed: CustomFeed) =
let source =
match feed.Source with
| Category (CategoryId catId) ->
app.Categories
|> Array.tryFind (fun cat -> cat.Id = catId)
|> Option.map _.Name
|> Option.defaultValue "--INVALID; DELETE THIS FEED--"
|> sprintf "Category: %s"
| Tag tag -> $"Tag: {tag}"
div [ _class "row mwl-table-detail" ] [
div [ _class "col-12 col-md-6" ] [
txt source
if Option.isSome feed.Podcast then
raw " &nbsp; "; span [ _class "badge bg-primary" ] [ raw "PODCAST" ]
br []
small [] [
let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}"
a [ _href (relUrl app (string feed.Path)); _target "_blank" ] [ raw "View Feed" ]
actionSpacer
a [ _href $"{feedUrl}/edit" ] [ raw "Edit" ]; actionSpacer
a [ _href feedUrl; _hxDelete feedUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the custom RSS feed based on {feed.Source}? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class "col-12 col-md-6" ] [
small [ _class "d-md-none" ] [ raw "Served at "; txt (string feed.Path) ]
span [ _class "d-none d-md-inline" ] [ txt (string feed.Path) ]
]
]
h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " Settings" ]
article [] [
p [ _class "text-muted" ] [
raw "Go to: "; a [ _href "#users" ] [ raw "Users" ]; raw " &bull; "
a [ _href "#rss-settings" ] [ raw "RSS Settings" ]; raw " &bull; "
a [ _href "#tag-mappings" ] [ raw "Tag Mappings" ]; raw " &bull; "
a [ _href (relUrl app "admin/settings/redirect-rules") ] [ raw "Redirect Rules" ]
]
fieldset [ _class "container mb-3" ] [
legend [] [ raw "Web Log Settings" ]
form [ _action (relUrl app "admin/settings"); _method "post" ] [
antiCsrf app
div [ _class "container g-0" ] [
div [ _class "row" ] [
div [ _class "col-12 col-md-6 col-xl-4 pb-3" ] [
textField [ _required; _autofocus ] (nameof model.Name) "Name" model.Name []
]
div [ _class "col-12 col-md-6 col-xl-4 pb-3" ] [
textField [ _required ] (nameof model.Slug) "Slug" model.Slug [
span [ _class "form-text" ] [
span [ _class "badge rounded-pill bg-warning text-dark" ] [ raw "WARNING" ]
raw " changing this value may break links ("
a [ _href "https://bitbadger.solutions/open-source/myweblog/configuring.html#blog-settings"
_target "_blank" ] [
raw "more"
]; raw ")"
]
]
]
div [ _class "col-12 col-md-6 col-xl-4 pb-3" ] [
textField [] (nameof model.Subtitle) "Subtitle" model.Subtitle []
]
div [ _class "col-12 col-md-6 col-xl-4 offset-xl-1 pb-3" ] [
selectField [ _required ] (nameof model.ThemeId) "Theme" model.ThemeId themes
(fun t -> string t.Id) (fun t -> $"{t.Name} (v{t.Version})") []
]
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
(fun p -> string p.Id) (_.Title) []
]
div [ _class "col-12 col-md-4 col-xl-2 pb-3" ] [
numberField [ _required; _min "0"; _max "50" ] (nameof model.PostsPerPage) "Posts per Page"
(string model.PostsPerPage) []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-4 col-xl-3 offset-xl-2 pb-3" ] [
textField [ _required ] (nameof model.TimeZone) "Time Zone" model.TimeZone []
]
div [ _class "col-12 col-md-4 col-xl-2" ] [
checkboxSwitch [] (nameof model.AutoHtmx) "Auto-Load htmx" model.AutoHtmx []
span [ _class "form-text fst-italic" ] [
a [ _href "https://htmx.org"; _target "_blank"; _relNoOpener ] [ raw "What is this?" ]
]
]
div [ _class "col-12 col-md-4 col-xl-3 pb-3" ] [
selectField [] (nameof model.Uploads) "Default Upload Destination" model.Uploads uploads
string string []
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ]
]
]
]
]
]
fieldset [ _id "users"; _class "container mb-3 pb-0" ] [
legend [] [ raw "Users" ]
span [ _hxGet (relUrl app "admin/settings/users"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
]
fieldset [ _id "rss-settings"; _class "container mb-3 pb-0" ] [
legend [] [ raw "RSS Settings" ]
form [ _action (relUrl app "admin/settings/rss"); _method "post"; _class "container g-0" ] [
antiCsrf app
div [ _class "row pb-3" ] [
div [ _class "col col-xl-8 offset-xl-2" ] [
fieldset [ _class "d-flex justify-content-evenly flex-row" ] [
legend [] [ raw "Feeds Enabled" ]
checkboxSwitch [] (nameof rss.IsFeedEnabled) "All Posts" rss.IsFeedEnabled []
checkboxSwitch [] (nameof rss.IsCategoryEnabled) "Posts by Category" rss.IsCategoryEnabled
[]
checkboxSwitch [] (nameof rss.IsTagEnabled) "Posts by Tag" rss.IsTagEnabled []
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-sm-6 col-md-3 col-xl-2 offset-xl-2 pb-3" ] [
textField [] (nameof rss.FeedName) "Feed File Name" rss.FeedName [
span [ _class "form-text" ] [ raw "Default is "; code [] [ raw "feed.xml" ] ]
]
]
div [ _class "col-12 col-sm-6 col-md-4 col-xl-2 pb-3" ] [
numberField [ _required; _min "0" ] (nameof rss.ItemsInFeed) "Items in Feed"
(string rss.ItemsInFeed) [
span [ _class "form-text" ] [
raw "Set to &ldquo;0&rdquo; to use &ldquo;Posts per Page&rdquo; setting ("
raw (string app.WebLog.PostsPerPage); raw ")"
]
]
]
div [ _class "col-12 col-md-5 col-xl-4 pb-3" ] [
textField [] (nameof rss.Copyright) "Copyright String" rss.Copyright [
span [ _class "form-text" ] [
raw "Can be a "
a [ _href "https://creativecommons.org/share-your-work/"; _target "_blank"
_relNoOpener ] [
raw "Creative Commons license string"
]
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ]
]
]
]
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Custom Feeds" ]
a [ _class "btn btn-sm btn-secondary"; _href (relUrl app "admin/settings/rss/new/edit") ] [
raw "Add a New Custom Feed"
]
if app.WebLog.Rss.CustomFeeds.Length = 0 then
p [ _class "text-muted fst-italic text-center" ] [ raw "No custom feeds defined" ]
else
form [ _method "post"; _class "container g-0"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row mwl-table-heading" ] [
div [ _class "col-12 col-md-6" ] [
span [ _class "d-md-none" ] [ raw "Feed" ]
span [ _class "d-none d-md-inline" ] [ raw "Source" ]
]
div [ _class "col-12 col-md-6 d-none d-md-inline-block" ] [ raw "Relative Path" ]
]
yield! app.WebLog.Rss.CustomFeeds |> List.map feedDetail
]
]
]
fieldset [ _id "tag-mappings"; _class "container mb-3 pb-0" ] [
legend [] [ raw "Tag Mappings" ]
a [ _href (relUrl app "admin/settings/tag-mapping/new/edit"); _class "btn btn-primary btn-sm mb-3"
_hxTarget "#tag_new" ] [
raw "Add a New Tag Mapping"
]
span [ _hxGet (relUrl app "admin/settings/tag-mappings"); _hxTrigger HxTrigger.Load
_hxSwap HxSwap.OuterHtml ] []
]
]
]

View File

@@ -1,8 +1,15 @@
{
"Generator": "myWebLog 2.0-beta05",
"Generator": "myWebLog 2.2",
"Logging": {
"LogLevel": {
"MyWebLog.Handlers": "Information"
}
},
"Kestrel": {
"Endpoints": {
"Http": {
"Url": "http://0.0.0.0:80"
}
}
}
}

View File

@@ -1,64 +0,0 @@
<header>
<nav class="navbar navbar-dark bg-dark navbar-expand-md justify-content-start px-2 position-fixed top-0 w-100">
<div class="container-fluid">
<a class="navbar-brand" href="{{ "" | relative_link }}" hx-boost="false">{{ web_log.name }}</a>
<button class="navbar-toggler" type="button" data-bs-toggle="collapse" data-bs-target="#navbarText"
aria-controls="navbarText" aria-expanded="false" aria-label="Toggle navigation">
<span class="navbar-toggler-icon"></span>
</button>
<div class="collapse navbar-collapse" id="navbarText">
{% if is_logged_on -%}
<ul class="navbar-nav">
{{ "admin/dashboard" | nav_link: "Dashboard" }}
{% if is_author %}
{{ "admin/pages" | nav_link: "Pages" }}
{{ "admin/posts" | nav_link: "Posts" }}
{{ "admin/uploads" | nav_link: "Uploads" }}
{% endif %}
{% if is_web_log_admin %}
{{ "admin/categories" | nav_link: "Categories" }}
{{ "admin/users" | nav_link: "Users" }}
{{ "admin/settings" | nav_link: "Settings" }}
{% endif %}
</ul>
{%- endif %}
<ul class="navbar-nav flex-grow-1 justify-content-end">
{% if is_logged_on -%}
{{ "admin/user/my-info" | nav_link: "My Info" }}
<li class="nav-item">
<a class="nav-link" href="{{ "user/log-off" | relative_link }}" hx-boost="false">Log Off</a>
</li>
{%- else -%}
{{ "user/log-on" | nav_link: "Log On" }}
{%- endif %}
</ul>
</div>
</div>
</nav>
</header>
<main class="mx-3 mt-3">
<div class="messages mt-2" id="msgContainer">
{% for msg in messages %}
<div role="alert" class="alert alert-{{ msg.level }} alert-dismissible fade show">
{{ msg.message }}
<button type="button" class="btn-close" data-bs-dismiss="alert" aria-label="Close"></button>
{% if msg.detail %}
<hr>
{{ msg.detail.value }}
{% endif %}
</div>
{% endfor %}
</div>
{{ content }}
</main>
<footer class="position-fixed bottom-0 w-100">
<div class="container-fluid">
<div class="row">
<div class="col-xs-12 text-end">
{%- assign version = generator | split: " " -%}
<small class="me-1 align-baseline">v{{ version[1] }}</small>
<img src="{{ "themes/admin/logo-light.png" | relative_link }}" alt="myWebLog" width="120" height="34">
</div>
</div>
</div>
</footer>

View File

@@ -1,54 +0,0 @@
<div class="col-12">
<h5 class="my-3">{{ page_title }}</h5>
<form hx-post="{{ "admin/category/save" | relative_link }}" method="post" class="container"
hx-target="#catList" hx-swap="outerHTML show:window:top">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<input type="hidden" name="CategoryId" value="{{ model.category_id }}">
<div class="row">
<div class="col-12 col-sm-6 col-lg-4 col-xxl-3 offset-xxl-1 mb-3">
<div class="form-floating">
<input type="text" name="Name" id="name" class="form-control form-control-sm" placeholder="Name" autofocus
required value="{{ model.name | escape }}">
<label for="name">Name</label>
</div>
</div>
<div class="col-12 col-sm-6 col-lg-4 col-xxl-3 mb-3">
<div class="form-floating">
<input type="text" name="Slug" id="slug" class="form-control form-control-sm" placeholder="Slug" required
value="{{ model.slug | escape }}">
<label for="slug">Slug</label>
</div>
</div>
<div class="col-12 col-lg-4 col-xxl-3 offset-xxl-1 mb-3">
<div class="form-floating">
<select name="ParentId" id="parentId" class="form-control form-control-sm">
<option value=""{% if model.parent_id == "" %} selected="selected"{% endif %}>
&ndash; None &ndash;
</option>
{% for cat in categories -%}
{%- unless cat.id == model.category_id %}
<option value="{{ cat.id }}"{% if model.parent_id == cat.id %} selected="selected"{% endif %}>
{% for it in cat.parent_names %} &nbsp; &raquo; {% endfor %}{{ cat.name }}
</option>
{% endunless -%}
{%- endfor %}
</select>
<label for="parentId">Parent Category</label>
</div>
</div>
<div class="col-12 col-xl-10 offset-xl-1 mb-3">
<div class="form-floating">
<input name="Description" id="description" class="form-control form-control-sm"
placeholder="A short description of this category" value="{{ model.description | escape }}">
<label for="description">Description</label>
</div>
</div>
</div>
<div class="row mb-3">
<div class="col text-center">
<button type="submit" class="btn btn-sm btn-primary">Save Changes</button>
<a href="{{ "admin/categories/bare" | relative_link }}" class="btn btn-sm btn-secondary ms-3">Cancel</a>
</div>
</div>
</form>
</div>

View File

@@ -1,45 +0,0 @@
<form method="post" id="catList" class="container" hx-target="this" hx-swap="outerHTML show:window:top">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<div class="row mwl-table-detail" id="cat_new"></div>
{%- assign cat_count = categories | size -%}
{% if cat_count > 0 %}
{%- assign cat_col = "col-12 col-md-6 col-xl-5 col-xxl-4" -%}
{%- assign desc_col = "col-12 col-md-6 col-xl-7 col-xxl-8" -%}
{% for cat in categories -%}
<div class="row mwl-table-detail" id="cat_{{ cat.id }}">
<div class="{{ cat_col }} no-wrap">
{%- if cat.parent_names %}
<small class="text-muted">{% for name in cat.parent_names %}{{ name }} &rang; {% endfor %}</small>
{%- endif %}
{{ cat.name }}<br>
<small>
{%- assign cat_url_base = "admin/category/" | append: cat.id -%}
{%- if cat.post_count > 0 %}
<a href="{{ cat | category_link }}" target="_blank">
View {{ cat.post_count }} Post{% unless cat.post_count == 1 %}s{% endunless -%}
</a>
<span class="text-muted"> &bull; </span>
{%- endif %}
<a href="{{ cat_url_base | append: "/edit" | relative_link }}" hx-target="#cat_{{ cat.id }}"
hx-swap="innerHTML show:#cat_{{ cat.id }}:top">
Edit
</a>
<span class="text-muted"> &bull; </span>
{%- assign cat_del_link = cat_url_base | append: "/delete" | relative_link -%}
<a href="{{ cat_del_link }}" hx-post="{{ cat_del_link }}" class="text-danger"
hx-confirm="Are you sure you want to delete the category &ldquo;{{ cat.name }}&rdquo;? This action cannot be undone.">
Delete
</a>
</small>
</div>
<div class="{{ desc_col }}">
{%- if cat.description %}{{ cat.description.value }}{% else %}<em class="text-muted">none</em>{% endif %}
</div>
</div>
{%- endfor %}
{%- else -%}
<div class="row">
<div class="col-12 text-muted fst-italic text-center">This web log has no categores defined</div>
</div>
{%- endif %}
</form>

View File

@@ -1,16 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
<a href="{{ "admin/category/new/edit" | relative_link }}" class="btn btn-primary btn-sm mb-3"
hx-target="#cat_new">
Add a New Category
</a>
<div class="container">
{%- assign cat_col = "col-12 col-md-6 col-xl-5 col-xxl-4" -%}
{%- assign desc_col = "col-12 col-md-6 col-xl-7 col-xxl-8" -%}
<div class="row mwl-table-heading">
<div class="{{ cat_col }}">Category<span class="d-md-none">; Description</span></div>
<div class="{{ desc_col }} d-none d-md-inline-block">Description</div>
</div>
</div>
{{ category_list }}
</article>

View File

@@ -1,259 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
<form action="{{ "admin/settings/rss/save" | relative_link }}" method="post">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<input type="hidden" name="Id" value="{{ model.id }}">
{%- assign typ = model.source_type -%}
<div class="container">
<div class="row pb-3">
<div class="col">
<a href="{{ "admin/settings/rss" | relative_link }}">&laquo; Back to RSS Settings</a>
</div>
</div>
<div class="row pb-3">
<div class="col-12 col-lg-6">
<fieldset class="container pb-0">
<legend>Identification</legend>
<div class="row">
<div class="col">
<div class="form-floating">
<input type="text" name="Path" id="path" class="form-control" placeholder="Relative Feed Path"
value="{{ model.path }}">
<label for="path">Relative Feed Path</label>
<span class="form-text fst-italic">Appended to {{ web_log.url_base }}/</span>
</div>
</div>
</div>
<div class="row">
<div class="col py-3 d-flex align-self-center justify-content-center">
<div class="form-check form-switch">
<input type="checkbox" name="IsPodcast" id="isPodcast" class="form-check-input" value="true"
{%- if model.is_podcast %} checked="checked"{% endif %} onclick="Admin.checkPodcast()">
<label for="isPodcast" class="form-check-label">This Is a Podcast Feed</label>
</div>
</div>
</div>
</fieldset>
</div>
<div class="col-12 col-lg-6">
<fieldset class="container pb-0">
<legend>Feed Source</legend>
<div class="row d-flex align-items-center">
<div class="col-1 d-flex justify-content-end pb-3">
<div class="form-check form-check-inline me-0">
<input type="radio" name="SourceType" id="sourceTypeCat" class="form-check-input" value="category"
{%- unless typ == "tag" %} checked="checked" {% endunless -%}
onclick="Admin.customFeedBy('category')">
<label for="sourceTypeCat" class="form-check-label d-none">Category</label>
</div>
</div>
<div class="col-11 pb-3">
<div class="form-floating">
<select name="SourceValue" id="sourceValueCat" class="form-control" required
{%- if typ == "tag" %} disabled="disabled"{% endif %}>
<option value="">&ndash; Select Category &ndash;</option>
{% for cat in categories -%}
<option value="{{ cat.id }}"
{%- if typ != "tag" and model.source_value == cat.id %} selected="selected"{% endif -%}>
{% for it in cat.parent_names %}{{ it }} &rang; {% endfor %}{{ cat.name }}
</option>
{%- endfor %}
</select>
<label for="sourceValueCat">Category</label>
</div>
</div>
<div class="col-1 d-flex justify-content-end pb-3">
<div class="form-check form-check-inline me-0">
<input type="radio" name="SourceType" id="sourceTypeTag" class="form-check-input" value="tag"
{%- if typ == "tag" %} checked="checked"{% endif %} onclick="Admin.customFeedBy('tag')">
<label for="sourceTypeTag" class="form-check-label d-none">Tag</label>
</div>
</div>
<div class="col-11 pb-3">
<div class="form-floating">
<input type="text" name="SourceValue" id="sourceValueTag" class="form-control" placeholder="Tag"
{%- unless typ == "tag" %} disabled="disabled"{% endunless %} required
{%- if typ == "tag" %} value="{{ model.source_value }}"{% endif %}>
<label for="sourceValueTag">Tag</label>
</div>
</div>
</div>
</fieldset>
</div>
</div>
<div class="row pb-3">
<div class="col">
<fieldset class="container" id="podcastFields"{% unless model.is_podcast %} disabled="disabled"{%endunless%}>
<legend>Podcast Settings</legend>
<div class="row">
<div class="col-12 col-md-5 col-lg-4 offset-lg-1 pb-3">
<div class="form-floating">
<input type="text" name="Title" id="title" class="form-control" placeholder="Title" required
value="{{ model.title }}">
<label for="title">Title</label>
</div>
</div>
<div class="col-12 col-md-4 col-lg-4 pb-3">
<div class="form-floating">
<input type="text" name="Subtitle" id="subtitle" class="form-control" placeholder="Subtitle"
value="{{ model.subtitle }}">
<label for="subtitle">Podcast Subtitle</label>
</div>
</div>
<div class="col-12 col-md-3 col-lg-2 pb-3">
<div class="form-floating">
<input type="number" name="ItemsInFeed" id="itemsInFeed" class="form-control" placeholder="Items"
required value="{{ model.items_in_feed }}">
<label for="itemsInFeed"># Episodes</label>
</div>
</div>
</div>
<div class="row">
<div class="col-12 col-md-5 col-lg-4 offset-lg-1 pb-3">
<div class="form-floating">
<input type="text" name="AppleCategory" id="appleCategory" class="form-control"
placeholder="iTunes Category" required value="{{ model.apple_category }}">
<label for="appleCategory">iTunes Category</label>
<span class="form-text fst-italic">
<a href="https://www.thepodcasthost.com/planning/itunes-podcast-categories/" target="_blank"
rel="noopener">
iTunes Category / Subcategory List
</a>
</span>
</div>
</div>
<div class="col-12 col-md-4 pb-3">
<div class="form-floating">
<input type="text" name="AppleSubcategory" id="appleSubcategory" class="form-control"
placeholder="iTunes Subcategory" value="{{ model.apple_subcategory }}">
<label for="appleSubcategory">iTunes Subcategory</label>
</div>
</div>
<div class="col-12 col-md-3 col-lg-2 pb-3">
<div class="form-floating">
<select name="Explicit" id="explicit" class="form-control" required>
<option value="yes"{% if model.explicit == "yes" %} selected="selected"{% endif %}>Yes</option>
<option value="no"{% if model.explicit == "no" %} selected="selected"{% endif %}>No</option>
<option value="clean"{% if model.explicit == "clean" %} selected="selected"{% endif %}>
Clean
</option>
</select>
<label for="explicit">Explicit Rating</label>
</div>
</div>
</div>
<div class="row">
<div class="col-12 col-md-6 col-lg-4 offset-xxl-1 pb-3">
<div class="form-floating">
<input type="text" name="DisplayedAuthor" id="displayedAuthor" class="form-control"
placeholder="Author" required value="{{ model.displayed_author }}">
<label for="displayedAuthor">Displayed Author</label>
</div>
</div>
<div class="col-12 col-md-6 col-lg-4 pb-3">
<div class="form-floating">
<input type="email" name="Email" id="email" class="form-control" placeholder="Email" required
value="{{ model.email }}">
<label for="email">Author E-mail</label>
<span class="form-text fst-italic">For iTunes, must match registered e-mail</span>
</div>
</div>
<div class="col-12 col-sm-5 col-md-4 col-lg-4 col-xl-3 offset-xl-1 col-xxl-2 offset-xxl-0">
<div class="form-floating">
<input type="text" name="DefaultMediaType" id="defaultMediaType" class="form-control"
placeholder="Media Type" value="{{ model.default_media_type }}">
<label for="defaultMediaType">Default Media Type</label>
<span class="form-text fst-italic">Optional; blank for no default</span>
</div>
</div>
<div class="col-12 col-sm-7 col-md-8 col-lg-10 offset-lg-1">
<div class="form-floating">
<input type="text" name="ImageUrl" id="imageUrl" class="form-control" placeholder="Image URL" required
value="{{ model.image_url }}">
<label for="imageUrl">Image URL</label>
<span class="form-text fst-italic">Relative URL will be appended to {{ web_log.url_base }}/</span>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col-12 col-lg-10 offset-lg-1">
<div class="form-floating">
<input type="text" name="Summary" id="summary" class="form-control" placeholder="Summary" required
value="{{ model.summary }}">
<label for="summary">Summary</label>
<span class="form-text fst-italic">Displayed in podcast directories</span>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col-12 col-lg-10 offset-lg-1">
<div class="form-floating">
<input type="text" name="MediaBaseUrl" id="mediaBaseUrl" class="form-control"
placeholder="Media Base URL" value="{{ model.media_base_url }}">
<label for="mediaBaseUrl">Media Base URL</label>
<span class="form-text fst-italic">Optional; prepended to episode media file if present</span>
</div>
</div>
</div>
<div class="row">
<div class="col-12 col-lg-5 offset-lg-1 pb-3">
<div class="form-floating">
<input type="text" name="FundingUrl" id="fundingUrl" class="form-control" placeholder="Funding URL"
value="{{ model.funding_url }}">
<label for="fundingUrl">Funding URL</label>
<span class="form-text fst-italic">
Optional; URL describing donation options for this podcast, relative URL supported
</span>
</div>
</div>
<div class="col-12 col-lg-5 pb-3">
<div class="form-floating">
<input type="text" name="FundingText" id="fundingText" class="form-control" maxlength="128"
placeholder="Funding Text" value="{{ model.funding_text }}">
<label for="fundingText">Funding Text</label>
<span class="form-text fst-italic">Optional; text for the funding link</span>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col-8 col-lg-5 offset-lg-1 pb-3">
<div class="form-floating">
<input type="text" name="PodcastGuid" id="guid" class="form-control" placeholder="GUID"
value="{{ model.podcast_guid }}">
<label for="guid">Podcast GUID</label>
<span class="form-text fst-italic">
Optional; v5 UUID uniquely identifying this podcast; once entered, do not change this value
(<a href="https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#guid"
target="_blank">documentation</a>)
</span>
</div>
</div>
<div class="col-4 col-lg-3 offset-lg-2 pb-3">
<div class="form-floating">
<select name="Medium" id="medium" class="form-control">
{% for med in medium_values -%}
<option value="{{ med[0] }}"{% if model.medium == med[0] %} selected{% endif %}>
{{ med[1] }}
</option>
{%- endfor %}
</select>
<label for="medium">Medium</label>
<span class="form-text fst-italic">
Optional; medium of the podcast content
(<a href="https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#medium"
target="_blank">documentation</a>)
</span>
</div>
</div>
</div>
</fieldset>
</div>
</div>
<div class="row pb-3">
<div class="col text-center">
<button type="submit" class="btn btn-primary">Save Changes</button>
</div>
</div>
</div>
</form>
</article>

View File

@@ -1,59 +0,0 @@
<h2 class="my-3">{{ web_log.name }} &bull; Dashboard</h2>
<article class="container">
<div class="row">
<section class="col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3">
<div class="card">
<header class="card-header text-white bg-primary">Posts</header>
<div class="card-body">
<h6 class="card-subtitle text-muted pb-3">
Published <span class="badge rounded-pill bg-secondary">{{ model.posts }}</span>
&nbsp; Drafts <span class="badge rounded-pill bg-secondary">{{ model.drafts }}</span>
</h6>
{% if is_author %}
<a href="{{ "admin/posts" | relative_link }}" class="btn btn-secondary me-2">View All</a>
<a href="{{ "admin/post/new/edit" | relative_link }}" class="btn btn-primary">Write a New Post</a>
{% endif %}
</div>
</div>
</section>
<section class="col-lg-5 col-xl-4 pb-3">
<div class="card">
<header class="card-header text-white bg-primary">Pages</header>
<div class="card-body">
<h6 class="card-subtitle text-muted pb-3">
All <span class="badge rounded-pill bg-secondary">{{ model.pages }}</span>
&nbsp; Shown in Page List <span class="badge rounded-pill bg-secondary">{{ model.listed_pages }}</span>
</h6>
{% if is_author %}
<a href="{{ "admin/pages" | relative_link }}" class="btn btn-secondary me-2">View All</a>
<a href="{{ "admin/page/new/edit" | relative_link }}" class="btn btn-primary">Create a New Page</a>
{% endif %}
</div>
</div>
</section>
</div>
<div class="row">
<section class="col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3">
<div class="card">
<header class="card-header text-white bg-secondary">Categories</header>
<div class="card-body">
<h6 class="card-subtitle text-muted pb-3">
All <span class="badge rounded-pill bg-secondary">{{ model.categories }}</span>
&nbsp; Top Level <span class="badge rounded-pill bg-secondary">{{ model.top_level_categories }}</span>
</h6>
{% if is_web_log_admin %}
<a href="{{ "admin/categories" | relative_link }}" class="btn btn-secondary me-2">View All</a>
<a href="{{ "admin/category/new/edit" | relative_link }}" class="btn btn-secondary">Add a New Category</a>
{% endif %}
</div>
</div>
</section>
</div>
{% if is_web_log_admin %}
<div class="row pb-3">
<div class="col text-end">
<a href="{{ "admin/settings" | relative_link }}" class="btn btn-secondary">Modify Settings</a>
</div>
</div>
{% endif %}
</article>

View File

@@ -1,5 +0,0 @@
<!DOCTYPE html>
<html lang="en">
<head><title></title></head>
<body>{{ content }}</body>
</html>

View File

@@ -1,10 +0,0 @@
<!DOCTYPE html>
<html lang="en">
<head>
<title>{{ page_title | strip_html }} &laquo; Admin &laquo; {{ web_log.name | strip_html }}</title>
</head>
<body>
{% include_template "_layout" %}
<script>Admin.dismissSuccesses()</script>
</body>
</html>

View File

@@ -1,32 +0,0 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta name="viewport" content="width=device-width, initial-scale=1">
<meta name="generator" content="{{ generator }}">
<title>{{ page_title | strip_html }} &laquo; Admin &laquo; {{ web_log.name | strip_html }}</title>
<link rel="stylesheet" href="https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/css/bootstrap.min.css"
integrity="sha384-EVSTQN3/azprG1Anm3QDgpJLIm9Nao0Yz1ztcQTwFspd3yD65VohhpuuCOmLASjC" crossorigin="anonymous">
<link rel="stylesheet" href="{{ "themes/admin/admin.css" | relative_link }}">
</head>
<body hx-boost="true">
{% include_template "_layout" %}
<script src="https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/js/bootstrap.bundle.min.js"
integrity="sha384-MrcW6ZMFYlzcLA8Nl+NtUVF0sA7MsXsP1UyJoMp4YLEuNSfAP+JcXn/tWtIaxVXM"
crossorigin="anonymous"></script>
{{ htmx_script }}
<script>
const cssLoaded = [...document.styleSheets].filter(it => it.href.indexOf("bootstrap.min.css") > -1).length > 0
if (!cssLoaded) {
const local = document.createElement("link")
local.rel = "stylesheet"
local.href = "{{ "themes/admin/bootstrap.min.css" | relative_link }}"
document.getElementsByTagName("link")[0].prepend(local)
}
setTimeout(function () {
if (!bootstrap) document.write('<script src=\"{{ "script/bootstrap.bundle.min.js" | relative_link }}\"><\/script>')
}, 2000)
</script>
<script src="{{ "themes/admin/admin.js" | relative_link }}"></script>
<script>Admin.dismissSuccesses()</script>
</body>
</html>

View File

@@ -1,30 +0,0 @@
<h2 class="my-3">Log On to {{ web_log.name }}</h2>
<article class="py-3">
<form action="{{ "user/log-on" | relative_link }}" method="post" hx-push-url="true">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
{% if model.return_to %}
<input type="hidden" name="ReturnTo" value="{{ model.return_to.value }}">
{% endif %}
<div class="container">
<div class="row">
<div class="col-12 col-md-6 col-lg-4 offset-lg-2 pb-3">
<div class="form-floating">
<input type="email" id="email" name="EmailAddress" class="form-control" autofocus required>
<label for="email">E-mail Address</label>
</div>
</div>
<div class="col-12 col-md-6 col-lg-4 pb-3">
<div class="form-floating">
<input type="password" id="password" name="Password" class="form-control" required>
<label for="password">Password</label>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col text-center">
<button type="submit" class="btn btn-primary">Log On</button>
</div>
</div>
</div>
</form>
</article>

View File

@@ -1,77 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
<form action="{{ "admin/user/my-info" | relative_link }}" method="post">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<div class="d-flex flex-row flex-wrap justify-content-around">
<div class="text-center mb-3 lh-sm">
<strong class="text-decoration-underline">Access Level</strong><br>{{ access_level }}
</div>
<div class="text-center mb-3 lh-sm">
<strong class="text-decoration-underline">Created</strong><br>{{ created_on | date: "MMMM d, yyyy" }}
</div>
<div class="text-center mb-3 lh-sm">
<strong class="text-decoration-underline">Last Log On</strong><br>
{{ last_seen_on | date: "MMMM d, yyyy" }} at {{ last_seen_on | date: "h:mmtt" | downcase }}
</div>
</div>
<div class="container">
<div class="row"><div class="col"><hr class="mt-0"></div></div>
<div class="row mb-3">
<div class="col-12 col-md-6 col-lg-4 pb-3">
<div class="form-floating">
<input type="text" name="FirstName" id="firstName" class="form-control" autofocus required
placeholder="First" value="{{ model.first_name }}">
<label for="firstName">First Name</label>
</div>
</div>
<div class="col-12 col-md-6 col-lg-4 pb-3">
<div class="form-floating">
<input type="text" name="LastName" id="lastName" class="form-control" required
placeholder="Last" value="{{ model.last_name }}">
<label for="lastName">Last Name</label>
</div>
</div>
<div class="col-12 col-md-6 col-lg-4 pb-3">
<div class="form-floating">
<input type="text" name="PreferredName" id="preferredName" class="form-control" required
placeholder="Preferred" value="{{ model.preferred_name }}">
<label for="preferredName">Preferred Name</label>
</div>
</div>
</div>
<div class="row mb-3">
<div class="col">
<fieldset class="p-2">
<legend class="ps-1">Change Password</legend>
<div class="row">
<div class="col">
<p class="form-text">Optional; leave blank to keep your current password</p>
</div>
</div>
<div class="row">
<div class="col-12 col-md-6 pb-3">
<div class="form-floating">
<input type="password" name="NewPassword" id="newPassword" class="form-control"
placeholder="Password">
<label for="newPassword">New Password</label>
</div>
</div>
<div class="col-12 col-md-6 pb-3">
<div class="form-floating">
<input type="password" name="NewPasswordConfirm" id="newPasswordConfirm" class="form-control"
placeholder="Confirm">
<label for="newPasswordConfirm">Confirm New Password</label>
</div>
</div>
</div>
</fieldset>
</div>
</div>
<div class="row">
<div class="col text-center mb-3">
<button type="submit" class="btn btn-primary">Save Changes</button>
</div>
</div>
</div>
</form>
</article>

View File

@@ -1,112 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
<form action="{{ "admin/page/save" | relative_link }}" method="post" hx-push-url="true">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<input type="hidden" name="PageId" value="{{ model.page_id }}">
<div class="container">
<div class="row mb-3">
<div class="col-9">
<div class="form-floating pb-3">
<input type="text" name="Title" id="title" class="form-control" autofocus required
value="{{ model.title }}">
<label for="title">Title</label>
</div>
<div class="form-floating pb-3">
<input type="text" name="Permalink" id="permalink" class="form-control" required
value="{{ model.permalink }}">
<label for="permalink">Permalink</label>
{%- unless model.is_new %}
<span class="form-text">
<a href="{{ "admin/page/" | append: model.page_id | append: "/permalinks" | relative_link }}">
Manage Permalinks
</a>
<span class="text-muted"> &bull; </span>
<a href="{{ "admin/page/" | append: model.page_id | append: "/revisions" | relative_link }}">
Manage Revisions
</a>
</span>
{% endunless -%}
</div>
<div class="mb-2">
<label for="text">Text</label> &nbsp; &nbsp;
<input type="radio" name="Source" id="source_html" class="btn-check" value="HTML"
{%- if model.source == "HTML" %} checked="checked"{% endif %}>
<label class="btn btn-sm btn-outline-secondary" for="source_html">HTML</label>
<input type="radio" name="Source" id="source_md" class="btn-check" value="Markdown"
{%- if model.source == "Markdown" %} checked="checked"{% endif %}>
<label class="btn btn-sm btn-outline-secondary" for="source_md">Markdown</label>
</div>
<div class="mb-3">
<textarea name="Text" id="text" class="form-control">{{ model.text }}</textarea>
</div>
</div>
<div class="col-3">
<div class="form-floating pb-3">
<select name="Template" id="template" class="form-control">
{% for tmpl in templates -%}
<option value="{{ tmpl[0] }}"{% if model.template == tmpl[0] %} selected="selected"{% endif %}>
{{ tmpl[1] }}
</option>
{%- endfor %}
</select>
<label for="template">Page Template</label>
</div>
<div class="form-check form-switch">
<input type="checkbox" name="IsShownInPageList" id="showList" class="form-check-input" value="true"
{%- if model.is_shown_in_page_list %} checked="checked"{% endif %}>
<label for="showList" class="form-check-label">Show in Page List</label>
</div>
</div>
</div>
<div class="row mb-3">
<div class="col">
<button type="submit" class="btn btn-primary">Save Changes</button>
</div>
</div>
<div class="row mb-3">
<div class="col">
<fieldset>
<legend>
Metadata
<button type="button" class="btn btn-sm btn-secondary" data-bs-toggle="collapse"
data-bs-target="#metaItemContainer">
show
</button>
</legend>
<div id="metaItemContainer" class="collapse">
<div id="metaItems" class="container">
{%- for meta in metadata %}
<div id="meta_{{ meta[0] }}" 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({{ meta[0] }})">
&minus;
</button>
</div>
<div class="col-3">
<div class="form-floating">
<input type="text" name="MetaNames" id="metaNames_{{ meta[0] }}" class="form-control"
placeholder="Name" value="{{ meta[1] }}">
<label for="metaNames_{{ meta[0] }}">Name</label>
</div>
</div>
<div class="col-8">
<div class="form-floating">
<input type="text" name="MetaValues" id="metaValues_{{ meta[0] }}" class="form-control"
placeholder="Value" value="{{ meta[2] }}">
<label for="metaValues_{{ meta[0] }}">Value</label>
</div>
</div>
</div>
{% endfor -%}
</div>
<button type="button" class="btn btn-sm btn-secondary" onclick="Admin.addMetaItem()">Add an Item</button>
<script>
document.addEventListener("DOMContentLoaded", () => Admin.setNextMetaIndex({{ metadata | size }}))
</script>
</div>
</fieldset>
</div>
</div>
</div>
</form>
</article>

View File

@@ -1,77 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
<a href="{{ "admin/page/new/edit" | relative_link }}" class="btn btn-primary btn-sm mb-3">Create a New Page</a>
{%- assign page_count = pages | size -%}
{%- assign title_col = "col-12 col-md-5" -%}
{%- assign link_col = "col-12 col-md-5" -%}
{%- assign upd8_col = "col-12 col-md-2" -%}
<form method="post" class="container" hx-target="body">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<div class="row mwl-table-heading">
<div class="{{ title_col }}">
<span class="d-none d-md-inline">Title</span><span class="d-md-none">Page</span>
</div>
<div class="{{ link_col }} d-none d-md-inline-block">Permalink</div>
<div class="{{ upd8_col }} d-none d-md-inline-block">Updated</div>
</div>
{% if page_count > 0 %}
{% for pg in pages -%}
<div class="row mwl-table-detail">
<div class="{{ title_col }}">
{{ pg.title }}
{%- if pg.is_default %} &nbsp; <span class="badge bg-success">HOME PAGE</span>{% endif -%}
{%- if pg.is_in_page_list %} &nbsp; <span class="badge bg-primary">IN PAGE LIST</span> {% endif -%}<br>
<small>
{%- capture pg_link %}{% unless pg.is_default %}{{ pg.permalink }}{% endunless %}{% endcapture -%}
<a href="{{ pg_link | relative_link }}" target="_blank">View Page</a>
{% if is_editor or is_author and user_id == pg.author_id %}
<span class="text-muted"> &bull; </span>
<a href="{{ pg | edit_page_link }}">Edit</a>
{% endif %}
{% if is_web_log_admin %}
<span class="text-muted"> &bull; </span>
{%- assign pg_del_link = "admin/page/" | append: pg.id | append: "/delete" | relative_link -%}
<a href="{{ pg_del_link }}" hx-post="{{ pg_del_link }}" class="text-danger"
hx-confirm="Are you sure you want to delete the page &ldquo;{{ pg.title | strip_html | escape }}&rdquo;? This action cannot be undone.">
Delete
</a>
{% endif %}
</small>
</div>
<div class="{{ link_col }}">
{%- capture pg_link %}/{% unless pg.is_default %}{{ pg.permalink }}{% endunless %}{% endcapture -%}
<small class="d-md-none">{{ pg_link }}</small><span class="d-none d-md-inline">{{ pg_link }}</span>
</div>
<div class="{{ upd8_col }}">
<small class="d-md-none text-muted">Updated {{ pg.updated_on | date: "MMMM d, yyyy" }}</small>
<span class="d-none d-md-inline">{{ pg.updated_on | date: "MMMM d, yyyy" }}</span>
</div>
</div>
{%- endfor %}
{% else %}
<div class="row">
<div class="col text-muted fst-italic text-center">This web log has no pages</div>
</div>
{% endif %}
</form>
{% if page_nbr > 1 or page_count == 25 %}
<div class="d-flex justify-content-evenly pb-3">
<div>
{% if page_nbr > 1 %}
<p>
<a class="btn btn-default" href="{{ "admin/pages" | append: prev_page | relative_link }}">
&laquo; Previous
</a>
</p>
{% endif %}
</div>
<div class="text-right">
{% if page_count == 25 %}
<p>
<a class="btn btn-default" href="{{ "admin/pages" | append: next_page | relative_link }}">Next &raquo;</a>
</p>
{% endif %}
</div>
</div>
{% endif %}
</article>

View File

@@ -1,60 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
{%- assign base_url = "admin/" | append: model.entity | append: "/" -%}
<form action="{{ base_url | append: "permalinks" | relative_link }}" method="post">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<input type="hidden" name="Id" value="{{ model.id }}">
<div class="container">
<div class="row">
<div class="col">
<p style="line-height:1.2rem;">
<strong>{{ model.current_title }}</strong><br>
<small class="text-muted">
<span class="fst-italic">{{ model.current_permalink }}</span><br>
<a href="{{ base_url | append: model.id | append: "/edit" | relative_link }}">
&laquo; Back to Edit {{ model.entity | capitalize }}
</a>
</small>
</p>
</div>
</div>
<div class="row mb-3">
<div class="col">
<button type="button" class="btn btn-sm btn-secondary" onclick="Admin.addPermalink()">Add a Permalink</button>
</div>
</div>
<div class="row mb-3">
<div class="col">
<div id="permalinks" class="container">
{%- assign link_count = 0 -%}
{%- for link in model.prior %}
<div id="link_{{ link_count }}" class="row mb-3">
<div class="col-1 text-center align-self-center">
<button type="button" class="btn btn-sm btn-danger" onclick="Admin.removePermalink({{ link_count }})">
&minus;
</button>
</div>
<div class="col-11">
<div class="form-floating">
<input type="text" name="Prior" id="prior_{{ link_count }}" class="form-control"
placeholder="Link" value="{{ link }}">
<label for="prior_{{ link_count }}">Link</label>
</div>
</div>
</div>
{%- assign link_count = link_count | plus: 1 -%}
{% endfor -%}
<script>
document.addEventListener("DOMContentLoaded", () => Admin.setPermalinkIndex({{ link_count }}))
</script>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col">
<button type="submit" class="btn btn-primary">Save Changes</button>
</div>
</div>
</div>
</form>
</article>

View File

@@ -1,346 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
<form action="{{ "admin/post/save" | relative_link }}" method="post" hx-push-url="true">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<input type="hidden" name="PostId" value="{{ model.post_id }}">
<div class="container">
<div class="row mb-3">
<div class="col-12 col-lg-9">
<div class="form-floating pb-3">
<input type="text" name="Title" id="title" class="form-control" placeholder="Title" autofocus required
value="{{ model.title }}">
<label for="title">Title</label>
</div>
<div class="form-floating pb-3">
<input type="text" name="Permalink" id="permalink" class="form-control" placeholder="Permalink" required
value="{{ model.permalink }}">
<label for="permalink">Permalink</label>
{%- unless model.is_new %}
<span class="form-text">
<a href="{{ "admin/post/" | append: model.post_id | append: "/permalinks" | relative_link }}">
Manage Permalinks
</a>
<span class="text-muted"> &bull; </span>
<a href="{{ "admin/post/" | append: model.post_id | append: "/revisions" | relative_link }}">
Manage Revisions
</a>
</span>
{% endunless -%}
</div>
<div class="mb-2">
<label for="text">Text</label> &nbsp; &nbsp;
<div class="btn-group btn-group-sm" role="group" aria-label="Text format button group">
<input type="radio" name="Source" id="source_html" class="btn-check" value="HTML"
{%- if model.source == "HTML" %} checked="checked"{% endif %}>
<label class="btn btn-sm btn-outline-secondary" for="source_html">HTML</label>
<input type="radio" name="Source" id="source_md" class="btn-check" value="Markdown"
{%- if model.source == "Markdown" %} checked="checked"{% endif %}>
<label class="btn btn-sm btn-outline-secondary" for="source_md">Markdown</label>
</div>
</div>
<div class="pb-3">
<textarea name="Text" id="text" class="form-control" rows="20">{{ model.text }}</textarea>
</div>
<div class="form-floating pb-3">
<input type="text" name="Tags" id="tags" class="form-control" placeholder="Tags"
value="{{ model.tags }}">
<label for="tags">Tags</label>
<div class="form-text">comma-delimited</div>
</div>
{% if model.status == "Draft" %}
<div class="form-check form-switch pb-2">
<input type="checkbox" name="DoPublish" id="doPublish" class="form-check-input" value="true">
<label for="doPublish" class="form-check-label">Publish This Post</label>
</div>
{% endif %}
<button type="submit" class="btn btn-primary pb-2">Save Changes</button>
<hr class="mb-3">
<fieldset class="mb-3">
<legend>
<span class="form-check form-switch">
<small>
<input type="checkbox" name="IsEpisode" id="isEpisode" class="form-check-input" value="true"
data-bs-toggle="collapse" data-bs-target="#episodeItems" onclick="Admin.toggleEpisodeFields()"
{%- if model.is_episode %}checked="checked"{% endif %}>
</small>
<label for="isEpisode">Podcast Episode</label>
</span>
</legend>
<div id="episodeItems" class="container p-0 collapse{% if model.is_episode %} show{% endif %}">
<div class="row">
<div class="col-12 col-md-8 pb-3">
<div class="form-floating">
<input type="text" name="Media" id="media" class="form-control" placeholder="Media" required
value="{{ model.media }}">
<label for="media">Media File</label>
<div class="form-text">
Relative URL will be appended to base media path (if set) or served from this web log
</div>
</div>
</div>
<div class="col-12 col-md-4 pb-3">
<div class="form-floating">
<input type="text" name="MediaType" id="mediaType" class="form-control" placeholder="Media Type"
value="{{ model.media_type }}">
<label for="mediaType">Media MIME Type</label>
<div class="form-text">Optional; overrides podcast default</div>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col">
<div class="form-floating">
<input type="number" name="Length" id="length" class="form-control" placeholder="Length" required
value="{{ model.length }}">
<label for="length">Media Length (bytes)</label>
<div class="form-text">TODO: derive from above file name</div>
</div>
</div>
<div class="col">
<div class="form-floating">
<input type="text" name="Duration" id="duration" class="form-control" placeholder="Duration"
value="{{ model.duration }}">
<label for="duration">Duration</label>
<div class="form-text">Recommended; enter in <code>HH:MM:SS</code> format</div>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col">
<div class="form-floating">
<input type="text" name="Subtitle" id="subtitle" class="form-control" placeholder="Subtitle"
value="{{ model.subtitle }}">
<label for="subtitle">Subtitle</label>
<div class="form-text">Optional; a subtitle for this episode</div>
</div>
</div>
</div>
<div class="row">
<div class="col-12 col-md-8 pb-3">
<div class="form-floating">
<input type="text" name="ImageUrl" id="imageUrl" class="form-control" placeholder="Image URL"
value="{{ model.image_url }}">
<label for="imageUrl">Image URL</label>
<div class="form-text">
Optional; overrides podcast default; relative URL served from this web log
</div>
</div>
</div>
<div class="col-12 col-md-4 pb-3">
<div class="form-floating">
<select name="Explicit" id="explicit" class="form-control">
{% for exp_value in explicit_values %}
<option value="{{ exp_value[0] }}"
{%- if model.explicit == exp_value[0] %} selected="selected"{% endif -%}>
{{ exp_value[1] }}
</option>
{% endfor %}
</select>
<label for="explicit">Explicit Rating</label>
<div class="form-text">Optional; overrides podcast default</div>
</div>
</div>
</div>
<div class="row">
<div class="col-12 col-md-8 pb-3">
<div class="form-floating">
<input type="text" name="ChapterFile" id="chapterFile" class="form-control"
placeholder="Chapter File" value="{{ model.chapter_file }}">
<label for="chapterFile">Chapter File</label>
<div class="form-text">Optional; relative URL served from this web log</div>
</div>
</div>
<div class="col-12 col-md-4 pb-3">
<div class="form-floating">
<input type="text" name="ChapterType" id="chapterType" class="form-control"
placeholder="Chapter Type" value="{{ model.chapter_type }}">
<label for="chapterType">Chapter MIME Type</label>
<div class="form-text">
Optional; <code>application/json+chapters</code> assumed if chapter file ends with
<code>.json</code>
</div>
</div>
</div>
</div>
<div class="row">
<div class="col-12 col-md-8 pb-3">
<div class="form-floating">
<input type="text" name="TranscriptUrl" id="transcriptUrl" class="form-control"
placeholder="Transcript URL" value="{{ model.transcript_url }}"
onkeyup="Admin.requireTranscriptType()">
<label for="transcriptUrl">Transcript URL</label>
<div class="form-text">Optional; relative URL served from this web log</div>
</div>
</div>
<div class="col-12 col-md-4 pb-3">
<div class="form-floating">
<input type="text" name="TranscriptType" id="transcriptType" class="form-control"
placeholder="Transcript Type" value="{{ model.transcript_type }}"
{%- if model.transcript_url != "" %} required{% endif %}>
<label for="transcriptType">Transcript MIME Type</label>
<div class="form-text">Required if transcript URL provided</div>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col">
<div class="form-floating">
<input type="text" name="TranscriptLang" id="transcriptLang" class="form-control"
placeholder="Transcript Language" value="{{ model.transcript_lang }}">
<label for="transcriptLang">Transcript Language</label>
<div class="form-text">Optional; overrides podcast default</div>
</div>
</div>
<div class="col d-flex justify-content-center">
<div class="form-check form-switch align-self-center pb-3">
<input type="checkbox" name="TranscriptCaptions" id="transcriptCaptions" class="form-check-input"
value="true" {% if model.transcript_captions %} checked="checked"{% endif %}>
<label for="transcriptCaptions">This is a captions file</label>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col col-md-4">
<div class="form-floating">
<input type="number" name="SeasonNumber" id="seasonNumber" class="form-control"
placeholder="Season Number" value="{{ model.season_number }}">
<label for="seasonNumber">Season Number</label>
<div class="form-text">Optional</div>
</div>
</div>
<div class="col col-md-8">
<div class="form-floating">
<input type="text" name="SeasonDescription" id="seasonDescription" class="form-control"
placeholder="Season Description" maxlength="128" value="{{ model.season_description }}">
<label for="seasonDescription">Season Description</label>
<div class="form-text">Optional</div>
</div>
</div>
</div>
<div class="row pb-3">
<div class="col col-md-4">
<div class="form-floating">
<input type="number" name="EpisodeNumber" id="episodeNumber" class="form-control" step="0.01"
placeholder="Episode Number" value="{{ model.episode_number }}">
<label for="episodeNumber">Episode Number</label>
<div class="form-text">Optional; up to 2 decimal points</div>
</div>
</div>
<div class="col col-md-8">
<div class="form-floating">
<input type="text" name="EpisodeDescription" id="episodeDescription" class="form-control"
placeholder="Episode Description" maxlength="128" value="{{ model.episode_description }}">
<label for="episodeDescription">Episode Description</label>
<div class="form-text">Optional</div>
</div>
</div>
</div>
</div>
<script>
document.addEventListener("DOMContentLoaded", () => Admin.toggleEpisodeFields())
</script>
</fieldset>
<fieldset class="pb-3">
<legend>
Metadata
<button type="button" class="btn btn-sm btn-secondary" data-bs-toggle="collapse"
data-bs-target="#metaItemContainer">
show
</button>
</legend>
<div id="metaItemContainer" class="collapse">
<div id="metaItems" class="container">
{%- for meta in metadata %}
<div id="meta_{{ meta[0] }}" 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({{ meta[0] }})">
&minus;
</button>
</div>
<div class="col-3">
<div class="form-floating">
<input type="text" name="MetaNames" id="metaNames_{{ meta[0] }}" class="form-control"
placeholder="Name" value="{{ meta[1] }}">
<label for="metaNames_{{ meta[0] }}">Name</label>
</div>
</div>
<div class="col-8">
<div class="form-floating">
<input type="text" name="MetaValues" id="metaValues_{{ meta[0] }}" class="form-control"
placeholder="Value" value="{{ meta[2] }}">
<label for="metaValues_{{ meta[0] }}">Value</label>
</div>
</div>
</div>
{% endfor -%}
</div>
<button type="button" class="btn btn-sm btn-secondary" onclick="Admin.addMetaItem()">Add an Item</button>
<script>
document.addEventListener("DOMContentLoaded", () => Admin.setNextMetaIndex({{ metadata | size }}))
</script>
</div>
</fieldset>
{% if model.status == "Published" %}
<fieldset class="pb-3">
<legend>Maintenance</legend>
<div class="container">
<div class="row">
<div class="col align-self-center">
<div class="form-check form-switch pb-2">
<input type="checkbox" name="SetPublished" id="setPublished" class="form-check-input"
value="true">
<label for="setPublished" class="form-check-label">Set Published Date</label>
</div>
</div>
<div class="col-4">
<div class="form-floating">
<input type="datetime-local" name="PubOverride" id="pubOverride" class="form-control"
placeholder="Override Date"
{%- if model.pub_override -%}
value="{{ model.pub_override | date: "yyyy-MM-dd\THH:mm" }}"
{%- endif %}>
<label for="pubOverride" class="form-label">Published On</label>
</div>
</div>
<div class="col-5 align-self-center">
<div class="form-check form-switch pb-2">
<input type="checkbox" name="SetUpdated" id="setUpdated" class="form-check-input" value="true">
<label for="setUpdated" class="form-check-label">
Purge revisions and<br>set as updated date as well
</label>
</div>
</div>
</div>
</div>
</fieldset>
{% endif %}
</div>
<div class="col-12 col-lg-3">
<div class="form-floating pb-3">
<select name="Template" id="template" class="form-control">
{% for tmpl in templates -%}
<option value="{{ tmpl[0] }}"{% if model.template == tmpl[0] %} selected="selected"{% endif %}>
{{ tmpl[1] }}
</option>
{%- endfor %}
</select>
<label for="template">Post Template</label>
</div>
<fieldset>
<legend>Categories</legend>
{% for cat in categories %}
<div class="form-check">
<input type="checkbox" name="CategoryIds" id="categoryId_{{ cat.id }}" class="form-check-input"
value="{{ cat.id }}" {% if model.category_ids contains cat.id %} checked="checked"{% endif %}>
<label for="categoryId_{{ cat.id }}" class="form-check-label"
{%- if cat.description %} title="{{ cat.description.value | strip_html | escape }}"{% endif %}>
{%- for it in cat.parent_names %}&nbsp; &rang; &nbsp;{% endfor %}{{ cat.name }}
</label>
</div>
{% endfor %}
</fieldset>
</div>
</div>
</div>
</form>
</article>

View File

@@ -1,100 +0,0 @@
<h2 class="my-3">{{ page_title }}</h2>
<article>
<a href="{{ "admin/post/new/edit" | relative_link }}" class="btn btn-primary btn-sm mb-3">Write a New Post</a>
<form method="post" class="container" hx-target="body">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
{%- assign post_count = model.posts | size -%}
{%- assign date_col = "col-xs-12 col-md-3 col-lg-2" -%}
{%- assign title_col = "col-xs-12 col-md-7 col-lg-6 col-xl-5 col-xxl-4" -%}
{%- assign author_col = "col-xs-12 col-md-2 col-lg-1" -%}
{%- assign tag_col = "col-lg-3 col-xl-4 col-xxl-5 d-none d-lg-inline-block" -%}
<div class="row mwl-table-heading">
<div class="{{ date_col }}">
<span class="d-md-none">Post</span><span class="d-none d-md-inline">Date</span>
</div>
<div class="{{ title_col }} d-none d-md-inline-block">Title</div>
<div class="{{ author_col }} d-none d-md-inline-block">Author</div>
<div class="{{ tag_col }}">Tags</div>
</div>
{%- if post_count > 0 %}
{% for post in model.posts -%}
<div class="row mwl-table-detail">
<div class="{{ date_col }} no-wrap">
<small class="d-md-none">
{%- if post.published_on -%}
Published {{ post.published_on | date: "MMMM d, yyyy" }}
{%- else -%}
Not Published
{%- endif -%}
{%- if post.published_on != post.updated_on -%}
<em class="text-muted"> (Updated {{ post.updated_on | date: "MMMM d, yyyy" }})</em>
{%- endif %}
</small>
<span class="d-none d-md-inline">
{%- if post.published_on -%}
{{ post.published_on | date: "MMMM d, yyyy" }}
{%- else -%}
Not Published
{%- endif -%}
{%- if post.published_on != post.updated_on %}<br>
<small class="text-muted"><em>{{ post.updated_on | date: "MMMM d, yyyy" }}</em></small>
{%- endif %}
</span>
</div>
<div class="{{ title_col }}">
{%- if post.episode %}<span class="badge bg-success float-end text-uppercase mt-1">Episode</span>{% endif -%}
{{ post.title }}<br>
<small>
<a href="{{ post | relative_link }}" target="_blank">View Post</a>
{% if is_editor or is_author and user_id == post.author_id %}
<span class="text-muted"> &bull; </span>
<a href="{{ post | edit_post_link }}">Edit</a>
{% endif %}
{% if is_web_log_admin %}
<span class="text-muted"> &bull; </span>
{%- assign post_del_link = "admin/post/" | append: post.id | append: "/delete" | relative_link -%}
<a href="{{ post_del_link }}" hx-post="{{ post_del_link }}" class="text-danger"
hx-confirm="Are you sure you want to delete the page &ldquo;{{ post.title | strip_html | escape }}&rdquo;? This action cannot be undone.">
Delete
</a>
{% endif %}
</small>
</div>
<div class="{{ author_col }}">
{%- assign tag_count = post.tags | size -%}
<small class="d-md-none">
Authored by {{ model.authors | value: post.author_id }} |
{% if tag_count == 0 -%}
No
{%- else -%}
{{ tag_count }}
{%- endif %} Tag{% unless tag_count == 1 %}s{% endunless %}
</small>
<span class="d-none d-md-inline">{{ model.authors | value: post.author_id }}</span>
</div>
<div class="{{ tag_col }}">
<span class="no-wrap">{{ post.tags | join: "</span>, <span class='no-wrap'>" }}</span>
</div>
</div>
{%- endfor %}
{% else %}
<div class="row">
<div class="col text-muted fst-italic text-center">This web log has no posts</div>
</div>
{% endif %}
</form>
{% if model.newer_link or model.older_link %}
<div class="d-flex justify-content-evenly">
<div>
{% if model.newer_link %}
<p><a class="btn btn-default" href="{{ model.newer_link.value }}">&laquo; Newer Posts</a></p>
{% endif %}
</div>
<div class="text-right">
{% if model.older_link %}
<p><a class="btn btn-default" href="{{ model.older_link.value }}">Older Posts &raquo;</a></p>
{% endif %}
</div>
</div>
{% endif %}
</article>

Some files were not shown because too many files have changed in this diff Show More