From 5b27ea5cd2bf6834cc7049585db7beba3ee69cbb Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 8 Jul 2023 20:36:49 -0400 Subject: [PATCH 001/123] Add canonical domain support (#37) - Update deps --- .gitignore | 1 + src/MyWebLog.Data/MyWebLog.Data.fsproj | 12 ++++++++---- src/MyWebLog.Domain/MyWebLog.Domain.fsproj | 6 +++--- src/MyWebLog/MyWebLog.fsproj | 12 +++++++----- src/MyWebLog/Program.fs | 6 ++++++ 5 files changed, 25 insertions(+), 12 deletions(-) diff --git a/.gitignore b/.gitignore index 170e429..4a0e7bf 100644 --- a/.gitignore +++ b/.gitignore @@ -261,6 +261,7 @@ src/MyWebLog/wwwroot/img/daniel-j-summers src/MyWebLog/wwwroot/img/bit-badger .ionide +.vscode src/MyWebLog/appsettings.Production.json # SQLite database files diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 1f1cf76..6a6ae75 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -5,18 +5,22 @@ - - + + - + - + + + + + diff --git a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj index 9511caa..048dc6c 100644 --- a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj +++ b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj @@ -7,9 +7,9 @@ - - - + + + diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 78ad373..037c8b9 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -23,13 +23,15 @@ - - - - - + + + + + + + diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index f114259..1437985 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -99,6 +99,8 @@ let showHelp () = open System.IO +open System.Linq +open BitBadger.AspNetCore.CanonicalDomains open Giraffe open Giraffe.EndpointRouting open Microsoft.AspNetCore.Authentication.Cookies @@ -200,6 +202,10 @@ let rec main args = do! Maintenance.loadTheme [| ""; themeFile |] app.Services let _ = app.UseForwardedHeaders () + + let domainCfg = app.Services.GetRequiredService().GetSection "CanonicalDomains" + if domainCfg.AsEnumerable().Count () > 0 then app.UseCanonicalDomains () |> ignore + let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) let _ = app.UseMiddleware () let _ = app.UseAuthentication () -- 2.45.1 From 5f5927c425c96f0573d108da6fcbfb4ba03d7499 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 8 Jul 2023 21:26:11 -0400 Subject: [PATCH 002/123] First cut of Docker files (#38) - Fix canonical domain config detection (#37) - Fix version insert for new SQLite dbs - Bump version to 2.1 --- src/.dockerignore | 2 ++ src/Directory.Build.props | 6 +++--- src/Dockerfile | 28 ++++++++++++++++++++++++++++ src/MyWebLog.Data/SQLiteData.fs | 2 +- src/MyWebLog/Program.fs | 5 +++-- 5 files changed, 37 insertions(+), 6 deletions(-) create mode 100644 src/.dockerignore create mode 100644 src/Dockerfile diff --git a/src/.dockerignore b/src/.dockerignore new file mode 100644 index 0000000..f181d71 --- /dev/null +++ b/src/.dockerignore @@ -0,0 +1,2 @@ +**/bin +**/obj diff --git a/src/Directory.Build.props b/src/Directory.Build.props index 5529e72..e376d97 100644 --- a/src/Directory.Build.props +++ b/src/Directory.Build.props @@ -2,8 +2,8 @@ net6.0;net7.0 embedded - 2.0.0.0 - 2.0.0.0 - 2.0.0 + 2.1.0.0 + 2.1.0.0 + 2.1.0 diff --git a/src/Dockerfile b/src/Dockerfile new file mode 100644 index 0000000..cf71ceb --- /dev/null +++ b/src/Dockerfile @@ -0,0 +1,28 @@ +FROM mcr.microsoft.com/dotnet/sdk:7.0 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/ +RUN dotnet restore + +COPY . ./ +WORKDIR /mwl/MyWebLog +RUN dotnet publish -f net7.0 -c Release -r linux-x64 + +FROM alpine AS theme +RUN apk add --no-cache zip +WORKDIR /themes +COPY ./default-theme ./default-theme/ +RUN zip default-theme.zip ./default-theme/* +COPY ./admin-theme ./admin-theme/ +RUN zip admin-theme.zip ./admin-theme/* + +FROM mcr.microsoft.com/dotnet/aspnet:7.0 as final +WORKDIR /app +COPY --from=build /mwl/MyWebLog/bin/Release/net7.0/linux-x64/publish/ ./ +COPY --from=theme /themes/*.zip /app/ + +EXPOSE 80 +CMD [ "/app/MyWebLog" ] diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 873945c..6133eb1 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -210,7 +210,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS // Database version table if needsTable "db_version" then "CREATE TABLE db_version (id TEXT PRIMARY KEY); - INSERT INTO db_version VALUES ('v2-rc1')" + INSERT INTO db_version VALUES ('v2')" } |> Seq.map (fun sql -> log.LogInformation $"Creating {(sql.Split ' ')[2]} table..." diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 1437985..7b0c3ca 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -203,8 +203,9 @@ let rec main args = let _ = app.UseForwardedHeaders () - let domainCfg = app.Services.GetRequiredService().GetSection "CanonicalDomains" - if domainCfg.AsEnumerable().Count () > 0 then app.UseCanonicalDomains () |> ignore + (app.Services.GetRequiredService().GetSection "CanonicalDomains").Value + |> (isNull >> not) + |> function true -> app.UseCanonicalDomains () |> ignore | false -> () let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) let _ = app.UseMiddleware () -- 2.45.1 From 9dd6ab70e969edd2662603eca34c91e82ea8c3ba Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 18 Jul 2023 21:53:04 -0400 Subject: [PATCH 003/123] Add Sqlite Docker file - Fix import typo in RethinkDB upload restore - Switch default Docker file to alpine image --- src/Dockerfile | 10 ++++++---- src/MyWebLog.Data/RethinkDbData.fs | 6 ++++-- src/sqlite.Dockerfile | 28 ++++++++++++++++++++++++++++ 3 files changed, 38 insertions(+), 6 deletions(-) create mode 100644 src/sqlite.Dockerfile diff --git a/src/Dockerfile b/src/Dockerfile index cf71ceb..d05e417 100644 --- a/src/Dockerfile +++ b/src/Dockerfile @@ -1,4 +1,4 @@ -FROM mcr.microsoft.com/dotnet/sdk:7.0 AS build +FROM mcr.microsoft.com/dotnet/sdk:7.0-alpine AS build WORKDIR /mwl COPY ./MyWebLog.sln ./ COPY ./Directory.Build.props ./ @@ -9,7 +9,7 @@ RUN dotnet restore COPY . ./ WORKDIR /mwl/MyWebLog -RUN dotnet publish -f net7.0 -c Release -r linux-x64 +RUN dotnet publish -f net7.0 -c Release -r linux-x64 --no-self-contained -p:PublishSingleFile=false FROM alpine AS theme RUN apk add --no-cache zip @@ -19,10 +19,12 @@ RUN zip default-theme.zip ./default-theme/* COPY ./admin-theme ./admin-theme/ RUN zip admin-theme.zip ./admin-theme/* -FROM mcr.microsoft.com/dotnet/aspnet:7.0 as final +FROM mcr.microsoft.com/dotnet/aspnet:7.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/net7.0/linux-x64/publish/ ./ COPY --from=theme /themes/*.zip /app/ EXPOSE 80 -CMD [ "/app/MyWebLog" ] +CMD [ "dotnet", "/app/MyWebLog.dll" ] diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 92ace6e..9cf340e 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -226,7 +226,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger () | Some v when v = "v2-rc2" -> do! migrateV2Rc2ToV2 () - | Some v when v = "v2-rc1" -> do! migrateV2Rc1ToV2Rc2 () + | Some v when v = "v2-rc1" -> + do! migrateV2Rc1ToV2Rc2 () + do! migrateV2Rc2ToV2 () | Some _ | None -> log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" @@ -926,7 +928,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger List.chunkBySize 5 do do! rethink { - withTable Table.TagMap + withTable Table.Upload insert batch write; withRetryOnce; ignoreResult conn } diff --git a/src/sqlite.Dockerfile b/src/sqlite.Dockerfile new file mode 100644 index 0000000..cf71ceb --- /dev/null +++ b/src/sqlite.Dockerfile @@ -0,0 +1,28 @@ +FROM mcr.microsoft.com/dotnet/sdk:7.0 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/ +RUN dotnet restore + +COPY . ./ +WORKDIR /mwl/MyWebLog +RUN dotnet publish -f net7.0 -c Release -r linux-x64 + +FROM alpine AS theme +RUN apk add --no-cache zip +WORKDIR /themes +COPY ./default-theme ./default-theme/ +RUN zip default-theme.zip ./default-theme/* +COPY ./admin-theme ./admin-theme/ +RUN zip admin-theme.zip ./admin-theme/* + +FROM mcr.microsoft.com/dotnet/aspnet:7.0 as final +WORKDIR /app +COPY --from=build /mwl/MyWebLog/bin/Release/net7.0/linux-x64/publish/ ./ +COPY --from=theme /themes/*.zip /app/ + +EXPOSE 80 +CMD [ "/app/MyWebLog" ] -- 2.45.1 From ab9f2f577b41017dea79231eecba36e141f1a3d6 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 28 Jul 2023 19:41:53 -0400 Subject: [PATCH 004/123] Use PG lib data source singleton --- src/MyWebLog.Data/PostgresData.fs | 12 +++++------- src/MyWebLog/Program.fs | 16 +++++++--------- 2 files changed, 12 insertions(+), 16 deletions(-) diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 0650379..58967d5 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -6,16 +6,14 @@ open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data.Postgres open Newtonsoft.Json -open Npgsql open Npgsql.FSharp /// Data implementation for PostgreSQL -type PostgresData (source : NpgsqlDataSource, log : ILogger, ser : JsonSerializer) = +type PostgresData (log : ILogger, ser : JsonSerializer) = /// Create any needed tables let ensureTables () = backgroundTask { // Set up the PostgreSQL document store - Configuration.useDataSource source Configuration.useSerializer { new IDocumentSerializer with member _.Serialize<'T> (it : 'T) : string = Utils.serialize ser it @@ -23,9 +21,8 @@ type PostgresData (source : NpgsqlDataSource, log : ILogger, ser : } let! tables = - Sql.fromDataSource source - |> Sql.query "SELECT tablename FROM pg_tables WHERE schemaname = 'public'" - |> Sql.executeAsync (fun row -> row.string "tablename") + Custom.list "SELECT tablename FROM pg_tables WHERE schemaname = 'public'" [] + (fun row -> row.string "tablename") let needsTable table = not (List.contains table tables) // Create a document table let mutable isNew = false @@ -117,7 +114,8 @@ type PostgresData (source : NpgsqlDataSource, log : ILogger, ser : $"INSERT INTO {Table.DbVersion} VALUES ('{Utils.currentDbVersion}')" } - Sql.fromDataSource source + Configuration.dataSource () + |> Sql.fromDataSource |> Sql.executeTransactionAsync (sql |> Seq.map (fun s -> diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 7b0c3ca..cd462bb 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -27,6 +27,7 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger) open System +open BitBadger.Npgsql.FSharp.Documents open Microsoft.Extensions.DependencyInjection open MyWebLog.Data open Newtonsoft.Json @@ -44,7 +45,7 @@ module DataImplementation = let builder = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PostgreSQL") let _ = builder.UseNodaTime () // let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore)) - builder.Build () + (builder.Build >> Configuration.useDataSource) () /// Get the configured data implementation let get (sp : IServiceProvider) : IData = @@ -68,11 +69,11 @@ module DataImplementation = let conn = await (rethinkCfg.CreateConnectionAsync log) RethinkDbData (conn, rethinkCfg, log) elif hasConnStr "PostgreSQL" then - let source = createNpgsqlDataSource config - use conn = source.CreateConnection () + createNpgsqlDataSource config + use conn = Configuration.dataSource().CreateConnection () let log = sp.GetRequiredService> () log.LogInformation $"Using PostgreSQL database {conn.Database}" - PostgresData (source, log, Json.configure (JsonSerializer.CreateDefault ())) + PostgresData (log, Json.configure (JsonSerializer.CreateDefault ())) else createSQLite "Data Source=./myweblog.db;Cache=Shared" @@ -99,7 +100,6 @@ let showHelp () = open System.IO -open System.Linq open BitBadger.AspNetCore.CanonicalDomains open Giraffe open Giraffe.EndpointRouting @@ -111,7 +111,7 @@ open NeoSmart.Caching.Sqlite open RethinkDB.DistributedCache [] -let rec main args = +let main args = let builder = WebApplication.CreateBuilder(args) let _ = builder.Services.Configure(fun (opts : ForwardedHeadersOptions) -> @@ -162,9 +162,7 @@ let rec main args = () | :? PostgresData as postgres -> // ADO.NET Data Sources are designed to work as singletons - let _ = - builder.Services.AddSingleton (fun sp -> - DataImplementation.createNpgsqlDataSource (sp.GetRequiredService ())) + let _ = builder.Services.AddSingleton (Configuration.dataSource ()) let _ = builder.Services.AddSingleton postgres let _ = builder.Services.AddSingleton (fun _ -> -- 2.45.1 From 42d3280f6763be4ee7739fcc917281d16143b63f Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 28 Jul 2023 20:28:03 -0400 Subject: [PATCH 005/123] Add redirect rule to data stores (#39) --- src/MyWebLog.Data/PostgresData.fs | 31 ++++++++++----- src/MyWebLog.Data/RethinkDbData.fs | 36 +++++++++++++----- src/MyWebLog.Data/SQLite/Helpers.fs | 27 ++++++------- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 38 ++++++++++--------- src/MyWebLog.Data/SQLiteData.fs | 40 ++++++++++++++------ src/MyWebLog.Data/Utils.fs | 2 +- src/MyWebLog.Domain/DataTypes.fs | 28 ++++++++------ src/MyWebLog.Domain/SupportTypes.fs | 11 ++++++ 8 files changed, 139 insertions(+), 74 deletions(-) diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 58967d5..66ee047 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -159,14 +159,28 @@ type PostgresData (log : ILogger, ser : JsonSerializer) = exit 1 } + /// Migrate from v2 to v2.1 + let migrateV2ToV2point1 () = backgroundTask { + Utils.logMigrationStep log "v2 to v2.1" "Adding empty redirect rule set to all weblogs" + do! Custom.nonQuery $"UPDATE {Table.WebLog} SET data['RedirectRules'] = '[]'::json" [] + + Utils.logMigrationStep log "v2 to v2.1" "Setting database to version 2.1" + do! setDbVersion "v2.1" + } + /// Do required data migration between versions let migrate version = backgroundTask { - match version with - | Some "v2" -> () - | Some "v2-rc2" -> do! migrateV2Rc2ToV2 () - // Future versions will be inserted here - | Some _ - | None -> + let mutable v = defaultArg version "" + + if v = "v2-rc2" then + do! migrateV2Rc2ToV2 () + v <- "v2" + + if v = "v2" then + do! migrateV2ToV2point1 () + v <- "v2.1" + + if v <> "v2.1" then log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" do! setDbVersion Utils.currentDbVersion } @@ -190,8 +204,5 @@ type PostgresData (log : ILogger, ser : JsonSerializer) = do! ensureTables () let! version = Custom.single "SELECT id FROM db_version" [] (fun row -> row.string "id") - match version with - | Some v when v = Utils.currentDbVersion -> () - | Some _ - | None -> do! migrate version + do! migrate version } diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 9cf340e..7c318a9 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -220,17 +220,37 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger () - | Some v when v = "v2-rc2" -> do! migrateV2Rc2ToV2 () - | Some v when v = "v2-rc1" -> + let mutable v = defaultArg version "" + + if v = "v2-rc1" then do! migrateV2Rc1ToV2Rc2 () + v <- "v2-rc2" + + if v = "v2-rc2" then do! migrateV2Rc2ToV2 () - | Some _ - | None -> + v <- "v2" + + if v = "v2" then + do! migrateV2ToV2point1 () + v <- "v2.1" + + if v <> "v2.1" then log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" do! setDbVersion Utils.currentDbVersion } @@ -1185,7 +1205,5 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger () - | it -> do! migrate (it |> Option.map (fun x -> x.Id)) + do! migrate (List.tryHead version |> Option.map (fun x -> x.Id)) } diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 150085f..5224674 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -271,19 +271,19 @@ module Map = } /// 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 = { + let toWebLog ser 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 @@ -292,6 +292,7 @@ module Map = Copyright = tryString "copyright" rdr CustomFeeds = [] } + RedirectRules = getString "redirect_rules" rdr |> Utils.deserialize ser } /// Create a web log user from the current row in the given data reader diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index aa34719..1bcfbb1 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -26,17 +26,18 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = /// 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) + [ 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) + cmd.Parameters.AddWithValue ("@redirectRules", Utils.serialize ser webLog.RedirectRules) ] |> ignore addWebLogRssParameters cmd webLog @@ -129,10 +130,12 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = 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 + uploads, is_feed_enabled, feed_name, items_in_feed, is_category_enabled, is_tag_enabled, copyright, + redirect_rules ) VALUES ( @id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx, - @uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright + @uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright, + @redirectRules )" addWebLogParameters cmd webLog do! write cmd @@ -145,7 +148,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = cmd.CommandText <- "SELECT * FROM web_log" use! rdr = cmd.ExecuteReaderAsync () let! webLogs = - toList Map.toWebLog rdr + toList (Map.toWebLog ser) rdr |> List.map (fun webLog -> backgroundTask { return! appendCustomFeeds webLog }) |> Task.WhenAll return List.ofArray webLogs @@ -184,7 +187,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = cmd.Parameters.AddWithValue ("@urlBase", url) |> ignore use! rdr = cmd.ExecuteReaderAsync () if rdr.Read () then - let! webLog = appendCustomFeeds (Map.toWebLog rdr) + let! webLog = appendCustomFeeds (Map.toWebLog ser rdr) return Some webLog else return None @@ -197,7 +200,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = addWebLogId cmd webLogId use! rdr = cmd.ExecuteReaderAsync () if rdr.Read () then - let! webLog = appendCustomFeeds (Map.toWebLog rdr) + let! webLog = appendCustomFeeds (Map.toWebLog ser rdr) return Some webLog else return None @@ -223,7 +226,8 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = items_in_feed = @itemsInFeed, is_category_enabled = @isCategoryEnabled, is_tag_enabled = @isTagEnabled, - copyright = @copyright + copyright = @copyright, + redirect_rules = @redirectRules WHERE id = @id" addWebLogParameters cmd webLog do! write cmd diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 6133eb1..89caa0c 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -65,7 +65,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS items_in_feed INTEGER, is_category_enabled INTEGER NOT NULL DEFAULT 0, is_tag_enabled INTEGER NOT NULL DEFAULT 0, - copyright TEXT); + copyright TEXT, + redirect_rules TEXT NOT NULL DEFAULT '[]'); CREATE INDEX web_log_theme_idx ON web_log (theme_id)" if needsTable "web_log_feed" then "CREATE TABLE web_log_feed ( @@ -535,15 +536,34 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS do! setDbVersion "v2" } + /// Migrate from v2 to v2.1 + let migrateV2ToV2point1 () = backgroundTask { + Utils.logMigrationStep log "v2 to v2.1" "Adding redirect rules to web_log table" + use cmd = conn.CreateCommand () + cmd.CommandText <- "ALTER TABLE web_log ADD COLUMN redirect_rules TEXT NOT NULL DEFAULT '[]'" + do! write cmd + + Utils.logMigrationStep log "v2 to v2.1" "Setting database version to v2.1" + do! setDbVersion "v2.1" + } + /// 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" - match version with - | Some v when v = "v2" -> () - | Some v when v = "v2-rc2" -> do! migrateV2Rc2ToV2 () - | Some v when v = "v2-rc1" -> do! migrateV2Rc1ToV2Rc2 () - | Some _ - | None -> + if v = "v2-rc2" then + do! migrateV2Rc2ToV2 () + v <- "v2" + + if v = "v2" then + do! migrateV2ToV2point1 () + v <- "v2.1" + + if v <> "v2.1" then log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" do! setDbVersion Utils.currentDbVersion } @@ -580,9 +600,5 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT id FROM db_version" use! rdr = cmd.ExecuteReaderAsync () - let version = if rdr.Read () then Some (Map.getString "id" rdr) else None - match version with - | Some v when v = "v2-rc2" -> () - | Some _ - | None -> do! migrate version + do! migrate (if rdr.Read () then Some (Map.getString "id" rdr) else None) } diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index 9f08592..c241a65 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -6,7 +6,7 @@ open MyWebLog open MyWebLog.ViewModels /// The current database version -let currentDbVersion = "v2" +let currentDbVersion = "v2.1" /// Create a category hierarchy from the given list of categories let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq { diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index 87b9a1c..c547389 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -375,6 +375,9 @@ type WebLog = /// Where uploads are placed Uploads : UploadDestination + + /// Redirect rules for this weblog + RedirectRules : RedirectRule list } /// Functions to support web logs @@ -382,18 +385,19 @@ module WebLog = /// An empty web log let empty = - { Id = WebLogId.empty - Name = "" - Slug = "" - Subtitle = None - DefaultPage = "" - PostsPerPage = 10 - ThemeId = ThemeId "default" - UrlBase = "" - TimeZone = "" - Rss = RssOptions.empty - AutoHtmx = false - Uploads = Database + { Id = WebLogId.empty + Name = "" + Slug = "" + Subtitle = None + DefaultPage = "" + PostsPerPage = 10 + ThemeId = ThemeId "default" + UrlBase = "" + TimeZone = "" + Rss = RssOptions.empty + AutoHtmx = false + Uploads = Database + RedirectRules = [] } /// Get the host (including scheme) and extra path from the URL base diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 4753583..4a525c7 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -422,6 +422,17 @@ module PostId = let create () = PostId (newId ()) +/// A redirection for a previously valid URL +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 + } + + /// An identifier for a custom feed type CustomFeedId = CustomFeedId of string -- 2.45.1 From 3ef4499a9031397e399c9708363e43c5b414c718 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 28 Jul 2023 22:07:13 -0400 Subject: [PATCH 006/123] Add redirect index page (#39) - Bump version to 2.1 --- src/MyWebLog.Data/RethinkDbData.fs | 2 +- src/MyWebLog/Handlers/Admin.fs | 25 +++++++++--- src/MyWebLog/Handlers/Routes.fs | 3 ++ src/MyWebLog/appsettings.json | 1 + src/admin-theme/redirect-list.liquid | 58 ++++++++++++++++++++++++++++ src/admin-theme/settings.liquid | 3 +- src/admin-theme/version.txt | 2 +- 7 files changed, 85 insertions(+), 9 deletions(-) create mode 100644 src/admin-theme/redirect-list.liquid diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 7c318a9..ccf4ef2 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -226,7 +226,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj ] write; withRetryOnce; ignoreResult conn } diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 30ebac4..1808676 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -7,7 +7,7 @@ open MyWebLog open MyWebLog.ViewModels open NodaTime -/// ~~ DASHBOARDS ~~ +/// ~~~ DASHBOARDS ~~~ module Dashboard = // GET /admin/dashboard @@ -75,7 +75,7 @@ module Dashboard = let toAdminDashboard : HttpHandler = redirectToGet "admin/administration" -/// ~~ CACHES ~~ +/// ~~~ CACHES ~~~ module Cache = // POST /admin/cache/web-log/{id}/refresh @@ -126,7 +126,7 @@ module Cache = } -/// ~~ CATEGORIES ~~ +/// ~~~ CATEGORIES ~~~ module Category = open MyWebLog.Data @@ -214,7 +214,20 @@ module Category = } -/// ~~ TAG MAPPINGS ~~ +/// ~~~ REDIRECT RULES ~~~ +module RedirectRules = + + // GET /admin/redirect-rules + let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + return! + hashForPage "Redirect Rules" + |> withAntiCsrf ctx + |> addToHash "redirections" ctx.WebLog.RedirectRules + |> adminView "redirect-list" next ctx + } + + +/// ~~~ TAG MAPPINGS ~~~ module TagMapping = open Microsoft.AspNetCore.Http @@ -278,7 +291,7 @@ module TagMapping = } -/// ~~ THEMES ~~ +/// ~~~ THEMES ~~~ module Theme = open System @@ -440,7 +453,7 @@ module Theme = } -/// ~~ WEB LOG SETTINGS ~~ +/// ~~~ WEB LOG SETTINGS ~~~ module WebLog = open System.Collections.Generic diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index e664a9d..0c82308 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -130,6 +130,9 @@ let router : HttpHandler = choose [ routef "/%s/revision/%s/preview" Post.previewRevision routef "/%s/revisions" Post.editRevisions ]) + subRoute "/redirect-rules" (choose [ + route "" >=> Admin.RedirectRules.all + ]) subRoute "/settings" (choose [ route "" >=> Admin.WebLog.settings routef "/rss/%s/edit" Feed.editCustomFeed diff --git a/src/MyWebLog/appsettings.json b/src/MyWebLog/appsettings.json index e89af6d..5956ea7 100644 --- a/src/MyWebLog/appsettings.json +++ b/src/MyWebLog/appsettings.json @@ -1,5 +1,6 @@ { "Generator": "myWebLog 2.0", + "Generator": "myWebLog 2.1", "Logging": { "LogLevel": { "MyWebLog.Handlers": "Information" diff --git a/src/admin-theme/redirect-list.liquid b/src/admin-theme/redirect-list.liquid new file mode 100644 index 0000000..88ff325 --- /dev/null +++ b/src/admin-theme/redirect-list.liquid @@ -0,0 +1,58 @@ +

Redirect Rules

+
+ « Back to Settings +
+
+
+ {%- assign redir_count = redirections | size -%} + {% if redir_count > 0 -%} +
+
+
From
+
To
+
RegEx?
+
+
+
+ +
+ {% for redir in redirections -%} + {%- assign map_id = mapping_ids | value: map.tag -%} +
+
+ {{ redir.from }}
+ + {%- assign redir_url = "admin/settings/redirect-rules/" | append: forloop.index0 -%} + + Edit + + {% unless forloop.first %} + • + {%- assign move_up = redir_url | append: "/up" | relative_link -%} + Move Up + {% endunless %} + {% unless forloop.last %} + • + {%- assign move_down = redir_url | append: "/down" | relative_link -%} + Move Down + {% endunless %} + • + {%- assign del_url = redir_url | append: "/delete" | relative_link -%} + Delete + +
+
{{ redir.to }}
+
{% if redir.is_regex %}Yes{% else %}No{% endif %}
+
+ {%- endfor %} +
+ {%- else -%} +
+

This web log has no redirect rules defined

+
+ {%- endif %} +
+
+
+
diff --git a/src/admin-theme/settings.liquid b/src/admin-theme/settings.liquid index ab956f8..92c5649 100644 --- a/src/admin-theme/settings.liquid +++ b/src/admin-theme/settings.liquid @@ -2,7 +2,8 @@

Go to: Users • RSS Settings • - Tag Mappings + Tag Mappings • + Redirect Rules

Web Log Settings diff --git a/src/admin-theme/version.txt b/src/admin-theme/version.txt index 821af72..eb1fc5a 100644 --- a/src/admin-theme/version.txt +++ b/src/admin-theme/version.txt @@ -1,2 +1,2 @@ myWebLog Admin -2.0.0 \ No newline at end of file +2.1.0 \ No newline at end of file -- 2.45.1 From dc6b066e79b1411796a65e0c01b5dd876b7462f2 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 30 Jul 2023 21:00:31 -0400 Subject: [PATCH 007/123] Rule add/edit/move/delete works (#39) - Begin moving auth to route definition where practical - Fix typo on post list page --- src/MyWebLog.Data/Interfaces.fs | 3 + .../Postgres/PostgresWebLogData.fs | 20 +++- src/MyWebLog.Data/PostgresData.fs | 2 +- src/MyWebLog.Data/RethinkDbData.fs | 7 ++ src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 48 ++++---- src/MyWebLog.Domain/SupportTypes.fs | 12 ++ src/MyWebLog.Domain/ViewModels.fs | 37 +++++++ src/MyWebLog/DotLiquidBespoke.fs | 18 +-- src/MyWebLog/Handlers/Admin.fs | 104 +++++++++++++++--- src/MyWebLog/Handlers/Routes.fs | 31 ++++-- src/MyWebLog/Handlers/User.fs | 6 +- src/admin-theme/post-list.liquid | 2 +- src/admin-theme/redirect-edit.liquid | 48 ++++++++ src/admin-theme/redirect-list.liquid | 79 +++++++------ src/admin-theme/settings.liquid | 2 +- 15 files changed, 322 insertions(+), 97 deletions(-) create mode 100644 src/admin-theme/redirect-edit.liquid diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index f064cc4..0ec05d5 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -259,6 +259,9 @@ type IWebLogData = /// Find a web log by its ID abstract member FindById : WebLogId -> Task + /// Update redirect rules for a web log + abstract member UpdateRedirectRules : WebLog -> Task + /// Update RSS options for a web log abstract member UpdateRssOptions : WebLog -> Task diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index 713005b..ef6020c 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -45,11 +45,13 @@ type PostgresWebLogData (log : ILogger) = log.LogTrace "WebLog.findById" Find.byId Table.WebLog (WebLogId.toString webLogId) - /// Update settings for a web log - let updateSettings (webLog : WebLog) = - log.LogTrace "WebLog.updateSettings" - Update.full Table.WebLog (WebLogId.toString webLog.Id) webLog - + let updateRedirectRules (webLog : WebLog) = backgroundTask { + log.LogTrace "WebLog.updateRedirectRules" + match! findById webLog.Id with + | Some _ -> + do! Update.partialById Table.WebLog (WebLogId.toString webLog.Id) {| RedirectRules = webLog.RedirectRules |} + | None -> () + } /// Update RSS options for a web log let updateRssOptions (webLog : WebLog) = backgroundTask { log.LogTrace "WebLog.updateRssOptions" @@ -58,11 +60,17 @@ type PostgresWebLogData (log : ILogger) = | None -> () } + /// Update settings for a web log + let updateSettings (webLog : WebLog) = + log.LogTrace "WebLog.updateSettings" + Update.full Table.WebLog (WebLogId.toString 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 _.UpdateSettings webLog = updateSettings webLog + member _.UpdateRedirectRules webLog = updateRedirectRules webLog member _.UpdateRssOptions webLog = updateRssOptions webLog + member _.UpdateSettings webLog = updateSettings webLog diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 66ee047..0b788b0 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -162,7 +162,7 @@ type PostgresData (log : ILogger, ser : JsonSerializer) = /// Migrate from v2 to v2.1 let migrateV2ToV2point1 () = backgroundTask { Utils.logMigrationStep log "v2 to v2.1" "Adding empty redirect rule set to all weblogs" - do! Custom.nonQuery $"UPDATE {Table.WebLog} SET data['RedirectRules'] = '[]'::json" [] + do! Custom.nonQuery $"""UPDATE {Table.WebLog} SET data = data + '{{ "RedirectRules": [] }}'::json""" [] Utils.logMigrationStep log "v2 to v2.1" "Setting database to version 2.1" do! setDbVersion "v2.1" diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index ccf4ef2..73a625f 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -1031,6 +1031,13 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj ] + write; withRetryDefault; ignoreResult conn + } + member _.UpdateRssOptions webLog = rethink { withTable Table.WebLog get webLog.Id diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index 1bcfbb1..f4b64e7 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -206,6 +206,33 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = return None } + /// Update redirect rules for a web log + let updateRedirectRules webLog = backgroundTask { + use cmd = conn.CreateCommand () + cmd.CommandText <- "UPDATE web_log SET redirect_rules = @redirectRules WHERE id = @id" + cmd.Parameters.AddWithValue ("@redirectRules", Utils.serialize ser webLog.RedirectRules) |> ignore + cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore + do! write cmd + } + + /// 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 + cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore + do! write cmd + do! updateCustomFeeds webLog + } + /// Update settings for a web log let updateSettings webLog = backgroundTask { use cmd = conn.CreateCommand () @@ -233,29 +260,12 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = do! write cmd } - /// 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 - cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore - do! write cmd - do! updateCustomFeeds 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 _.UpdateSettings webLog = updateSettings webLog + member _.UpdateRedirectRules webLog = updateRedirectRules webLog member _.UpdateRssOptions webLog = updateRssOptions webLog + member _.UpdateSettings webLog = updateSettings webLog diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 4a525c7..1ece831 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -426,12 +426,24 @@ module PostId = 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 } +/// Functions to support redirect rules +module RedirectRule = + + /// An empty redirect rule + let empty = + { From = "" + To = "" + IsRegex = false + } + /// An identifier for a custom feed type CustomFeedId = CustomFeedId of string diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index f7d204f..61ece89 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -807,6 +807,43 @@ type EditPostModel = } +/// View model to add/edit a redirect rule +[] +type EditRedirectRuleModel = + { /// The ID (index) of the rule being edited + RuleId : int + + /// The "from" side of the rule + From : string + + /// The "to" side of the rule + To : string + + /// Whether this rule uses a regular expression + IsRegex : bool + + /// Whether a new rule should be inserted at the top or appended to the end (ignored for edits) + InsertAtTop : bool + } + + /// Create a model from an existing rule + static member fromRule idx (rule : RedirectRule) = + { RuleId = idx + From = rule.From + To = rule.To + IsRegex = rule.IsRegex + InsertAtTop = false + } + + /// Update a rule with the values from this model + member this.UpdateRule (rule : RedirectRule) = + { rule with + From = this.From + To = this.To + IsRegex = this.IsRegex + } + + /// View model to edit RSS settings [] type EditRssModel = diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 4cbd799..83e9a3f 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -224,15 +224,17 @@ let register () = Template.RegisterTag "user_links" [ // Domain types - typeof; typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof; typeof // View models - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 1808676..4025843 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -132,7 +132,7 @@ module Category = open MyWebLog.Data // GET /admin/categories - let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + let all : HttpHandler = fun next ctx -> task { match! TemplateCache.get adminTheme "category-list-body" ctx.Data with | Ok catListTemplate -> let! hash = @@ -146,14 +146,14 @@ module Category = } // GET /admin/categories/bare - let bare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> + let bare : HttpHandler = fun next ctx -> hashForPage "Categories" |> withAntiCsrf ctx |> adminBareView "category-list-body" next ctx // GET /admin/category/{id}/edit - let edit 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" }) @@ -173,7 +173,7 @@ module Category = } // POST /admin/category/save - let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + let save : HttpHandler = fun next ctx -> task { let data = ctx.Data let! model = ctx.BindFormAsync () let category = @@ -196,7 +196,7 @@ module Category = } // POST /admin/category/{id}/delete - let delete catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + let delete catId : HttpHandler = fun next ctx -> task { let! result = ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id match result with | CategoryDeleted @@ -217,8 +217,10 @@ module Category = /// ~~~ REDIRECT RULES ~~~ module RedirectRules = - // GET /admin/redirect-rules - let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + open Microsoft.AspNetCore.Http + + // GET /admin/settings/redirect-rules + let all : HttpHandler = fun next ctx -> task { return! hashForPage "Redirect Rules" |> withAntiCsrf ctx @@ -226,6 +228,82 @@ module RedirectRules = |> adminView "redirect-list" next ctx } + // GET /admin/settings/redirect-rules/[index] + let edit idx : HttpHandler = fun next ctx -> task { + if idx = -1 then + return! + hashForPage "Add Redirect Rule" + |> addToHash "model" (EditRedirectRuleModel.fromRule -1 RedirectRule.empty) + |> withAntiCsrf ctx + |> adminBareView "redirect-edit" next ctx + else + let rules = ctx.WebLog.RedirectRules + if rules.Length < idx || idx < 0 then + return! Error.notFound next ctx + else + return! + hashForPage "Edit Redirect Rule" + |> addToHash "model" (EditRedirectRuleModel.fromRule idx (List.item idx rules)) + |> withAntiCsrf ctx + |> adminBareView "redirect-edit" 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 () + let isNew = idx = -1 + let rules = ctx.WebLog.RedirectRules + let rule = model.UpdateRule (if isNew then RedirectRule.empty else List.item idx rules) + let newRules = + match isNew with + | true when model.InsertAtTop -> List.insertAt 0 rule rules + | true -> List.insertAt (rules.Length) rule rules + | false -> rules |> List.removeAt idx |> List.insertAt idx rule + do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } + 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 + } + + // POST /admin/settings/redirect-rules/[index]/delete + 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 = @@ -243,7 +321,7 @@ module TagMapping = } // GET /admin/settings/tag-mappings - let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + let all : HttpHandler = fun next ctx -> task { let! hash = hashForPage "" |> withAntiCsrf ctx @@ -252,7 +330,7 @@ module TagMapping = } // GET /admin/settings/tag-mapping/{id}/edit - let edit 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" } @@ -268,7 +346,7 @@ module TagMapping = } // POST /admin/settings/tag-mapping/save - let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + let save : HttpHandler = fun next ctx -> task { let data = ctx.Data let! model = ctx.BindFormAsync () let tagMap = @@ -283,7 +361,7 @@ module TagMapping = } // POST /admin/settings/tag-mapping/{id}/delete - let delete tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + 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" } @@ -460,7 +538,7 @@ 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 match! TemplateCache.get adminTheme "user-list-body" data with | Ok userTemplate -> @@ -508,7 +586,7 @@ module WebLog = } // 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 () match! data.WebLog.FindById ctx.WebLog.Id with diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 0c82308..3b8f74d 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -107,7 +107,7 @@ let router : HttpHandler = choose [ subRoute "/admin" (requireUser >=> choose [ GET_HEAD >=> choose [ route "/administration" >=> Admin.Dashboard.admin - subRoute "/categor" (choose [ + subRoute "/categor" (requireAccess WebLogAdmin >=> choose [ route "ies" >=> Admin.Category.all route "ies/bare" >=> Admin.Category.bare routef "y/%s/edit" Admin.Category.edit @@ -130,20 +130,21 @@ let router : HttpHandler = choose [ routef "/%s/revision/%s/preview" Post.previewRevision routef "/%s/revisions" Post.editRevisions ]) - subRoute "/redirect-rules" (choose [ - route "" >=> Admin.RedirectRules.all - ]) - subRoute "/settings" (choose [ - route "" >=> Admin.WebLog.settings - routef "/rss/%s/edit" Feed.editCustomFeed - subRoute "/user" (choose [ - route "s" >=> User.all - routef "/%s/edit" User.edit + 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.TagMapping.all routef "/%s/edit" Admin.TagMapping.edit ]) + subRoute "/user" (choose [ + route "s" >=> User.all + routef "/%s/edit" User.edit + ]) ]) subRoute "/theme" (choose [ route "/list" >=> Admin.Theme.all @@ -159,7 +160,7 @@ let router : HttpHandler = choose [ routef "/theme/%s/refresh" Admin.Cache.refreshTheme routef "/web-log/%s/refresh" Admin.Cache.refreshWebLog ]) - subRoute "/category" (choose [ + subRoute "/category" (requireAccess WebLogAdmin >=> choose [ route "/save" >=> Admin.Category.save routef "/%s/delete" Admin.Category.delete ]) @@ -180,13 +181,19 @@ let router : HttpHandler = choose [ routef "/%s/revision/%s/restore" Post.restoreRevision routef "/%s/revisions/purge" Post.purgeRevisions ]) - subRoute "/settings" (choose [ + 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 "/redirect-rules" (choose [ + routef "/%i" Admin.RedirectRules.save + routef "/%i/up" Admin.RedirectRules.moveUp + routef "/%i/down" Admin.RedirectRules.moveDown + routef "/%i/delete" Admin.RedirectRules.delete + ]) subRoute "/tag-mapping" (choose [ route "/save" >=> Admin.TagMapping.save routef "/%s/delete" Admin.TagMapping.delete diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 6a67a61..43d9ccc 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -95,7 +95,7 @@ open Giraffe.Htmx let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" // GET /admin/settings/users -let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { +let all : HttpHandler = fun next ctx -> task { let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id return! hashForPage "User Administration" @@ -119,7 +119,7 @@ let private showEdit (model : EditUserModel) : HttpHandler = fun next ctx -> |> adminBareView "user-edit" next ctx // GET /admin/settings/user/{id}/edit -let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { +let edit usrId : HttpHandler = fun next ctx -> task { let isNew = usrId = "new" let userId = WebLogUserId usrId let tryUser = @@ -131,7 +131,7 @@ let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> tas } // POST /admin/settings/user/{id}/delete -let delete userId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { +let delete userId : HttpHandler = fun next ctx -> task { let data = ctx.Data match! data.WebLogUser.FindById (WebLogUserId userId) ctx.WebLog.Id with | Some user -> diff --git a/src/admin-theme/post-list.liquid b/src/admin-theme/post-list.liquid index b597187..ffb9994 100644 --- a/src/admin-theme/post-list.liquid +++ b/src/admin-theme/post-list.liquid @@ -54,7 +54,7 @@ • {%- assign post_del_link = "admin/post/" | append: post.id | append: "/delete" | relative_link -%} + hx-confirm="Are you sure you want to delete the post “{{ post.title | strip_html | escape }}”? This action cannot be undone."> Delete {% endif %} diff --git a/src/admin-theme/redirect-edit.liquid b/src/admin-theme/redirect-edit.liquid new file mode 100644 index 0000000..d35172d --- /dev/null +++ b/src/admin-theme/redirect-edit.liquid @@ -0,0 +1,48 @@ +

{% if model.rule_id < 0 %}Add{% else %}Edit{% endif %} Redirect Rule

+{%- assign post_url = "admin/settings/redirect-rules/" | append: model.rule_id | relative_link -%} +
+ + +
+
+
+ + +
+
+
+
+ + +
+
+
+
+ + +
+
+
+ {% if model.rule_id < 0 %} +
+
+ +
+ + + + +
+
+
+ {% endif %} +
+
+ + Cancel +
+
+
diff --git a/src/admin-theme/redirect-list.liquid b/src/admin-theme/redirect-list.liquid index 88ff325..232ead0 100644 --- a/src/admin-theme/redirect-list.liquid +++ b/src/admin-theme/redirect-list.liquid @@ -1,7 +1,17 @@ -

Redirect Rules

+

{{ page_title }}

- « Back to Settings +

+ « Back to Settings +

+
+
+ + Add Redirect Rule + +
+
{%- assign redir_count = redirections | size -%} @@ -13,42 +23,45 @@
RegEx?
-
+
+ -
- {% for redir in redirections -%} - {%- assign map_id = mapping_ids | value: map.tag -%} -
-
- {{ redir.from }}
- - {%- assign redir_url = "admin/settings/redirect-rules/" | append: forloop.index0 -%} - - Edit - - {% unless forloop.first %} - • - {%- assign move_up = redir_url | append: "/up" | relative_link -%} - Move Up - {% endunless %} - {% unless forloop.last %} - • - {%- assign move_down = redir_url | append: "/down" | relative_link -%} - Move Down - {% endunless %} + {% for redir in redirections -%} + {%- assign redir_id = "redir_" | append: forloop.index0 -%} +
+
+ {{ redir.from }}
+ + {%- assign redir_url = "admin/settings/redirect-rules/" | append: forloop.index0 -%} + + Edit + + {% unless forloop.first %} • - {%- assign del_url = redir_url | append: "/delete" | relative_link -%} - Delete - -
-
{{ redir.to }}
-
{% if redir.is_regex %}Yes{% else %}No{% endif %}
+ {%- assign move_up = redir_url | append: "/up" | relative_link -%} + Move Up + {% endunless %} + {% unless forloop.last %} + • + {%- assign move_down = redir_url | append: "/down" | relative_link -%} + Move Down + {% endunless %} + • + {%- assign del_url = redir_url | append: "/delete" | relative_link -%} + + Delete + +
- {%- endfor %} +
{{ redir.to }}
+
{% if redir.is_regex %}Yes{% else %}No{% endif %}
+
+ {%- endfor %} {%- else -%} -
+

This web log has no redirect rules defined

{%- endif %} diff --git a/src/admin-theme/settings.liquid b/src/admin-theme/settings.liquid index 92c5649..ed75e5c 100644 --- a/src/admin-theme/settings.liquid +++ b/src/admin-theme/settings.liquid @@ -3,7 +3,7 @@

Go to: Users • RSS Settings • Tag Mappings • - Redirect Rules + Redirect Rules

Web Log Settings -- 2.45.1 From 693a1df34fff13e782dc4081bf1297ebe01ad487 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 30 Jul 2023 22:26:30 -0400 Subject: [PATCH 008/123] Redirect plain-text rules (#39) regex still untested --- src/MyWebLog/Caches.fs | 28 +++++++++++++++++++++++++++- src/MyWebLog/Program.fs | 25 +++++++++++++++++++++++++ 2 files changed, 52 insertions(+), 1 deletion(-) diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index 2c4e74b..2b66b59 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -65,9 +65,21 @@ open System.Collections.Concurrent /// settings update page 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 () + /// Try to get the web log for the current request (longest matching URL base wins) let tryGet (path : string) = _cache @@ -78,6 +90,16 @@ module WebLogCache = /// 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 webLog + 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.Substring 1)}" else it.From + RegEx (new Regex (pattern, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo) + else + Text (relUrl it.From, urlTo)) /// Get all cached web logs let all () = @@ -86,9 +108,13 @@ module WebLogCache = /// 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) diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index cd462bb..2a94084 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -26,6 +26,30 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger) } +/// Middleware to check redirects for the current web log +type RedirectRuleMiddleware (next : RequestDelegate, log : ILogger) = + + /// 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) -> + log.LogInformation $"Checking {path} against from={urlFrom} and to={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 BitBadger.Npgsql.FSharp.Documents open Microsoft.Extensions.DependencyInjection @@ -207,6 +231,7 @@ let main args = let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) let _ = app.UseMiddleware () + let _ = app.UseMiddleware () let _ = app.UseAuthentication () let _ = app.UseStaticFiles () let _ = app.UseRouting () -- 2.45.1 From f43c431278a6efbad7472184088cd3b25ba71c15 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 31 Jul 2023 20:56:27 -0400 Subject: [PATCH 009/123] Verify regex rules work correctly (#39) - Remove debug for plain-text rules - Update htmx libs to 1.9.4 --- src/MyWebLog/MyWebLog.fsproj | 4 ++-- src/MyWebLog/Program.fs | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 037c8b9..7b21a1c 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -26,8 +26,8 @@ - - + + diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 2a94084..a48fc2e 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -40,7 +40,6 @@ type RedirectRuleMiddleware (next : RequestDelegate, log : ILogger List.tryPick (fun rule -> match rule with | WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) -> - log.LogInformation $"Checking {path} against from={urlFrom} and to={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) -- 2.45.1 From 79c304493c839865a8b71a9a129e9d077019d329 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 31 Jul 2023 21:28:02 -0400 Subject: [PATCH 010/123] Add doc link to redirect page (#39) - Tweak redirect list style - Add rules to v2.0 backup restorations --- src/MyWebLog/Maintenance.fs | 6 +++++- src/admin-theme/redirect-list.liquid | 17 +++++++++++------ 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 544de4f..8413504 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -384,7 +384,11 @@ module Backup = // Restore web log data printfn "- Restoring web log..." - do! data.WebLog.Add restore.WebLog + // 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..." do! data.WebLogUser.Restore restore.Users diff --git a/src/admin-theme/redirect-list.liquid b/src/admin-theme/redirect-list.liquid index 232ead0..721c862 100644 --- a/src/admin-theme/redirect-list.liquid +++ b/src/admin-theme/redirect-list.liquid @@ -18,9 +18,9 @@ {% if redir_count > 0 -%}
-
From
-
To
-
RegEx?
+
From
+
To
+
RegEx?
@@ -29,7 +29,7 @@ {% for redir in redirections -%} {%- assign redir_id = "redir_" | append: forloop.index0 -%}
-
+
{{ redir.from }}
{%- assign redir_url = "admin/settings/redirect-rules/" | append: forloop.index0 -%} @@ -55,8 +55,8 @@
-
{{ redir.to }}
-
{% if redir.is_regex %}Yes{% else %}No{% endif %}
+
{{ redir.to }}
+
{% if redir.is_regex %}Yes{% else %}No{% endif %}
{%- endfor %} @@ -68,4 +68,9 @@
+

+ This is an advanced feature; please + read and understand the documentation on this feature before adding rules. +

-- 2.45.1 From b84a0f711f6c7822cbd619003a568a8d6e511aec Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 31 Jul 2023 22:17:14 -0400 Subject: [PATCH 011/123] Add chapter data type (#6) --- src/MyWebLog.Data/SQLiteData.fs | 2 ++ src/MyWebLog.Domain/SupportTypes.fs | 39 +++++++++++++++++++++++++++++ src/MyWebLog.Domain/ViewModels.fs | 1 + 3 files changed, 42 insertions(+) diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 89caa0c..c8248a9 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -318,6 +318,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS Subtitle = Map.tryString "subtitle" epRdr Explicit = Map.tryString "explicit" epRdr |> Option.map ExplicitRating.parse + Chapters = Map.tryString "chapters" epRdr + |> Option.map (Utils.deserialize ser) ChapterFile = Map.tryString "chapter_file" epRdr ChapterType = Map.tryString "chapter_type" epRdr TranscriptUrl = Map.tryString "transcript_url" epRdr diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 1ece831..fb277ba 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -161,6 +161,41 @@ module ExplicitRating = | x -> raise (invalidArg "rating" $"{x} is not a valid explicit rating") +/// 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 option + + /// 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 + + /// 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 + } + + open NodaTime.Text /// A podcast episode @@ -186,6 +221,9 @@ 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 @@ -229,6 +267,7 @@ module Episode = ImageUrl = None Subtitle = None Explicit = None + Chapters = None ChapterFile = None ChapterType = None TranscriptUrl = None diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 61ece89..86f00a7 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -788,6 +788,7 @@ type EditPostModel = ImageUrl = noneIfBlank this.ImageUrl Subtitle = noneIfBlank this.Subtitle Explicit = noneIfBlank this.Explicit |> Option.map ExplicitRating.parse + Chapters = match post.Episode with Some e -> e.Chapters | None -> None ChapterFile = noneIfBlank this.ChapterFile ChapterType = noneIfBlank this.ChapterType TranscriptUrl = noneIfBlank this.TranscriptUrl -- 2.45.1 From 715e545ed57c540d1a6866326f8069124e55833e Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 13 Dec 2023 14:17:53 -0500 Subject: [PATCH 012/123] Update deps - Add .NET 8 target - Remove ID param for Postgres doc calls --- src/Directory.Build.props | 2 +- src/MyWebLog.Data/MyWebLog.Data.fsproj | 16 ++++++---------- .../Postgres/PostgresCategoryData.fs | 2 +- src/MyWebLog.Data/Postgres/PostgresPageData.fs | 2 +- src/MyWebLog.Data/Postgres/PostgresPostData.fs | 2 +- src/MyWebLog.Data/Postgres/PostgresTagMapData.fs | 2 +- src/MyWebLog.Data/Postgres/PostgresThemeData.fs | 2 +- src/MyWebLog.Data/Postgres/PostgresWebLogData.fs | 2 +- .../Postgres/PostgresWebLogUserData.fs | 2 +- src/MyWebLog/MyWebLog.fsproj | 1 - 10 files changed, 14 insertions(+), 19 deletions(-) diff --git a/src/Directory.Build.props b/src/Directory.Build.props index e376d97..548e37b 100644 --- a/src/Directory.Build.props +++ b/src/Directory.Build.props @@ -1,6 +1,6 @@ - net6.0;net7.0 + net6.0;net7.0;net8.0 embedded 2.1.0.0 2.1.0.0 diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 6a6ae75..707825c 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -5,21 +5,17 @@ - - - - + + + + - - + + - - - - diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index 244faed..5b703fa 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -122,7 +122,7 @@ type PostgresCategoryData (log : ILogger) = /// Save a category let save (cat : Category) = backgroundTask { log.LogTrace "Category.save" - do! save Table.Category (CategoryId.toString cat.Id) cat + do! save Table.Category cat } /// Restore categories from a backup diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index faa4c79..6feb078 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -145,7 +145,7 @@ type PostgresPageData (log : ILogger) = let save (page : Page) = backgroundTask { log.LogTrace "Page.save" let! oldPage = findFullById page.Id page.WebLogId - do! save Table.Page (PageId.toString page.Id) { page with Revisions = [] } + do! save Table.Page { page with Revisions = [] } do! updatePageRevisions page.Id (match oldPage with Some p -> p.Revisions | None -> []) page.Revisions () } diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index d3791de..ac676e7 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -175,7 +175,7 @@ type PostgresPostData (log : ILogger) = let save (post : Post) = backgroundTask { log.LogTrace "Post.save" let! oldPost = findFullById post.Id post.WebLogId - do! save Table.Post (PostId.toString post.Id) { post with Revisions = [] } + do! save Table.Post { post with Revisions = [] } do! updatePostRevisions post.Id (match oldPost with Some p -> p.Revisions | None -> []) post.Revisions } diff --git a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs index 6c0aa52..210dc14 100644 --- a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -46,7 +46,7 @@ type PostgresTagMapData (log : ILogger) = /// Save a tag mapping let save (tagMap : TagMap) = - save Table.TagMap (TagMapId.toString tagMap.Id) tagMap + save Table.TagMap tagMap /// Restore tag mappings from a backup let restore (tagMaps : TagMap list) = backgroundTask { diff --git a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs index 00af329..cf3a569 100644 --- a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs @@ -47,7 +47,7 @@ type PostgresThemeData (log : ILogger) = /// Save a theme let save (theme : Theme) = log.LogTrace "Theme.save" - save Table.Theme (ThemeId.toString theme.Id) theme + save Table.Theme theme interface IThemeData with member _.All () = all () diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index ef6020c..f583cc2 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -11,7 +11,7 @@ type PostgresWebLogData (log : ILogger) = /// Add a web log let add (webLog : WebLog) = log.LogTrace "WebLog.add" - insert Table.WebLog (WebLogId.toString webLog.Id) webLog + insert Table.WebLog webLog /// Retrieve all web logs let all () = diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs index 80eeee3..32b912e 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -85,7 +85,7 @@ type PostgresWebLogUserData (log : ILogger) = /// Save a user let save (user : WebLogUser) = log.LogTrace "WebLogUser.save" - save Table.WebLogUser (WebLogUserId.toString user.Id) user + save Table.WebLogUser user interface IWebLogUserData with member _.Add user = save user diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 7b21a1c..a270487 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -31,7 +31,6 @@ - -- 2.45.1 From ec2d43acde8427c5a980678ec50a7ce3fffa3636 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 13 Dec 2023 15:43:35 -0500 Subject: [PATCH 013/123] WIP on SQLite/JSON data --- src/MyWebLog.Data/SQLite/Helpers.fs | 57 +++ src/MyWebLog.Data/SQLiteData.fs | 195 +++------ src/MyWebLog.Domain/DataTypes.fs | 637 ++++++++++++++-------------- src/MyWebLog.Domain/SupportTypes.fs | 515 +++++++++++----------- src/MyWebLog.Domain/ViewModels.fs | 259 +++++------ src/MyWebLog/Caches.fs | 2 +- src/MyWebLog/Handlers/Page.fs | 2 +- src/MyWebLog/Handlers/Post.fs | 2 +- src/MyWebLog/Handlers/Routes.fs | 2 +- 9 files changed, 819 insertions(+), 852 deletions(-) diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 5224674..2a4f06a 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -2,6 +2,63 @@ [] module MyWebLog.Data.SQLite.Helpers +/// The table names used in the SQLite implementation +[] +module Table = + + /// Categories + [] + let Category = "category" + + /// Database Version + [] + let DbVersion = "db_version" + + /// Pages + [] + let Page = "page" + + /// Page Revisions + [] + let PageRevision = "page_revision" + + /// Posts + [] + let Post = "post" + + /// Post Comments + [] + let PostComment = "post_comment" + + /// Post Revisions + [] + let PostRevision = "post_revision" + + /// Tag/URL Mappings + [] + let TagMap = "tag_map" + + /// Themes + [] + let Theme = "theme" + + /// Theme Assets + [] + let ThemeAsset = "theme_asset" + + /// Uploads + [] + let Upload = "upload" + + /// Web Logs + [] + let WebLog = "web_log" + + /// Users + [] + let WebLogUser = "web_log_user" + + open System open Microsoft.Data.Sqlite open MyWebLog diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index c8248a9..d1a3aaf 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -27,17 +27,9 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS not (List.contains table tables) seq { // Theme tables - if needsTable "theme" then - "CREATE TABLE theme ( - id TEXT PRIMARY KEY, - name TEXT NOT NULL, - version TEXT NOT NULL)" - if needsTable "theme_template" then - "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))" + if needsTable Table.Theme then + $"CREATE TABLE {Table.Theme} (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{Table.Theme}_key ON {Table.Theme} (data ->> 'Id')"; if needsTable "theme_asset" then "CREATE TABLE theme_asset ( theme_id TEXT NOT NULL REFERENCES theme (id), @@ -46,139 +38,54 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS data BLOB NOT NULL, PRIMARY KEY (theme_id, path))" - // Web log tables - if needsTable "web_log" then - "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, - redirect_rules TEXT NOT NULL DEFAULT '[]'); - CREATE INDEX web_log_theme_idx ON web_log (theme_id)" - if needsTable "web_log_feed" then - "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, - podcast TEXT); - CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)" + // Web log table + if needsTable Table.WebLog then + $"CREATE TABLE {Table.WebLog} (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{Table.WebLog}_key ON {Table.WebLog} (data ->> 'Id')" // Category table - if needsTable "category" then - "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)" + if needsTable Table.Category then + $"CREATE TABLE {Table.Category} (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{Table.Category}_key ON {Table.Category} (data -> 'Id'); + CREATE INDEX idx_{Table.Category}_web_log ON {Table.Category} (data ->> 'WebLogId')" // Web log user table - if needsTable "web_log_user" then - "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, - 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)" + if needsTable Table.WebLogUser then + $"CREATE TABLE web_log_user (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{Table.WebLogUser}_key ON {Table.WebLogUser} (data ->> 'Id'); + CREATE INDEX idx_{Table.WebLogUser}_email ON {Table.WebLogUser} (data ->> 'WebLogId', data ->> 'Email')" // Page tables - if needsTable "page" then - "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, - meta_items TEXT); - 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)" - if needsTable "page_permalink" then - "CREATE TABLE page_permalink ( - page_id TEXT NOT NULL REFERENCES page (id), - permalink TEXT NOT NULL, - PRIMARY KEY (page_id, permalink))" - if needsTable "page_revision" then + if needsTable Table.Page then + $"CREATE TABLE {Table.Page} (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{Table.Page}_key ON {Table.Page} (data ->> 'Id'); + CREATE INDEX idx_{Table.Page}_author ON {Table.Page} (data ->> 'AuthorId'); + CREATE INDEX idx_{Table.Page}_permalink ON {Table.Page} (data ->> 'WebLogId', data ->> 'Permalink')" + if needsTable Table.PageRevision then "CREATE TABLE page_revision ( - page_id TEXT NOT NULL REFERENCES page (id), + 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 "post" then - "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, - meta_items TEXT, - episode TEXT); - 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)" - if needsTable "post_category" then - "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)" - if needsTable "post_tag" then - "CREATE TABLE post_tag ( - post_id TEXT NOT NULL REFERENCES post (id), - tag TEXT NOT NULL, - PRIMARY KEY (post_id, tag))" - if needsTable "post_permalink" then - "CREATE TABLE post_permalink ( - post_id TEXT NOT NULL REFERENCES post (id), - permalink TEXT NOT NULL, - PRIMARY KEY (post_id, permalink))" - if needsTable "post_revision" then - "CREATE TABLE post_revision ( - post_id TEXT NOT NULL REFERENCES post (id), + if needsTable Table.Post then + $"CREATE TABLE {Table.Post} (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{Table.Post}_key ON {Table.Post} (data ->> 'Id'); + CREATE INDEX idx_{Table.Post}_author ON {Table.Post} (data ->> 'AuthorId'); + CREATE INDEX idx_{Table.Post}_status ON {Table.Post} (data ->> 'WebLogId', data ->> 'Status', data ->> 'UpdatedOn'); + CREATE INDEX idx_{Table.Post}_permalink ON {Table.Post} (data ->> 'WebLogId', data ->> 'Permalink')" + // 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 "post_comment" then - "CREATE TABLE post_comment ( + if needsTable Table.PostComment then + $"CREATE TABLE {Table.PostComment} ( id TEXT PRIMARY KEY, - post_id TEXT NOT NULL REFERENCES post(id), + post_id TEXT NOT NULL, in_reply_to_id TEXT, name TEXT NOT NULL, email TEXT NOT NULL, @@ -186,32 +93,28 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS 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)" + CREATE INDEX idx_{Table.PostComment}_post ON {Table.PostComment} (post_id)" // Tag map table - if needsTable "tag_map" then - "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)" + if needsTable Table.TagMap then + $"CREATE TABLE {Table.TagMap} (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{Table.TagMap}_key ON {Table.TagMap} (data ->> 'Id'); + CREATE INDEX idx_{Table.TagMap}_tag ON {Table.TagMap} (data ->> 'WebLogId', data ->> 'UrlValue')"; // Uploaded file table - if needsTable "upload" then - "CREATE TABLE upload ( + if needsTable Table.Upload then + $"CREATE TABLE {Table.Upload} ( id TEXT PRIMARY KEY, - web_log_id TEXT NOT NULL REFERENCES web_log (id), + web_log_id TEXT NOT NULL, 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)" + CREATE INDEX idx_{Table.Upload}_path ON {Table.Upload} (web_log_id, path)" // Database version table - if needsTable "db_version" then - "CREATE TABLE db_version (id TEXT PRIMARY KEY); - INSERT INTO db_version VALUES ('v2')" + if needsTable Table.DbVersion then + $"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY); + INSERT INTO {Table.DbVersion} VALUES ('v2.1')" } |> Seq.map (fun sql -> log.LogInformation $"Creating {(sql.Split ' ')[2]} table..." @@ -224,7 +127,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS /// Set the database version to the specified version let setDbVersion version = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- $"DELETE FROM db_version; INSERT INTO db_version VALUES ('%s{version}')" + cmd.CommandText <- $"DELETE FROM {Table.DbVersion}; INSERT INTO {Table.DbVersion} VALUES ('%s{version}')" do! write cmd } @@ -600,7 +503,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS do! ensureTables () use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT id FROM db_version" + cmd.CommandText <- $"SELECT id FROM {Table.DbVersion}" use! rdr = cmd.ExecuteReaderAsync () do! migrate (if rdr.Read () then Some (Map.getString "id" rdr) else None) } diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index c547389..cae8b76 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -6,405 +6,404 @@ open NodaTime /// A category under which a post may be identified [] -type Category = - { /// The ID of the category - Id : CategoryId +type Category = { + /// The ID of the category + Id : CategoryId - /// The ID of the web log to which the category belongs - WebLogId : WebLogId + /// The ID of the web log to which the category belongs + WebLogId : WebLogId - /// The displayed name - Name : string + /// The displayed name + Name : string - /// The slug (used in category URLs) - Slug : string + /// The slug (used in category URLs) + Slug : string - /// A longer description of the category - Description : string option + /// A longer description of the category + Description : string option - /// The parent ID of this category (if a subcategory) - ParentId : CategoryId option - } + /// The parent ID of this category (if a subcategory) + ParentId : CategoryId option +} /// Functions to support categories module Category = /// An empty category - let empty = - { Id = CategoryId.empty - WebLogId = WebLogId.empty - Name = "" - Slug = "" - Description = None - ParentId = None - } + let empty = { + Id = CategoryId.empty + WebLogId = WebLogId.empty + Name = "" + Slug = "" + Description = None + ParentId = None + } /// A comment on a post [] -type Comment = - { /// The ID of the comment - Id : CommentId +type Comment = { + /// The ID of the comment + Id : CommentId - /// The ID of the post to which this comment applies - PostId : PostId + /// The ID of the post to which this comment applies + PostId : PostId - /// The ID of the comment to which this comment is a reply - InReplyToId : CommentId option + /// The ID of the comment to which this comment is a reply + InReplyToId : CommentId option - /// The name of the commentor - Name : string + /// The name of the commentor + Name : string - /// The e-mail address of the commentor - Email : string + /// The e-mail address of the commentor + Email : string - /// The URL of the commentor's personal website - Url : string option + /// The URL of the commentor's personal website + Url : string option - /// The status of the comment - Status : CommentStatus + /// The status of the comment + Status : CommentStatus - /// When the comment was posted - PostedOn : Instant + /// When the comment was posted + PostedOn : Instant - /// The text of the comment - Text : string - } + /// The text of the comment + Text : string +} /// Functions to support comments module Comment = /// An empty comment - let empty = - { Id = CommentId.empty - PostId = PostId.empty - InReplyToId = None - Name = "" - Email = "" - Url = None - Status = Pending - PostedOn = Noda.epoch - Text = "" - } + let empty = { + Id = CommentId.empty + PostId = PostId.empty + InReplyToId = None + Name = "" + Email = "" + Url = None + Status = Pending + PostedOn = Noda.epoch + Text = "" + } /// A page (text not associated with a date/time) [] -type Page = - { /// The ID of this page - Id : PageId +type Page = { + /// The ID of this page + Id : PageId - /// The ID of the web log to which this page belongs - WebLogId : WebLogId + /// The ID of the web log to which this page belongs + WebLogId : WebLogId - /// The ID of the author of this page - AuthorId : WebLogUserId + /// The ID of the author of this page + AuthorId : WebLogUserId - /// The title of the page - Title : string + /// The title of the page + Title : string - /// The link at which this page is displayed - Permalink : Permalink + /// The link at which this page is displayed + Permalink : Permalink - /// When this page was published - PublishedOn : Instant + /// When this page was published + PublishedOn : Instant - /// When this page was last updated - UpdatedOn : Instant + /// When this page was last updated + UpdatedOn : Instant - /// Whether this page shows as part of the web log's navigation - IsInPageList : bool + /// Whether this page shows as part of the web log's navigation + IsInPageList : bool - /// The template to use when rendering this page - Template : string option + /// The template to use when rendering this page + Template : string option - /// The current text of the page - Text : string + /// The current text of the page + Text : string - /// Metadata for this page - Metadata : MetaItem list - - /// Permalinks at which this page may have been previously served (useful for migrated content) - PriorPermalinks : Permalink list + /// Metadata for this page + Metadata : MetaItem list + + /// Permalinks at which this page may have been previously served (useful for migrated content) + PriorPermalinks : Permalink list - /// Revisions of this page - Revisions : Revision list - } + /// Revisions of this page + Revisions : Revision list +} /// Functions to support pages module Page = /// An empty page - let empty = - { Id = PageId.empty - WebLogId = WebLogId.empty - AuthorId = WebLogUserId.empty - Title = "" - Permalink = Permalink.empty - PublishedOn = Noda.epoch - UpdatedOn = Noda.epoch - IsInPageList = false - Template = None - Text = "" - Metadata = [] - PriorPermalinks = [] - Revisions = [] - } + let empty = { + Id = PageId.empty + WebLogId = WebLogId.empty + AuthorId = WebLogUserId.empty + Title = "" + Permalink = Permalink.empty + PublishedOn = Noda.epoch + UpdatedOn = Noda.epoch + IsInPageList = false + Template = None + Text = "" + Metadata = [] + PriorPermalinks = [] + Revisions = [] + } /// A web log post [] -type Post = - { /// The ID of this post - Id : PostId +type Post = { + /// The ID of this post + Id : PostId - /// The ID of the web log to which this post belongs - WebLogId : WebLogId + /// The ID of the web log to which this post belongs + WebLogId : WebLogId - /// The ID of the author of this post - AuthorId : WebLogUserId + /// The ID of the author of this post + AuthorId : WebLogUserId - /// The status - Status : PostStatus + /// The status + Status : PostStatus - /// The title - Title : string + /// The title + Title : string - /// The link at which the post resides - Permalink : Permalink + /// The link at which the post resides + Permalink : Permalink - /// The instant on which the post was originally published - PublishedOn : Instant option + /// The instant on which the post was originally published + PublishedOn : Instant option - /// The instant on which the post was last updated - UpdatedOn : Instant + /// The instant on which the post was last updated + UpdatedOn : Instant - /// The template to use in displaying the post - Template : string option - - /// The text of the post in HTML (ready to display) format - Text : string + /// The template to use in displaying the post + Template : string option + + /// The text of the post in HTML (ready to display) format + Text : string - /// The Ids of the categories to which this is assigned - CategoryIds : CategoryId list + /// The Ids of the categories to which this is assigned + CategoryIds : CategoryId list - /// The tags for the post - Tags : string list + /// The tags for the post + Tags : string list - /// Podcast episode information for this post - Episode : Episode option - - /// Metadata for the post - Metadata : MetaItem list - - /// Permalinks at which this post may have been previously served (useful for migrated content) - PriorPermalinks : Permalink list + /// Podcast episode information for this post + Episode : Episode option + + /// Metadata for the post + Metadata : MetaItem list + + /// Permalinks at which this post may have been previously served (useful for migrated content) + PriorPermalinks : Permalink list - /// The revisions for this post - Revisions : Revision list - } + /// The revisions for this post + Revisions : Revision list +} /// Functions to support posts module Post = /// An empty post - let empty = - { Id = PostId.empty - WebLogId = WebLogId.empty - AuthorId = WebLogUserId.empty - Status = Draft - Title = "" - Permalink = Permalink.empty - PublishedOn = None - UpdatedOn = Noda.epoch - Text = "" - Template = None - CategoryIds = [] - Tags = [] - Episode = None - Metadata = [] - PriorPermalinks = [] - Revisions = [] - } + let empty = { + Id = PostId.empty + WebLogId = WebLogId.empty + AuthorId = WebLogUserId.empty + Status = Draft + Title = "" + Permalink = Permalink.empty + PublishedOn = None + UpdatedOn = Noda.epoch + Text = "" + Template = None + CategoryIds = [] + Tags = [] + Episode = None + Metadata = [] + PriorPermalinks = [] + 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 - Id : TagMapId - - /// The ID of the web log to which this tag mapping belongs - WebLogId : WebLogId - - /// The tag which should be mapped to a different value in links - Tag : string - - /// The value by which the tag should be linked - UrlValue : string - } +type TagMap = { + /// The ID of this tag mapping + Id : TagMapId + + /// The ID of the web log to which this tag mapping belongs + WebLogId : WebLogId + + /// The tag which should be mapped to a different value in links + Tag : string + + /// The value by which the tag should be linked + UrlValue : string +} /// Functions to support tag mappings module TagMap = /// An empty tag mapping - let empty = - { Id = TagMapId.empty - WebLogId = WebLogId.empty - Tag = "" - UrlValue = "" - } + let empty = { + Id = TagMapId.empty + WebLogId = WebLogId.empty + Tag = "" + UrlValue = "" + } /// A theme -type Theme = - { /// The ID / path of the theme - Id : ThemeId - - /// A long name of the theme - Name : string - - /// The version of the theme - Version : string - - /// The templates for this theme - Templates: ThemeTemplate list - } +type Theme = { + /// The ID / path of the theme + Id : ThemeId + + /// A long name of the theme + Name : string + + /// The version of the theme + Version : string + + /// The templates for this theme + Templates: ThemeTemplate list +} /// Functions to support themes module Theme = /// An empty theme - let empty = - { Id = ThemeId "" - Name = "" - Version = "" - Templates = [] - } + let empty = { + Id = ThemeId "" + Name = "" + Version = "" + Templates = [] + } /// A theme asset (a file served as part of a theme, at /themes/[theme]/[asset-path]) -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 : Instant - - /// The data for the asset - Data : byte[] - } +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 : Instant + + /// The data for the asset + Data : byte[] +} /// Functions to support theme assets module ThemeAsset = /// An empty theme asset - let empty = - { Id = ThemeAssetId (ThemeId "", "") - UpdatedOn = Noda.epoch - Data = [||] - } + let empty = { + Id = ThemeAssetId (ThemeId "", "") + UpdatedOn = Noda.epoch + Data = [||] + } /// An uploaded file -type Upload = - { /// The ID of the upload - Id : UploadId - - /// The ID of the web log to which this upload belongs - WebLogId : WebLogId - - /// The link at which this upload is served - Path : Permalink - - /// The updated date/time for this upload - UpdatedOn : Instant - - /// The data for the upload - Data : byte[] - } +type Upload = { + /// The ID of the upload + Id : UploadId + + /// The ID of the web log to which this upload belongs + WebLogId : WebLogId + + /// The link at which this upload is served + Path : Permalink + + /// The updated date/time for this upload + UpdatedOn : Instant + + /// The data for the upload + Data : byte[] +} /// Functions to support uploaded files module Upload = /// An empty upload - let empty = - { Id = UploadId.empty - WebLogId = WebLogId.empty - Path = Permalink.empty - UpdatedOn = Noda.epoch - Data = [||] - } + let empty = { + Id = UploadId.empty + WebLogId = WebLogId.empty + Path = Permalink.empty + UpdatedOn = Noda.epoch + Data = [||] + } /// A web log [] -type WebLog = - { /// The ID of the web log - Id : WebLogId +type WebLog = { + /// The ID of the web log + Id : WebLogId - /// The name of the web log - Name : string + /// The name of the web log + Name : string - /// The slug of the web log - Slug : string - - /// A subtitle for the web log - Subtitle : string option + /// The slug of the web log + Slug : string + + /// A subtitle for the web log + Subtitle : string option - /// The default page ("posts" or a page Id) - DefaultPage : string + /// The default page ("posts" or a page Id) + DefaultPage : string - /// The number of posts to display on pages of posts - PostsPerPage : int + /// The number of posts to display on pages of posts + PostsPerPage : int - /// The ID of the theme (also the path within /themes) - ThemeId : ThemeId + /// The ID of the theme (also the path within /themes) + ThemeId : ThemeId - /// The URL base - UrlBase : string + /// The URL base + UrlBase : string - /// The time zone in which dates/times should be displayed - TimeZone : string - - /// The RSS options for this web log - Rss : RssOptions - - /// Whether to automatically load htmx - AutoHtmx : bool - - /// Where uploads are placed - Uploads : UploadDestination + /// The time zone in which dates/times should be displayed + TimeZone : string + + /// The RSS options for this web log + Rss : RssOptions + + /// Whether to automatically load htmx + AutoHtmx : bool + + /// Where uploads are placed + Uploads : UploadDestination - /// Redirect rules for this weblog - RedirectRules : RedirectRule list - } + /// Redirect rules for this weblog + RedirectRules : RedirectRule list +} /// Functions to support web logs module WebLog = /// An empty web log - let empty = - { Id = WebLogId.empty - Name = "" - Slug = "" - Subtitle = None - DefaultPage = "" - PostsPerPage = 10 - ThemeId = ThemeId "default" - UrlBase = "" - TimeZone = "" - Rss = RssOptions.empty - AutoHtmx = false - Uploads = Database - RedirectRules = [] - } + let empty = { + Id = WebLogId.empty + Name = "" + Slug = "" + Subtitle = None + DefaultPage = "" + PostsPerPage = 10 + ThemeId = ThemeId "default" + UrlBase = "" + TimeZone = "" + 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 "" + $"{scheme[0]}://{host[0]}", if host.Length > 1 then $"""/{String.Join("/", host |> Array.skip 1)}""" else "" /// Generate an absolute URL for the given link let absoluteUrl webLog permalink = @@ -418,71 +417,71 @@ module WebLog = /// Convert an Instant (UTC reference) to the web log's local date/time let localTime webLog (date : Instant) = match DateTimeZoneProviders.Tzdb[webLog.TimeZone] with - | null -> date.ToDateTimeUtc () - | tz -> date.InZone(tz).ToDateTimeUnspecified () + | null -> date.ToDateTimeUtc() + | tz -> date.InZone(tz).ToDateTimeUnspecified() /// A user of the web log [] -type WebLogUser = - { /// The ID of the user - Id : WebLogUserId +type WebLogUser = { + /// The ID of the user + Id : WebLogUserId - /// The ID of the web log to which this user belongs - WebLogId : WebLogId + /// The ID of the web log to which this user belongs + WebLogId : WebLogId - /// The user name (e-mail address) - Email : string + /// The user name (e-mail address) + Email : string - /// The user's first name - FirstName : string + /// The user's first name + FirstName : string - /// The user's last name - LastName : string + /// The user's last name + LastName : string - /// The user's preferred name - PreferredName : string + /// The user's preferred name + PreferredName : string - /// The hash of the user's password - PasswordHash : string + /// The hash of the user's password + PasswordHash : string - /// The URL of the user's personal site - Url : string option + /// The URL of the user's personal site + Url : string option - /// The user's access level - AccessLevel : AccessLevel - - /// When the user was created - CreatedOn : Instant - - /// When the user last logged on - LastSeenOn : Instant option - } + /// The user's access level + AccessLevel : AccessLevel + + /// When the user was created + CreatedOn : Instant + + /// When the user last logged on + LastSeenOn : Instant option +} /// Functions to support web log users module WebLogUser = /// An empty web log user - let empty = - { Id = WebLogUserId.empty - WebLogId = WebLogId.empty - Email = "" - FirstName = "" - LastName = "" - PreferredName = "" - PasswordHash = "" - Url = None - AccessLevel = Author - CreatedOn = Noda.epoch - LastSeenOn = None - } + let empty = { + Id = WebLogUserId.empty + WebLogId = WebLogId.empty + Email = "" + FirstName = "" + LastName = "" + PreferredName = "" + PasswordHash = "" + Url = None + AccessLevel = Author + 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 () + name.Trim() /// Does a user have the required access level? let hasAccess level user = diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index fb277ba..c3e0fe1 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -10,7 +10,7 @@ module private Helpers = /// 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('+', '-')[..22] /// Functions to support NodaTime manipulation @@ -21,19 +21,18 @@ module Noda = /// The Unix epoch let epoch = Instant.FromUnixTimeSeconds 0L - /// Truncate an instant to remove fractional seconds let toSecondsPrecision (value : Instant) = - Instant.FromUnixTimeSeconds (value.ToUnixTimeSeconds ()) + Instant.FromUnixTimeSeconds(value.ToUnixTimeSeconds()) /// The current Instant, with fractional seconds truncated - let now () = - toSecondsPrecision (clock.GetCurrentInstant ()) + let now = + clock.GetCurrentInstant >> toSecondsPrecision /// Convert a date/time to an Instant with whole seconds let fromDateTime (dt : DateTime) = - toSecondsPrecision (Instant.FromDateTimeUtc (DateTime (dt.Ticks, DateTimeKind.Utc))) + Instant.FromDateTimeUtc(DateTime(dt.Ticks, DateTimeKind.Utc)) |> toSecondsPrecision /// A user's access level @@ -94,7 +93,7 @@ module CategoryId = let toString = function CategoryId ci -> ci /// Create a new category ID - let create () = CategoryId (newId ()) + let create = newId >> CategoryId /// An identifier for a comment @@ -110,7 +109,7 @@ module CommentId = let toString = function CommentId ci -> ci /// Create a new comment ID - let create () = CommentId (newId ()) + let create = newId >> CommentId /// Statuses for post comments @@ -134,7 +133,7 @@ module CommentStatus = | "Approved" -> Approved | "Pending" -> Pending | "Spam" -> Spam - | it -> invalidOp $"{it} is not a valid post status" + | it -> invalidArg "status" $"{it} is not a valid comment status" /// Valid values for the iTunes explicit rating @@ -158,127 +157,127 @@ module ExplicitRating = | "yes" -> Yes | "no" -> No | "clean" -> Clean - | x -> raise (invalidArg "rating" $"{x} is not a valid explicit rating") + | x -> invalidArg "rating" $"{x} is not a valid explicit rating" /// A location (specified by Podcast Index) -type Location = - { /// The name of the location (free-form text) - Name : string +type Location = { + /// The name of the location (free-form text) + Name : string - /// A geographic coordinate string (RFC 5870) - Geo : string option + /// A geographic coordinate string (RFC 5870) + Geo : string option - /// An OpenStreetMap query - Osm : string option - } + /// An OpenStreetMap query + Osm : string option +} /// A chapter in a podcast episode -type Chapter = - { /// The start time for the chapter - StartTime : Duration +type Chapter = { + /// The start time for the chapter + StartTime : Duration - /// The title for this chapter - Title : string option + /// The title for this chapter + Title : string option - /// A URL for an image for this chapter - ImageUrl : string option + /// A URL for an image for this chapter + ImageUrl : string option - /// Whether this chapter is hidden - IsHidden : bool option + /// Whether this chapter is hidden + IsHidden : bool option - /// The episode end time for the chapter - EndTime : Duration option + /// The episode end time for the chapter + EndTime : Duration option - /// A location that applies to a chapter - Location : Location option - } + /// A location that applies to a chapter + Location : Location option +} open NodaTime.Text /// A podcast episode -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 : Duration option - - /// The media type of the file (overrides podcast default if present) - MediaType : string option - - /// The URL to the image file for this episode (overrides podcast image if present, may be permalink) - ImageUrl : string option - - /// A subtitle for this episode - Subtitle : string option - - /// This episode's explicit rating (overrides podcast rating if present) - Explicit : ExplicitRating option - - /// Chapters for this episode - Chapters : Chapter list option +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 : Duration option + + /// The media type of the file (overrides podcast default if present) + MediaType : string option + + /// The URL to the image file for this episode (overrides podcast image if present, may be permalink) + ImageUrl : string option + + /// A subtitle for this episode + Subtitle : string option + + /// 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 - - /// The URL for the transcript of the episode (may be permalink) - TranscriptUrl : string option - - /// The MIME type of the transcript - TranscriptType : string option - - /// The language in which the transcript is written - TranscriptLang : string option - - /// If true, the transcript will be declared (in the feed) to be a captions file - TranscriptCaptions : bool option - - /// The season number (for serialized podcasts) - SeasonNumber : int option - - /// A description of the season - SeasonDescription : string option - - /// The episode number - EpisodeNumber : double option - - /// A description of the episode - EpisodeDescription : string option - } + /// A link to a chapter file + ChapterFile : string option + + /// The MIME type for the chapter file + ChapterType : string option + + /// The URL for the transcript of the episode (may be permalink) + TranscriptUrl : string option + + /// The MIME type of the transcript + TranscriptType : string option + + /// The language in which the transcript is written + TranscriptLang : string option + + /// If true, the transcript will be declared (in the feed) to be a captions file + TranscriptCaptions : bool option + + /// The season number (for serialized podcasts) + SeasonNumber : int option + + /// A description of the season + SeasonDescription : string option + + /// The episode number + EpisodeNumber : double option + + /// A description of the episode + EpisodeDescription : string option +} /// Functions to support episodes module Episode = /// An empty episode - let empty = - { Media = "" - Length = 0L - Duration = None - MediaType = None - ImageUrl = None - Subtitle = None - Explicit = None - Chapters = None - ChapterFile = None - ChapterType = None - TranscriptUrl = None - TranscriptType = None - TranscriptLang = None - TranscriptCaptions = None - SeasonNumber = None - SeasonDescription = None - EpisodeNumber = None - EpisodeDescription = None - } + let empty = { + Media = "" + Length = 0L + Duration = None + MediaType = None + ImageUrl = None + Subtitle = None + Explicit = None + Chapters = None + ChapterFile = None + ChapterType = None + TranscriptUrl = None + TranscriptType = None + TranscriptLang = None + TranscriptCaptions = None + SeasonNumber = None + SeasonDescription = None + EpisodeNumber = None + EpisodeDescription = None + } /// Format a duration for an episode let formatDuration ep = @@ -299,7 +298,7 @@ type MarkupText = module MarkupText = /// Pipeline with most extensions enabled - let private _pipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build () + let private _pipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build() /// Get the source type for the markup text let sourceType = function Markdown _ -> "Markdown" | Html _ -> "HTML" @@ -311,25 +310,25 @@ module MarkupText = 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 + 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 when text.StartsWith "Markdown: " -> Markdown text[10..] + | text when text.StartsWith "HTML: " -> Html text[6..] | text -> invalidOp $"Cannot derive type of text ({text})" /// An item of metadata [] -type MetaItem = - { /// The name of the metadata value - Name : string - - /// The metadata value - Value : string - } +type MetaItem = { + /// The name of the metadata value + Name : string + + /// The metadata value + Value : string +} /// Functions to support metadata items module MetaItem = @@ -340,22 +339,20 @@ module MetaItem = /// A revision of a page or post [] -type Revision = - { /// When this revision was saved - AsOf : Instant +type Revision = { + /// When this revision was saved + AsOf : Instant - /// The text of the revision - Text : MarkupText - } + /// The text of the revision + Text : MarkupText +} /// Functions to support revisions module Revision = /// An empty revision let empty = - { AsOf = Noda.epoch - Text = Html "" - } + { AsOf = Noda.epoch; Text = Html "" } /// A permanent link @@ -384,7 +381,7 @@ module PageId = let toString = function PageId pi -> pi /// Create a new page ID - let create () = PageId (newId ()) + let create = newId >> PageId /// PodcastIndex.org podcast:medium allowed values @@ -421,7 +418,7 @@ module PodcastMedium = | "audiobook" -> Audiobook | "newsletter" -> Newsletter | "blog" -> Blog - | it -> invalidOp $"{it} is not a valid podcast medium" + | it -> invalidArg "medium" $"{it} is not a valid podcast medium" /// Statuses for posts @@ -442,7 +439,7 @@ module PostStatus = match value with | "Draft" -> Draft | "Published" -> Published - | it -> invalidOp $"{it} is not a valid post status" + | it -> invalidArg "status" $"{it} is not a valid post status" /// An identifier for a post @@ -458,30 +455,30 @@ module PostId = let toString = function PostId pi -> pi /// Create a new post ID - let create () = PostId (newId ()) + let create = newId >> PostId /// A redirection for a previously valid URL -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 - } +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 +} /// Functions to support redirect rules module RedirectRule = /// An empty redirect rule - let empty = - { From = "" - To = "" - IsRegex = false - } + let empty = { + From = "" + To = "" + IsRegex = false + } /// An identifier for a custom feed @@ -497,7 +494,7 @@ module CustomFeedId = let toString = function CustomFeedId pi -> pi /// Create a new custom feed ID - let create () = CustomFeedId (newId ()) + let create = newId >> CustomFeedId /// The source for a custom feed @@ -525,122 +522,122 @@ module CustomFeedSource = /// Options for a feed that describes a podcast -type PodcastOptions = - { /// The title of the podcast - Title : string - - /// A subtitle for the podcast - Subtitle : string option - - /// The number of items in the podcast feed - ItemsInFeed : int - - /// A summary of the podcast (iTunes field) - Summary : string - - /// The display name of the podcast author (iTunes field) - DisplayedAuthor : string - - /// The e-mail address of the user who registered the podcast at iTunes - Email : string - - /// The link to the image for the podcast - ImageUrl : Permalink - - /// The category from Apple Podcasts (iTunes) under which this podcast is categorized - AppleCategory : string - - /// A further refinement of the categorization of this podcast (Apple Podcasts/iTunes field / values) - AppleSubcategory : string option - - /// The explictness rating (iTunes field) - Explicit : ExplicitRating - - /// The default media type for files in this podcast - DefaultMediaType : string option - - /// The base URL for relative URL media files for this podcast (optional; defaults to web log base) - MediaBaseUrl : string option - - /// A GUID for this podcast - PodcastGuid : Guid option - - /// A URL at which information on supporting the podcast may be found (supports permalinks) - FundingUrl : string option - - /// The text to be displayed in the funding item within the feed - FundingText : string option - - /// The medium (what the podcast IS, not what it is ABOUT) - Medium : PodcastMedium option - } +type PodcastOptions = { + /// The title of the podcast + Title : string + + /// A subtitle for the podcast + Subtitle : string option + + /// The number of items in the podcast feed + ItemsInFeed : int + + /// A summary of the podcast (iTunes field) + Summary : string + + /// The display name of the podcast author (iTunes field) + DisplayedAuthor : string + + /// The e-mail address of the user who registered the podcast at iTunes + Email : string + + /// The link to the image for the podcast + ImageUrl : Permalink + + /// The category from Apple Podcasts (iTunes) under which this podcast is categorized + AppleCategory : string + + /// A further refinement of the categorization of this podcast (Apple Podcasts/iTunes field / values) + AppleSubcategory : string option + + /// The explictness rating (iTunes field) + Explicit : ExplicitRating + + /// The default media type for files in this podcast + DefaultMediaType : string option + + /// The base URL for relative URL media files for this podcast (optional; defaults to web log base) + MediaBaseUrl : string option + + /// A GUID for this podcast + PodcastGuid : Guid option + + /// A URL at which information on supporting the podcast may be found (supports permalinks) + FundingUrl : string option + + /// The text to be displayed in the funding item within the feed + FundingText : string option + + /// The medium (what the podcast IS, not what it is ABOUT) + Medium : PodcastMedium option +} /// A custom feed -type CustomFeed = - { /// The ID of the custom feed - Id : CustomFeedId - - /// The source for the custom feed - Source : CustomFeedSource - - /// The path for the custom feed - Path : Permalink - - /// Podcast options, if the feed defines a podcast - Podcast : PodcastOptions option - } +type CustomFeed = { + /// The ID of the custom feed + Id : CustomFeedId + + /// The source for the custom feed + Source : CustomFeedSource + + /// The path for the custom feed + Path : Permalink + + /// Podcast options, if the feed defines a podcast + Podcast : PodcastOptions option +} /// Functions to support custom feeds module CustomFeed = /// An empty custom feed - let empty = - { Id = CustomFeedId "" - Source = Category (CategoryId "") - Path = Permalink "" - Podcast = None - } + let empty = { + Id = CustomFeedId "" + Source = Category (CategoryId "") + Path = Permalink "" + Podcast = None + } /// Really Simple Syndication (RSS) options for this web log [] -type RssOptions = - { /// Whether the site feed of posts is enabled - IsFeedEnabled : bool - - /// The name of the file generated for the site feed - FeedName : string - - /// Override the "posts per page" setting for the site feed - ItemsInFeed : int option - - /// Whether feeds are enabled for all categories - IsCategoryEnabled : bool - - /// Whether feeds are enabled for all tags - IsTagEnabled : bool - - /// A copyright string to be placed in all feeds - Copyright : string option - - /// Custom feeds for this web log - CustomFeeds: CustomFeed list - } +type RssOptions = { + /// Whether the site feed of posts is enabled + IsFeedEnabled : bool + + /// The name of the file generated for the site feed + FeedName : string + + /// Override the "posts per page" setting for the site feed + ItemsInFeed : int option + + /// Whether feeds are enabled for all categories + IsCategoryEnabled : bool + + /// Whether feeds are enabled for all tags + IsTagEnabled : bool + + /// A copyright string to be placed in all feeds + Copyright : string option + + /// Custom feeds for this web log + CustomFeeds: CustomFeed list +} /// Functions to support RSS options module RssOptions = /// An empty set of RSS options - let empty = - { IsFeedEnabled = true - FeedName = "feed.xml" - ItemsInFeed = None - IsCategoryEnabled = true - IsTagEnabled = true - Copyright = None - CustomFeeds = [] - } + let empty = { + IsFeedEnabled = true + FeedName = "feed.xml" + ItemsInFeed = None + IsCategoryEnabled = true + IsTagEnabled = true + Copyright = None + CustomFeeds = [] + } /// An identifier for a tag mapping @@ -656,7 +653,7 @@ module TagMapId = let toString = function TagMapId tmi -> tmi /// Create a new tag mapping ID - let create () = TagMapId (newId ()) + let create = newId >> TagMapId /// An identifier for a theme (represents its path) @@ -683,22 +680,20 @@ module ThemeAssetId = /// A template for a theme -type ThemeTemplate = - { /// The name of the template - Name : string - - /// The text of the template - Text : string - } +type ThemeTemplate = { + /// The name of the template + Name : string + + /// The text of the template + Text : string +} /// Functions to support theme templates module ThemeTemplate = /// An empty theme template let empty = - { Name = "" - Text = "" - } + { Name = ""; Text = "" } /// Where uploads should be placed @@ -717,7 +712,7 @@ module UploadDestination = match value with | "Database" -> Database | "Disk" -> Disk - | it -> invalidOp $"{it} is not a valid upload destination" + | it -> invalidArg "destination" $"{it} is not a valid upload destination" /// An identifier for an upload @@ -733,7 +728,7 @@ module UploadId = let toString = function UploadId ui -> ui /// Create a new upload ID - let create () = UploadId (newId ()) + let create = newId >> UploadId /// An identifier for a web log @@ -749,7 +744,7 @@ module WebLogId = let toString = function WebLogId wli -> wli /// Create a new web log ID - let create () = WebLogId (newId ()) + let create = newId >> WebLogId @@ -766,6 +761,6 @@ module WebLogUserId = let toString = function WebLogUserId wli -> wli /// Create a new web log user ID - let create () = WebLogUserId (newId ()) + let create = newId >> WebLogUserId diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 86f00a7..a0ebb3f 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -10,7 +10,7 @@ module private Helpers = /// Create a string option if a string is blank let noneIfBlank (it : string) = - match (defaultArg (Option.ofObj it) "").Trim () with "" -> None | trimmed -> Some trimmed + match (defaultArg (Option.ofObj it) "").Trim() with "" -> None | trimmed -> Some trimmed /// Helper functions that are needed outside this file @@ -26,67 +26,70 @@ module PublicHelpers = /// The model used to display the admin dashboard [] -type DashboardModel = - { /// The number of published posts - Posts : int +type DashboardModel = { + /// The number of published posts + Posts : int - /// The number of post drafts - Drafts : int + /// The number of post drafts + Drafts : int - /// The number of pages - Pages : int + /// The number of pages + Pages : int - /// The number of pages in the page list - ListedPages : int + /// The number of pages in the page list + ListedPages : int - /// The number of categories - Categories : int + /// The number of categories + Categories : int - /// The top-level categories - TopLevelCategories : int - } + /// The top-level categories + TopLevelCategories : int +} /// Details about a category, used to display category lists [] -type DisplayCategory = - { /// The ID of the category - Id : string - - /// The slug for the category - Slug : string - - /// The name of the category - Name : string - - /// A description of the category - Description : string option - - /// The parent category names for this (sub)category - ParentNames : string[] - - /// The number of posts in this category - PostCount : int - } +type DisplayCategory = { + /// The ID of the category + Id : string + + /// The slug for the category + Slug : string + + /// The name of the category + Name : string + + /// A description of the category + Description : string option + + /// The parent category names for this (sub)category + ParentNames : string[] + + /// The number of posts in this category + PostCount : int +} /// A display version of a custom feed definition -type DisplayCustomFeed = - { /// The ID of the custom feed - Id : string - - /// The source of the custom feed - Source : string - - /// The relative path at which the custom feed is served - Path : string - - /// Whether this custom feed is for a podcast - IsPodcast : bool - } +type DisplayCustomFeed = { + /// The ID of the custom feed + Id : string + + /// The source of the custom feed + Source : string + + /// The relative path at which the custom feed is served + Path : string + + /// Whether this custom feed is for a podcast + IsPodcast : bool +} + +/// Support functions for custom feed displays +module DisplayCustomFeed = /// Create a display version from a custom feed - static member fromFeed (cats : DisplayCategory[]) (feed : CustomFeed) : DisplayCustomFeed = + let fromFeed (cats : DisplayCategory[]) (feed : CustomFeed) : DisplayCustomFeed = let source = match feed.Source with | Category (CategoryId catId) -> $"Category: {(cats |> Array.find (fun cat -> cat.Id = catId)).Name}" @@ -133,7 +136,7 @@ type DisplayPage = } /// Create a minimal display page (no text or metadata) from a database page - static member fromPageMinimal webLog (page : Page) = + static member FromPageMinimal webLog (page : Page) = let pageId = PageId.toString page.Id { Id = pageId AuthorId = WebLogUserId.toString page.AuthorId @@ -148,7 +151,7 @@ type DisplayPage = } /// Create a display page from a database page - static member fromPage webLog (page : Page) = + static member FromPage webLog (page : Page) = let _, extra = WebLog.hostAndPath webLog let pageId = PageId.toString page.Id { Id = pageId @@ -166,20 +169,22 @@ type DisplayPage = /// Information about a revision used for display [] -type DisplayRevision = - { /// The as-of date/time for the revision - AsOf : DateTime - - /// The as-of date/time for the revision in the web log's local time zone - AsOfLocal : DateTime - - /// The format of the text of the revision - Format : string - } -with +type DisplayRevision = { + /// The as-of date/time for the revision + AsOf : DateTime + + /// The as-of date/time for the revision in the web log's local time zone + AsOfLocal : DateTime + + /// The format of the text of the revision + Format : string +} +/// Functions to support displaying revisions +module DisplayRevision = + /// Create a display revision from an actual revision - static member fromRevision webLog (rev : Revision) = + let fromRevision webLog (rev : Revision) = { AsOf = rev.AsOf.ToDateTimeUtc () AsOfLocal = WebLog.localTime webLog rev.AsOf Format = MarkupText.sourceType rev.Text @@ -190,29 +195,31 @@ open System.IO /// Information about a theme used for display [] -type DisplayTheme = - { /// The ID / path slug of the theme - Id : string - - /// The name of the theme - Name : string - - /// The version of the theme - Version : string - - /// How many templates are contained in the theme - TemplateCount : int - - /// Whether the theme is in use by any web logs - IsInUse : bool - - /// Whether the theme .zip file exists on the filesystem - IsOnDisk : bool - } -with +type DisplayTheme = { + /// The ID / path slug of the theme + Id : string + + /// The name of the theme + Name : string + + /// The version of the theme + Version : string + + /// How many templates are contained in the theme + TemplateCount : int + + /// Whether the theme is in use by any web logs + IsInUse : bool + + /// Whether the theme .zip file exists on the filesystem + IsOnDisk : bool +} + +/// Functions to support displaying themes +module DisplayTheme = /// Create a display theme from a theme - static member fromTheme inUseFunc (theme : Theme) = + let fromTheme inUseFunc (theme : Theme) = { Id = ThemeId.toString theme.Id Name = theme.Name Version = theme.Version @@ -224,25 +231,28 @@ with /// Information about an uploaded file used for display [] -type DisplayUpload = - { /// The ID of the uploaded file - Id : string - - /// The name of the uploaded file - Name : string - - /// The path at which the file is served - Path : string - - /// The date/time the file was updated - UpdatedOn : DateTime option - - /// The source for this file (created from UploadDestination DU) - Source : string - } +type DisplayUpload = { + /// The ID of the uploaded file + Id : string + + /// The name of the uploaded file + Name : string + + /// The path at which the file is served + Path : string + + /// The date/time the file was updated + UpdatedOn : DateTime option + + /// The source for this file (created from UploadDestination DU) + Source : string +} + +/// Functions to support displaying uploads +module DisplayUpload = /// Create a display uploaded file - static member fromUpload webLog source (upload : Upload) = + let fromUpload webLog source (upload : Upload) = let path = Permalink.toString upload.Path let name = Path.GetFileName path { Id = UploadId.toString upload.Id @@ -255,37 +265,40 @@ type DisplayUpload = /// View model to display a user's information [] -type DisplayUser = - { /// The ID of the user - Id : string +type DisplayUser = { + /// The ID of the user + Id : string - /// The user name (e-mail address) - Email : string + /// The user name (e-mail address) + Email : string - /// The user's first name - FirstName : string + /// The user's first name + FirstName : string - /// The user's last name - LastName : string + /// The user's last name + LastName : string - /// The user's preferred name - PreferredName : string + /// The user's preferred name + PreferredName : string - /// The URL of the user's personal site - Url : string + /// The URL of the user's personal site + Url : string - /// The user's access level - AccessLevel : string - - /// When the user was created - CreatedOn : DateTime - - /// When the user last logged on - LastSeenOn : Nullable - } + /// The user's access level + AccessLevel : string + + /// When the user was created + CreatedOn : DateTime + + /// When the user last logged on + LastSeenOn : Nullable +} + +/// Functions to support displaying a user's information +module DisplayUser = /// Construct a displayed user from a web log user - static member fromUser webLog (user : WebLogUser) = + let fromUser webLog (user : WebLogUser) = { Id = WebLogUserId.toString user.Id Email = user.Email FirstName = user.FirstName diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index 2b66b59..cfb0e0f 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -131,7 +131,7 @@ module PageListCache = let private fillPages (webLog : WebLog) pages = _cache[webLog.Id] <- pages - |> List.map (fun pg -> DisplayPage.fromPage webLog { pg with Text = "" }) + |> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" }) |> Array.ofList /// Are there pages cached for this web log? diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 6ddeae8..cfdebbd 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -15,7 +15,7 @@ let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> addToHash "pages" (pages |> Seq.ofList |> Seq.truncate 25 - |> Seq.map (DisplayPage.fromPageMinimal ctx.WebLog) + |> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog) |> List.ofSeq) |> addToHash "page_nbr" pageNbr |> addToHash "prev_page" (if pageNbr = 2 then "" else $"/page/{pageNbr - 1}") diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index c39dc86..087f66c 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -200,7 +200,7 @@ 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 diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 3b8f74d..5c6d371 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -40,7 +40,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 -> () -- 2.45.1 From 7071d606f11053fdf4e98b27bb18cb05577da274 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 14 Dec 2023 23:49:38 -0500 Subject: [PATCH 014/123] WIP on module/member conversion --- src/MyWebLog.Data/Converters.fs | 74 ++++--- .../Postgres/PostgresCategoryData.fs | 12 +- .../Postgres/PostgresPostData.fs | 2 +- src/MyWebLog.Data/SQLite/Helpers.fs | 2 +- .../SQLite/SQLiteCategoryData.fs | 14 +- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 8 +- .../SQLite/SQLiteWebLogUserData.fs | 2 +- src/MyWebLog.Data/SQLiteData.fs | 4 +- src/MyWebLog.Data/Utils.fs | 16 +- src/MyWebLog.Domain/DataTypes.fs | 6 +- src/MyWebLog.Domain/SupportTypes.fs | 207 +++++++++--------- src/MyWebLog.Domain/ViewModels.fs | 34 +-- src/MyWebLog/Caches.fs | 4 +- src/MyWebLog/Handlers/Admin.fs | 2 +- src/MyWebLog/Handlers/Feed.fs | 87 ++++---- src/MyWebLog/Handlers/Helpers.fs | 6 +- src/MyWebLog/Handlers/Post.fs | 8 +- src/MyWebLog/Handlers/User.fs | 13 +- src/MyWebLog/Maintenance.fs | 4 +- 19 files changed, 250 insertions(+), 255 deletions(-) diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index 52a132c..0c3be03 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -9,20 +9,27 @@ module Json = open Newtonsoft.Json - type CategoryIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) = - writer.WriteValue (CategoryId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CategoryId, _ : bool, _ : JsonSerializer) = + type CategoryIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: CategoryId, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: CategoryId, _: bool, _: JsonSerializer) = (string >> CategoryId) reader.Value - type CommentIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CommentId, _ : JsonSerializer) = - writer.WriteValue (CommentId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CommentId, _ : bool, _ : JsonSerializer) = + type CommentIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: CommentId, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: CommentId, _: bool, _: JsonSerializer) = (string >> CommentId) reader.Value + type CommentStatusConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: CommentStatus, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: CommentStatus, _: bool, _: JsonSerializer) = + (string >> CommentStatus.Parse) reader.Value + type CustomFeedIdConverter () = inherit JsonConverter () override _.WriteJson (writer : JsonWriter, value : CustomFeedId, _ : JsonSerializer) = @@ -37,12 +44,12 @@ module Json = override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedSource, _ : bool, _ : JsonSerializer) = (string >> CustomFeedSource.parse) reader.Value - type ExplicitRatingConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : ExplicitRating, _ : JsonSerializer) = - writer.WriteValue (ExplicitRating.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : ExplicitRating, _ : bool, _ : JsonSerializer) = - (string >> ExplicitRating.parse) reader.Value + type ExplicitRatingConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: ExplicitRating, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: ExplicitRating, _: bool, _: JsonSerializer) = + (string >> ExplicitRating.Parse) reader.Value type MarkupTextConverter () = inherit JsonConverter () @@ -128,27 +135,28 @@ module Json = /// Configure a serializer to use these converters let configure (ser : JsonSerializer) = // Our converters - [ CategoryIdConverter () :> JsonConverter - CommentIdConverter () - CustomFeedIdConverter () - CustomFeedSourceConverter () - ExplicitRatingConverter () - MarkupTextConverter () - PermalinkConverter () - PageIdConverter () - PodcastMediumConverter () - PostIdConverter () - TagMapIdConverter () - ThemeAssetIdConverter () - ThemeIdConverter () - UploadIdConverter () - WebLogIdConverter () - WebLogUserIdConverter () + [ CategoryIdConverter() :> JsonConverter + CommentIdConverter() + CommentStatusConverter() + CustomFeedIdConverter() + CustomFeedSourceConverter() + ExplicitRatingConverter() + MarkupTextConverter() + PermalinkConverter() + PageIdConverter() + PodcastMediumConverter() + PostIdConverter() + TagMapIdConverter() + ThemeAssetIdConverter() + ThemeIdConverter() + UploadIdConverter() + WebLogIdConverter() + WebLogUserIdConverter() ] |> List.iter ser.Converters.Add // NodaTime let _ = ser.ConfigureForNodaTime DateTimeZoneProviders.Tzdb // Handles DUs with no associated data, as well as option fields - ser.Converters.Add (CompactUnionJsonConverter ()) + ser.Converters.Add(CompactUnionJsonConverter()) ser.NullValueHandling <- NullValueHandling.Ignore ser.MissingMemberHandling <- MissingMemberHandling.Ignore ser diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index 5b703fa..60ef682 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -65,7 +65,7 @@ type PostgresCategoryData (log : ILogger) = /// Find a category by its ID for the given web log let findById catId webLogId = log.LogTrace "Category.findById" - Document.findByIdAndWebLog Table.Category catId CategoryId.toString webLogId + Document.findByIdAndWebLog Table.Category catId (_.Value) webLogId /// Find all categories for the given web log let findByWebLog webLogId = @@ -74,7 +74,7 @@ type PostgresCategoryData (log : ILogger) = /// Create parameters for a category insert / update let catParameters (cat : Category) = - Query.docParameters (CategoryId.toString cat.Id) cat + Query.docParameters cat.Id.Value cat /// Delete a category let delete catId webLogId = backgroundTask { @@ -82,7 +82,7 @@ type PostgresCategoryData (log : ILogger) = match! findById catId webLogId with | Some cat -> // Reassign any children to the category's parent category - let! children = Find.byContains Table.Category {| ParentId = CategoryId.toString catId |} + let! children = Find.byContains Table.Category {| ParentId = catId.Value |} let hasChildren = not (List.isEmpty children) if hasChildren then let! _ = @@ -91,7 +91,7 @@ type PostgresCategoryData (log : ILogger) = |> Sql.executeTransactionAsync [ Query.Update.partialById Table.Category, children |> List.map (fun child -> [ - "@id", Sql.string (CategoryId.toString child.Id) + "@id", Sql.string child.Id.Value "@data", Query.jsonbDocParam {| ParentId = cat.ParentId |} ]) ] @@ -99,7 +99,7 @@ type PostgresCategoryData (log : ILogger) = // Delete the category off all posts where it is assigned let! posts = Custom.list $"SELECT data FROM {Table.Post} WHERE data -> '{nameof Post.empty.CategoryIds}' @> @id" - [ "@id", Query.jsonbDocParam [| CategoryId.toString catId |] ] fromData + [ "@id", Query.jsonbDocParam [| catId.Value |] ] fromData if not (List.isEmpty posts) then let! _ = Configuration.dataSource () @@ -114,7 +114,7 @@ type PostgresCategoryData (log : ILogger) = ] () // Delete the category itself - do! Delete.byId Table.Category (CategoryId.toString catId) + do! Delete.byId Table.Category catId.Value return if hasChildren then ReassignedChildCategories else CategoryDeleted | None -> return CategoryNotFound } diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index ac676e7..70a6c54 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -106,7 +106,7 @@ type PostgresPostData (log : ILogger) = /// Get a page of categorized posts for the given web log (excludes revisions) let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = log.LogTrace "Post.findPageOfCategorizedPosts" - let catSql, catParam = arrayContains (nameof Post.empty.CategoryIds) CategoryId.toString categoryIds + let catSql, catParam = arrayContains (nameof Post.empty.CategoryIds) (_.Value) categoryIds Custom.list $"{selectWithCriteria Table.Post} AND {catSql} diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 2a4f06a..08ab5a4 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -362,7 +362,7 @@ module Map = PreferredName = getString "preferred_name" rdr PasswordHash = getString "password_hash" rdr Url = tryString "url" rdr - AccessLevel = getString "access_level" rdr |> AccessLevel.parse + AccessLevel = getString "access_level" rdr |> AccessLevel.Parse CreatedOn = getInstant "created_on" rdr LastSeenOn = tryInstant "last_seen_on" rdr } diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 75728b8..3caae20 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -10,12 +10,12 @@ type SQLiteCategoryData (conn : SqliteConnection) = /// 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 ("@id", cat.Id.Value) 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)) + cmd.Parameters.AddWithValue ("@parentId", maybe (cat.ParentId |> Option.map _.Value)) ] |> ignore /// Add a category @@ -101,10 +101,10 @@ type SQLiteCategoryData (conn : SqliteConnection) = |> Array.ofSeq } /// Find a category by its ID for the given web log - let findById catId webLogId = backgroundTask { + let findById (catId: CategoryId) webLogId = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT * FROM category WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId) |> ignore + cmd.Parameters.AddWithValue ("@id", catId.Value) |> ignore use! rdr = cmd.ExecuteReaderAsync () return Helpers.verifyWebLog webLogId (fun c -> c.WebLogId) Map.toCategory rdr } @@ -125,11 +125,11 @@ type SQLiteCategoryData (conn : SqliteConnection) = use cmd = conn.CreateCommand () // Reassign any children to the category's parent category cmd.CommandText <- "SELECT COUNT(id) FROM category WHERE parent_id = @parentId" - cmd.Parameters.AddWithValue ("@parentId", CategoryId.toString catId) |> ignore + cmd.Parameters.AddWithValue ("@parentId", catId.Value) |> ignore let! children = count cmd if children > 0 then cmd.CommandText <- "UPDATE category SET parent_id = @newParentId WHERE parent_id = @parentId" - cmd.Parameters.AddWithValue ("@newParentId", maybe (cat.ParentId |> Option.map CategoryId.toString)) + cmd.Parameters.AddWithValue ("@newParentId", maybe (cat.ParentId |> Option.map _.Value)) |> ignore do! write cmd // Delete the category off all posts where it is assigned, and the category itself @@ -139,7 +139,7 @@ type SQLiteCategoryData (conn : SqliteConnection) = AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId); DELETE FROM category WHERE id = @id" cmd.Parameters.Clear () - let _ = cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId) + let _ = cmd.Parameters.AddWithValue ("@id", catId.Value) addWebLogId cmd webLogId do! write cmd return if children = 0 then CategoryDeleted else ReassignedChildCategories diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 257bdf7..d73cf86 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -83,7 +83,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = /// Update a post's assigned categories let updatePostCategories postId oldCats newCats = backgroundTask { - let toDelete, toAdd = Utils.diffLists oldCats newCats CategoryId.toString + let toDelete, toAdd = Utils.diffLists oldCats newCats _.Value if List.isEmpty toDelete && List.isEmpty toAdd then return () else @@ -91,8 +91,8 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = [ 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 + let runCmd (catId: CategoryId) = backgroundTask { + cmd.Parameters["@categoryId"].Value <- catId.Value do! write cmd } cmd.CommandText <- "DELETE FROM post_category WHERE post_id = @postId AND category_id = @categoryId" @@ -301,7 +301,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = /// 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 () - let catSql, catParams = inClause "AND pc.category_id" "catId" CategoryId.toString categoryIds + let catSql, catParams = inClause "AND pc.category_id" "catId" (_.Value) categoryIds cmd.CommandText <- $" {selectPost} INNER JOIN post_category pc ON pc.post_id = p.id diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 8eb8cd9..f99bf05 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -19,7 +19,7 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = cmd.Parameters.AddWithValue ("@preferredName", user.PreferredName) cmd.Parameters.AddWithValue ("@passwordHash", user.PasswordHash) cmd.Parameters.AddWithValue ("@url", maybe user.Url) - cmd.Parameters.AddWithValue ("@accessLevel", AccessLevel.toString user.AccessLevel) + cmd.Parameters.AddWithValue ("@accessLevel", user.AccessLevel.Value) cmd.Parameters.AddWithValue ("@createdOn", instantParam user.CreatedOn) cmd.Parameters.AddWithValue ("@lastSeenOn", maybeInstant user.LastSeenOn) ] |> ignore diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index d1a3aaf..61d5f48 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -188,7 +188,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS 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 + 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 @@ -220,7 +220,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS ImageUrl = Map.tryString "image_url" epRdr Subtitle = Map.tryString "subtitle" epRdr Explicit = Map.tryString "explicit" epRdr - |> Option.map ExplicitRating.parse + |> Option.map ExplicitRating.Parse Chapters = Map.tryString "chapters" epRdr |> Option.map (Utils.deserialize ser) ChapterFile = Map.tryString "chapter_file" epRdr diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index c241a65..14f94aa 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -12,7 +12,7 @@ let currentDbVersion = "v2.1" 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 = cat.Id.Value Slug = fullSlug Name = cat.Name Description = cat.Description @@ -24,7 +24,7 @@ let rec orderByHierarchy (cats : Category list) parentId slugBase 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 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 @@ -38,21 +38,21 @@ let diffPermalinks oldLinks newLinks = /// Find the revisions added and removed let diffRevisions oldRevs newRevs = - diffLists oldRevs newRevs (fun (rev : Revision) -> $"{rev.AsOf.ToUnixTimeTicks ()}|{MarkupText.toString rev.Text}") + diffLists oldRevs newRevs (fun (rev: Revision) -> $"{rev.AsOf.ToUnixTimeTicks()}|{MarkupText.toString 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) +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) +let deserialize<'T> (ser: JsonSerializer) value = + JsonConvert.DeserializeObject<'T>(value, Json.settings ser) open Microsoft.Extensions.Logging /// Log a migration step -let logMigrationStep<'T> (log : ILogger<'T>) migration message = +let logMigrationStep<'T> (log: ILogger<'T>) migration message = log.LogInformation $"Migrating %s{migration}: %s{message}" diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index cae8b76..baf4742 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -31,7 +31,7 @@ module Category = /// An empty category let empty = { - Id = CategoryId.empty + Id = CategoryId.Empty WebLogId = WebLogId.empty Name = "" Slug = "" @@ -76,7 +76,7 @@ module Comment = /// An empty comment let empty = { - Id = CommentId.empty + Id = CommentId.Empty PostId = PostId.empty InReplyToId = None Name = "" @@ -485,4 +485,4 @@ module WebLogUser = /// Does a user have the required access level? let hasAccess level user = - AccessLevel.hasAccess level user.AccessLevel + user.AccessLevel.HasAccess level diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index c3e0fe1..e6ac59c 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -10,20 +10,20 @@ module private Helpers = /// 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('+', '-')[..22] + Convert.ToBase64String(Guid.NewGuid().ToByteArray()).Replace('/', '_').Replace('+', '-')[..22] /// Functions to support NodaTime manipulation module Noda = /// The clock to use when getting "now" (will make mutable for testing) - let clock : IClock = SystemClock.Instance + let clock: IClock = SystemClock.Instance /// The Unix epoch let epoch = Instant.FromUnixTimeSeconds 0L /// Truncate an instant to remove fractional seconds - let toSecondsPrecision (value : Instant) = + let toSecondsPrecision (value: Instant) = Instant.FromUnixTimeSeconds(value.ToUnixTimeSeconds()) /// The current Instant, with fractional seconds truncated @@ -31,11 +31,12 @@ module Noda = clock.GetCurrentInstant >> toSecondsPrecision /// Convert a date/time to an Instant with whole seconds - let fromDateTime (dt : DateTime) = + let fromDateTime (dt: DateTime) = Instant.FromDateTimeUtc(DateTime(dt.Ticks, DateTimeKind.Utc)) |> toSecondsPrecision /// A user's access level +[] type AccessLevel = /// The user may create and publish posts and edit the ones they have created | Author @@ -45,74 +46,73 @@ type AccessLevel = | WebLogAdmin /// The user may manage themes (which affects all web logs for an installation) | Administrator - -/// Functions to support access levels -module AccessLevel = - - /// 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 - | 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 + static member Parse = + function + | "Author" -> Author + | "Editor" -> Editor + | "WebLogAdmin" -> WebLogAdmin | "Administrator" -> Administrator - | _ -> invalidOp $"{it} is not a valid access level" + | it -> invalidArg "level" $"{it} is not a valid access level" + + /// The string representation of this access level + member this.Value = + match this with + | Author -> "Author" + | Editor -> "Editor" + | WebLogAdmin -> "WebLogAdmin" + | Administrator -> "Administrator" /// 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) = + // TODO: Move this to user where it seems to belong better... + 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 = +[] +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 = newId >> CategoryId + static member Create = + newId >> CategoryId + + /// The string representation of this category ID + member this.Value = + match this with CategoryId it -> it /// An identifier for a comment -type CommentId = CommentId of string - -/// Functions to support comment IDs -module CommentId = +[] +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 = newId >> CommentId + static member Create = + newId >> CommentId + + /// The string representation of this comment ID + member this.Value = + match this with CommentId it -> it /// Statuses for post comments +[] type CommentStatus = /// The comment is approved | Approved @@ -121,77 +121,71 @@ 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 = + function | "Approved" -> Approved - | "Pending" -> Pending - | "Spam" -> Spam - | it -> invalidArg "status" $"{it} is not a valid comment status" + | "Pending" -> Pending + | "Spam" -> Spam + | it -> invalidArg "status" $"{it} is not a valid comment status" + + /// Convert a comment status to a string + member this.Value = + match this with Approved -> "Approved" | Pending -> "Pending" | Spam -> "Spam" /// Valid values for the iTunes explicit rating +[] 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 = + static member Parse = function - | "yes" -> Yes - | "no" -> No + | "yes" -> Yes + | "no" -> No | "clean" -> Clean - | x -> invalidArg "rating" $"{x} is not a valid explicit rating" + | it -> invalidArg "rating" $"{it} is not a valid explicit rating" + + /// The string value of this rating + member this.Value = + 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 + Name: string /// A geographic coordinate string (RFC 5870) - Geo : string option + Geo: string option /// An OpenStreetMap query - Osm : string option + Osm: string option } /// A chapter in a podcast episode type Chapter = { /// The start time for the chapter - StartTime : Duration + StartTime: Duration /// The title for this chapter - Title : string option + Title: string option /// A URL for an image for this chapter - ImageUrl : string option + ImageUrl: string option /// Whether this chapter is hidden - IsHidden : bool option + IsHidden: bool option /// The episode end time for the chapter - EndTime : Duration option + EndTime: Duration option /// A location that applies to a chapter - Location : Location option + Location: Location option } @@ -200,65 +194,62 @@ open NodaTime.Text /// A podcast episode type Episode = { /// The URL to the media file for the episode (may be permalink) - Media : string + Media: string /// The length of the media file, in bytes - Length : int64 + Length: int64 /// The duration of the episode - Duration : Duration option + Duration: Duration option /// The media type of the file (overrides podcast default if present) - MediaType : string option + MediaType: string option /// The URL to the image file for this episode (overrides podcast image if present, may be permalink) - ImageUrl : string option + ImageUrl: string option /// A subtitle for this episode - Subtitle : string option + Subtitle: string option /// This episode's explicit rating (overrides podcast rating if present) - Explicit : ExplicitRating option + Explicit: ExplicitRating option /// Chapters for this episode - Chapters : Chapter list option + Chapters: Chapter list option /// A link to a chapter file - ChapterFile : string option + ChapterFile: string option /// The MIME type for the chapter file - ChapterType : string option + ChapterType: string option /// The URL for the transcript of the episode (may be permalink) - TranscriptUrl : string option + TranscriptUrl: string option /// The MIME type of the transcript - TranscriptType : string option + TranscriptType: string option /// The language in which the transcript is written - TranscriptLang : string option + TranscriptLang: string option /// If true, the transcript will be declared (in the feed) to be a captions file - TranscriptCaptions : bool option + TranscriptCaptions: bool option /// The season number (for serialized podcasts) - SeasonNumber : int option + SeasonNumber: int option /// A description of the season - SeasonDescription : string option + SeasonDescription: string option /// The episode number - EpisodeNumber : double option + EpisodeNumber: double option /// A description of the episode - EpisodeDescription : string option -} - -/// Functions to support episodes -module Episode = + EpisodeDescription: string option +} with /// An empty episode - let empty = { + static member Empty = { Media = "" Length = 0L Duration = None @@ -280,8 +271,8 @@ module Episode = } /// Format a duration for an episode - let formatDuration ep = - ep.Duration |> Option.map (DurationPattern.CreateWithInvariantCulture("H:mm:ss").Format) + member this.FormatDuration() = + this.Duration |> Option.map (DurationPattern.CreateWithInvariantCulture("H:mm:ss").Format) open Markdig diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index a0ebb3f..28c85e5 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -305,7 +305,7 @@ module DisplayUser = LastName = user.LastName PreferredName = user.PreferredName Url = defaultArg user.Url "" - AccessLevel = AccessLevel.toString user.AccessLevel + AccessLevel = user.AccessLevel.Value CreatedOn = WebLog.localTime webLog user.CreatedOn LastSeenOn = user.LastSeenOn |> Option.map (WebLog.localTime webLog) |> Option.toNullable } @@ -332,11 +332,11 @@ type EditCategoryModel = /// Create an edit model from an existing category static member fromCategory (cat : Category) = - { CategoryId = CategoryId.toString cat.Id + { CategoryId = cat.Id.Value Name = cat.Name Slug = cat.Slug Description = defaultArg cat.Description "" - ParentId = cat.ParentId |> Option.map CategoryId.toString |> Option.defaultValue "" + ParentId = cat.ParentId |> Option.map _.Value |> Option.defaultValue "" } /// Is this a new category? @@ -457,7 +457,7 @@ type EditCustomFeedModel = ImageUrl = Permalink.toString p.ImageUrl AppleCategory = p.AppleCategory AppleSubcategory = defaultArg p.AppleSubcategory "" - Explicit = ExplicitRating.toString p.Explicit + Explicit = p.Explicit.Value DefaultMediaType = defaultArg p.DefaultMediaType "" MediaBaseUrl = defaultArg p.MediaBaseUrl "" FundingUrl = defaultArg p.FundingUrl "" @@ -486,7 +486,7 @@ type EditCustomFeedModel = ImageUrl = Permalink this.ImageUrl AppleCategory = this.AppleCategory AppleSubcategory = noneIfBlank this.AppleSubcategory - Explicit = ExplicitRating.parse this.Explicit + Explicit = ExplicitRating.Parse this.Explicit DefaultMediaType = noneIfBlank this.DefaultMediaType MediaBaseUrl = noneIfBlank this.MediaBaseUrl PodcastGuid = noneIfBlank this.PodcastGuid |> Option.map Guid.Parse @@ -714,11 +714,11 @@ type EditPostModel = /// Create an edit model from an existing past static member fromPost webLog (post : Post) = let latest = - match post.Revisions |> List.sortByDescending (fun r -> r.AsOf) |> List.tryHead with + match post.Revisions |> List.sortByDescending (_.AsOf) |> List.tryHead with | Some rev -> rev | None -> Revision.empty let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.empty ] } else post - let episode = defaultArg post.Episode Episode.empty + let episode = defaultArg post.Episode Episode.Empty { PostId = PostId.toString post.Id Title = post.Title Permalink = Permalink.toString post.Permalink @@ -726,22 +726,22 @@ type EditPostModel = Text = MarkupText.text latest.Text Tags = String.Join (", ", post.Tags) Template = defaultArg post.Template "" - CategoryIds = post.CategoryIds |> List.map CategoryId.toString |> Array.ofList + CategoryIds = post.CategoryIds |> List.map (_.Value) |> Array.ofList Status = PostStatus.toString post.Status DoPublish = false - MetaNames = post.Metadata |> List.map (fun m -> m.Name) |> Array.ofList - MetaValues = post.Metadata |> List.map (fun m -> m.Value) |> Array.ofList + MetaNames = post.Metadata |> List.map (_.Name) |> Array.ofList + MetaValues = post.Metadata |> List.map (_.Value) |> Array.ofList SetPublished = false PubOverride = post.PublishedOn |> Option.map (WebLog.localTime webLog) |> Option.toNullable SetUpdated = false IsEpisode = Option.isSome post.Episode Media = episode.Media Length = episode.Length - Duration = defaultArg (Episode.formatDuration episode) "" + Duration = defaultArg (episode.FormatDuration()) "" MediaType = defaultArg episode.MediaType "" ImageUrl = defaultArg episode.ImageUrl "" Subtitle = defaultArg episode.Subtitle "" - Explicit = defaultArg (episode.Explicit |> Option.map ExplicitRating.toString) "" + Explicit = defaultArg (episode.Explicit |> Option.map (_.Value)) "" ChapterFile = defaultArg episode.ChapterFile "" ChapterType = defaultArg episode.ChapterType "" TranscriptUrl = defaultArg episode.TranscriptUrl "" @@ -800,7 +800,7 @@ type EditPostModel = MediaType = noneIfBlank this.MediaType ImageUrl = noneIfBlank this.ImageUrl Subtitle = noneIfBlank this.Subtitle - Explicit = noneIfBlank this.Explicit |> Option.map ExplicitRating.parse + Explicit = noneIfBlank this.Explicit |> Option.map ExplicitRating.Parse Chapters = match post.Episode with Some e -> e.Chapters | None -> None ChapterFile = noneIfBlank this.ChapterFile ChapterType = noneIfBlank this.ChapterType @@ -960,7 +960,7 @@ type EditUserModel = /// Construct a displayed user from a web log user static member fromUser (user : WebLogUser) = { Id = WebLogUserId.toString user.Id - AccessLevel = AccessLevel.toString user.AccessLevel + AccessLevel = user.AccessLevel.Value Url = defaultArg user.Url "" Email = user.Email FirstName = user.FirstName @@ -974,9 +974,9 @@ type EditUserModel = member this.IsNew = this.Id = "new" /// Update a user with values from this model (excludes password) - member this.UpdateUser (user : WebLogUser) = + member this.UpdateUser (user: WebLogUser) = { user with - AccessLevel = AccessLevel.parse this.AccessLevel + AccessLevel = AccessLevel.Parse this.AccessLevel Email = this.Email Url = noneIfBlank this.Url FirstName = this.FirstName @@ -1126,7 +1126,7 @@ type PostListItem = PublishedOn = post.PublishedOn |> Option.map inTZ |> Option.toNullable UpdatedOn = inTZ post.UpdatedOn Text = addBaseToRelativeUrls extra post.Text - CategoryIds = post.CategoryIds |> List.map CategoryId.toString + CategoryIds = post.CategoryIds |> List.map _.Value Tags = post.Tags Episode = post.Episode Metadata = post.Metadata diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index cfb0e0f..05bda8f 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -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,7 +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 (fun it -> it.HasAccess level)) false open System.Collections.Concurrent diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 4025843..de59270 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -177,7 +177,7 @@ module Category = let data = ctx.Data let! model = ctx.BindFormAsync () 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 -> diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 7db1dd9..2db2de4 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -48,8 +48,8 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = /// 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 = catId.Value) getCategoryIds cat.Slug ctx let data = ctx.Data match feedType with @@ -116,7 +116,7 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[ Name = (authors |> List.find (fun a -> a.Name = WebLogUserId.toString post.AuthorId)).Value)) [ post.CategoryIds |> List.map (fun catId -> - let cat = cats |> Array.find (fun c -> c.Id = CategoryId.toString catId) + let cat = cats |> Array.find (fun c -> c.Id = catId.Value) SyndicationCategory (cat.Name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.Slug}/"), cat.Name)) post.Tags |> List.map (fun tag -> @@ -143,28 +143,27 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po | link -> WebLog.absoluteUrl webLog (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 epExplicit = (defaultArg episode.Explicit podcast.Explicit).Value - let xmlDoc = XmlDocument () + let xmlDoc = XmlDocument() let enclosure = let it = xmlDoc.CreateElement "enclosure" - it.SetAttribute ("url", epMediaUrl) - it.SetAttribute ("length", string episode.Length) - epMediaType |> Option.iter (fun typ -> it.SetAttribute ("type", typ)) + it.SetAttribute("url", epMediaUrl) + it.SetAttribute("length", string episode.Length) + epMediaType |> Option.iter (fun typ -> it.SetAttribute("type", typ)) it let image = - let it = xmlDoc.CreateElement ("itunes", "image", Namespace.iTunes) - it.SetAttribute ("href", epImageUrl) + let it = xmlDoc.CreateElement("itunes", "image", Namespace.iTunes) + it.SetAttribute("href", epImageUrl) it item.ElementExtensions.Add enclosure item.ElementExtensions.Add image - item.ElementExtensions.Add ("creator", Namespace.dc, podcast.DisplayedAuthor) - 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.formatDuration episode - |> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it)) + item.ElementExtensions.Add("creator", Namespace.dc, podcast.DisplayedAuthor) + 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.FormatDuration() |> Option.iter (fun it -> item.ElementExtensions.Add("duration", Namespace.iTunes, it)) match episode.ChapterFile with | Some chapters -> @@ -174,21 +173,20 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po | Some mime -> Some mime | None when chapters.EndsWith ".json" -> Some "application/json+chapters" | None -> None - let elt = xmlDoc.CreateElement ("podcast", "chapters", Namespace.podcast) - elt.SetAttribute ("url", url) - typ |> Option.iter (fun it -> elt.SetAttribute ("type", it)) + let elt = xmlDoc.CreateElement("podcast", "chapters", Namespace.podcast) + elt.SetAttribute("url", url) + typ |> Option.iter (fun it -> elt.SetAttribute("type", it)) item.ElementExtensions.Add elt | None -> () match episode.TranscriptUrl with | Some transcript -> let url = toAbsolute webLog transcript - let elt = xmlDoc.CreateElement ("podcast", "transcript", Namespace.podcast) - 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") + let elt = xmlDoc.CreateElement("podcast", "transcript", Namespace.podcast) + 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") item.ElementExtensions.Add elt | None -> () @@ -196,38 +194,37 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po | Some season -> match episode.SeasonDescription with | Some desc -> - let elt = xmlDoc.CreateElement ("podcast", "season", Namespace.podcast) - elt.SetAttribute ("name", desc) + let elt = xmlDoc.CreateElement("podcast", "season", Namespace.podcast) + elt.SetAttribute("name", desc) elt.InnerText <- string season item.ElementExtensions.Add elt - | None -> item.ElementExtensions.Add ("season", Namespace.podcast, string season) + | None -> item.ElementExtensions.Add("season", Namespace.podcast, string season) | None -> () match episode.EpisodeNumber with | Some epNumber -> match episode.EpisodeDescription with | Some desc -> - let elt = xmlDoc.CreateElement ("podcast", "episode", Namespace.podcast) - elt.SetAttribute ("name", desc) + let elt = xmlDoc.CreateElement("podcast", "episode", Namespace.podcast) + elt.SetAttribute("name", desc) elt.InnerText <- string epNumber item.ElementExtensions.Add elt - | None -> item.ElementExtensions.Add ("episode", Namespace.podcast, string epNumber) + | None -> item.ElementExtensions.Add("episode", Namespace.podcast, string epNumber) | None -> () if post.Metadata |> List.exists (fun it -> it.Name = "chapter") then try - let chapters = xmlDoc.CreateElement ("psc", "chapters", Namespace.psc) - chapters.SetAttribute ("version", "1.2") + let chapters = xmlDoc.CreateElement("psc", "chapters", Namespace.psc) + chapters.SetAttribute("version", "1.2") 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) - chapter.SetAttribute ("start", (fst chap).ToString "hh:mm:ss") - chapter.SetAttribute ("title", snd chap) + let chapter = xmlDoc.CreateElement("psc", "chapter", Namespace.psc) + chapter.SetAttribute("start", (fst chap).ToString "hh:mm:ss") + chapter.SetAttribute("title", snd chap) chapters.AppendChild chapter |> ignore) item.ElementExtensions.Add chapters @@ -300,21 +297,21 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) = rssFeed.ElementExtensions.Add categorization rssFeed.ElementExtensions.Add iTunesImage 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("summary", Namespace.iTunes, podcast.Summary) + rssFeed.ElementExtensions.Add("author", Namespace.iTunes, podcast.DisplayedAuthor) + rssFeed.ElementExtensions.Add("explicit", Namespace.iTunes, podcast.Explicit.Value) podcast.Subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add ("subtitle", Namespace.iTunes, sub)) podcast.FundingUrl |> Option.iter (fun url -> - let funding = xmlDoc.CreateElement ("podcast", "funding", Namespace.podcast) - funding.SetAttribute ("url", toAbsolute webLog url) + let funding = xmlDoc.CreateElement("podcast", "funding", Namespace.podcast) + funding.SetAttribute("url", toAbsolute webLog url) funding.InnerText <- defaultArg podcast.FundingText "Support This Podcast" rssFeed.ElementExtensions.Add funding) podcast.PodcastGuid |> Option.iter (fun guid -> - rssFeed.ElementExtensions.Add ("guid", Namespace.podcast, guid.ToString().ToLowerInvariant ())) + rssFeed.ElementExtensions.Add("guid", Namespace.podcast, guid.ToString().ToLowerInvariant())) podcast.Medium - |> Option.iter (fun med -> rssFeed.ElementExtensions.Add ("medium", Namespace.podcast, PodcastMedium.toString med)) + |> Option.iter (fun med -> rssFeed.ElementExtensions.Add("medium", Namespace.podcast, PodcastMedium.toString med)) /// Get the feed's self reference and non-feed link let private selfAndLink webLog feedType ctx = diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 2edefe8..b1f4bd3 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -348,12 +348,12 @@ 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" + Message = $"The page you tried to access requires {level.Value} privileges" + Detail = Some $"Your account only has {userLevel.Value} privileges" } return! Error.notAuthorized next ctx | None -> diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 087f66c..0f5ea97 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -242,10 +242,10 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])) |> addToHash "templates" templates |> addToHash "explicit_values" [| - KeyValuePair.Create ("", "– Default –") - KeyValuePair.Create (ExplicitRating.toString Yes, "Yes") - KeyValuePair.Create (ExplicitRating.toString No, "No") - KeyValuePair.Create (ExplicitRating.toString Clean, "Clean") + KeyValuePair.Create("", "– Default –") + KeyValuePair.Create(Yes.Value, "Yes") + KeyValuePair.Create(No.Value, "No") + KeyValuePair.Create(Clean.Value, "Clean") |] |> adminView "post-edit" next ctx | Some _ -> return! Error.notAuthorized next ctx diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 43d9ccc..389fe56 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -58,7 +58,7 @@ let doLogOn : HttpHandler = fun next ctx -> task { Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.Id) Claim (ClaimTypes.Name, $"{user.FirstName} {user.LastName}") Claim (ClaimTypes.GivenName, user.PreferredName) - Claim (ClaimTypes.Role, AccessLevel.toString user.AccessLevel) + Claim (ClaimTypes.Role, user.AccessLevel.Value) } let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) @@ -110,11 +110,10 @@ let private showEdit (model : EditUserModel) : HttpHandler = fun next ctx -> |> 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") + KeyValuePair.Create(Author.Value, "Author") + KeyValuePair.Create(Editor.Value, "Editor") + KeyValuePair.Create(WebLogAdmin.Value, "Web Log Admin") + if ctx.HasAccessLevel Administrator then KeyValuePair.Create(Administrator.Value, "Administrator") |] |> adminBareView "user-edit" next ctx @@ -160,7 +159,7 @@ let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandl hashForPage "Edit Your Information" |> withAntiCsrf ctx |> addToHash ViewContext.Model model - |> addToHash "access_level" (AccessLevel.toString user.AccessLevel) + |> addToHash "access_level" (user.AccessLevel.Value) |> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn) |> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn (Instant.FromUnixTimeSeconds 0))) diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 8413504..ee7d934 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -334,7 +334,7 @@ module Backup = | Some _ -> // Err'body gets new IDs... let newWebLogId = WebLogId.create () - let newCatIds = archive.Categories |> List.map (fun cat -> cat.Id, CategoryId.create ()) |> dict + 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 @@ -481,7 +481,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.Value}, not a WebLogAdmin" | None -> eprintfn $"ERROR: no user {email} found at {urlBase}" | None -> eprintfn $"ERROR: no web log found for {urlBase}" } -- 2.45.1 From 5fe2077974a9c2a7368e074e8edcf871c5c33c8a Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 15 Dec 2023 22:46:12 -0500 Subject: [PATCH 015/123] WIP on module/member conversion --- src/MyWebLog.Data/Converters.fs | 54 +- .../Postgres/PostgresCategoryData.fs | 13 +- src/MyWebLog.Data/Postgres/PostgresHelpers.fs | 4 +- .../Postgres/PostgresPageData.fs | 38 +- .../Postgres/PostgresPostData.fs | 52 +- .../Postgres/PostgresUploadData.fs | 2 +- src/MyWebLog.Data/RethinkDbData.fs | 2 +- src/MyWebLog.Data/SQLite/Helpers.fs | 4 +- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 40 +- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 72 +-- src/MyWebLog.Data/SQLite/SQLiteUploadData.fs | 4 +- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 2 +- src/MyWebLog.Data/SQLiteData.fs | 4 +- src/MyWebLog.Data/Utils.fs | 4 +- src/MyWebLog.Domain/DataTypes.fs | 22 +- src/MyWebLog.Domain/SupportTypes.fs | 192 ++++--- src/MyWebLog.Domain/ViewModels.fs | 494 +++++++++--------- src/MyWebLog/DotLiquidBespoke.fs | 18 +- src/MyWebLog/Handlers/Admin.fs | 12 +- src/MyWebLog/Handlers/Feed.fs | 30 +- src/MyWebLog/Handlers/Page.fs | 8 +- src/MyWebLog/Handlers/Post.fs | 18 +- src/MyWebLog/Handlers/Routes.fs | 10 +- src/MyWebLog/Maintenance.fs | 14 +- 24 files changed, 548 insertions(+), 565 deletions(-) diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index 0c3be03..d68025d 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -51,39 +51,39 @@ module Json = override _.ReadJson(reader: JsonReader, _: Type, _: ExplicitRating, _: bool, _: JsonSerializer) = (string >> ExplicitRating.Parse) reader.Value - type MarkupTextConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : MarkupText, _ : JsonSerializer) = - writer.WriteValue (MarkupText.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : MarkupText, _ : bool, _ : JsonSerializer) = - (string >> MarkupText.parse) reader.Value + type MarkupTextConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: MarkupText, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: MarkupText, _: bool, _: JsonSerializer) = + (string >> MarkupText.Parse) reader.Value - type PermalinkConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : Permalink, _ : JsonSerializer) = - writer.WriteValue (Permalink.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : Permalink, _ : bool, _ : JsonSerializer) = + type PermalinkConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: Permalink, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: Permalink, _: bool, _: JsonSerializer) = (string >> Permalink) reader.Value - type PageIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : PageId, _ : JsonSerializer) = - writer.WriteValue (PageId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : PageId, _ : bool, _ : JsonSerializer) = + type PageIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: PageId, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: PageId, _: bool, _: JsonSerializer) = (string >> PageId) reader.Value - type PodcastMediumConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : PodcastMedium, _ : JsonSerializer) = - writer.WriteValue (PodcastMedium.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : PodcastMedium, _ : bool, _ : JsonSerializer) = - (string >> PodcastMedium.parse) reader.Value + type PodcastMediumConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: PodcastMedium, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: PodcastMedium, _: bool, _: JsonSerializer) = + (string >> PodcastMedium.Parse) reader.Value - type PostIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : PostId, _ : JsonSerializer) = - writer.WriteValue (PostId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : PostId, _ : bool, _ : JsonSerializer) = + type PostIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: PostId, _: JsonSerializer) = + writer.WriteValue value.Value + override _.ReadJson(reader: JsonReader, _: Type, _: PostId, _: bool, _: JsonSerializer) = (string >> PostId) reader.Value type TagMapIdConverter () = diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index 60ef682..08d041c 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -7,7 +7,7 @@ open MyWebLog.Data open Npgsql.FSharp /// PostgreSQL myWebLog category data implementation -type PostgresCategoryData (log : ILogger) = +type PostgresCategoryData(log: ILogger) = /// Count all categories for the given web log let countAll webLogId = @@ -33,7 +33,7 @@ type PostgresCategoryData (log : ILogger) = let catIdSql, catIdParams = 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) |> List.ofSeq |> arrayContains (nameof Post.empty.CategoryIds) id @@ -43,10 +43,9 @@ type PostgresCategoryData (log : ILogger) = FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"} AND {catIdSql}""" - [ "@criteria", - Query.jsonbDocParam {| webLogDoc webLogId with Status = PostStatus.toString Published |} - catIdParams - ] Map.toCount + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} + catIdParams ] + Map.toCount |> Async.AwaitTask |> Async.RunSynchronously it.Id, postCount) @@ -107,7 +106,7 @@ type PostgresCategoryData (log : ILogger) = |> Sql.executeTransactionAsync [ Query.Update.partialById Table.Post, posts |> List.map (fun post -> [ - "@id", Sql.string (PostId.toString post.Id) + "@id", Sql.string post.Id.Value "@data", Query.jsonbDocParam {| CategoryIds = post.CategoryIds |> List.filter (fun cat -> cat <> catId) |} ]) diff --git a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs index 765e669..b51b1e6 100644 --- a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs +++ b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs @@ -144,7 +144,7 @@ module Map = /// Create a revision from the current row let toRevision (row : RowReader) : Revision = { AsOf = row.fieldValue "as_of" - Text = row.string "revision_text" |> MarkupText.parse + Text = row.string "revision_text" |> MarkupText.Parse } /// Create a theme asset from the current row @@ -206,7 +206,7 @@ module Revisions = let revParams<'TKey> (key : 'TKey) (keyFunc : 'TKey -> string) rev = [ typedParam "asOf" rev.AsOf "@id", Sql.string (keyFunc key) - "@text", Sql.string (MarkupText.toString rev.Text) + "@text", Sql.string rev.Text.Value ] /// The SQL statement to insert a revision diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 6feb078..8be3d1b 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -7,30 +7,30 @@ open MyWebLog.Data open Npgsql.FSharp /// PostgreSQL myWebLog page data implementation -type PostgresPageData (log : ILogger) = +type PostgresPageData (log: ILogger) = // SUPPORT FUNCTIONS /// Append revisions to a page - let appendPageRevisions (page : Page) = backgroundTask { + let appendPageRevisions (page: Page) = backgroundTask { log.LogTrace "Page.appendPageRevisions" - let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id PageId.toString + let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id _.Value return { page with Revisions = revisions } } /// Return a page with no text or revisions - let pageWithoutText (row : RowReader) = + let pageWithoutText (row: RowReader) = { fromData row with Text = "" } /// Update a page's revisions - let updatePageRevisions pageId oldRevs newRevs = + let updatePageRevisions (pageId: PageId) oldRevs newRevs = log.LogTrace "Page.updatePageRevisions" - Revisions.update Table.PageRevision Table.Page pageId PageId.toString oldRevs newRevs + Revisions.update Table.PageRevision Table.Page pageId (_.Value) oldRevs newRevs /// Does the given page exist? - let pageExists pageId webLogId = + let pageExists (pageId: PageId) webLogId = log.LogTrace "Page.pageExists" - Document.existsByWebLog Table.Page pageId PageId.toString webLogId + Document.existsByWebLog Table.Page pageId (_.Value) webLogId // IMPLEMENTATION FUNCTIONS @@ -51,9 +51,9 @@ type PostgresPageData (log : ILogger) = Count.byContains Table.Page {| webLogDoc webLogId with IsInPageList = true |} /// Find a page by its ID (without revisions) - let findById pageId webLogId = + let findById (pageId: PageId) webLogId = log.LogTrace "Page.findById" - Document.findByIdAndWebLog Table.Page pageId PageId.toString webLogId + Document.findByIdAndWebLog Table.Page pageId (_.Value) webLogId /// Find a complete page by its ID let findFullById pageId webLogId = backgroundTask { @@ -70,15 +70,15 @@ type PostgresPageData (log : ILogger) = log.LogTrace "Page.delete" match! pageExists pageId webLogId with | true -> - do! Delete.byId Table.Page (PageId.toString pageId) + do! Delete.byId Table.Page pageId.Value return true | false -> return false } /// Find a page by its permalink for the given web log - let findByPermalink permalink webLogId = + let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Page.findByPermalink" - Find.byContains Table.Page {| webLogDoc webLogId with Permalink = Permalink.toString permalink |} + Find.byContains Table.Page {| webLogDoc webLogId with Permalink = permalink.Value |} |> tryHead /// Find the current permalink within a set of potential prior permalinks for the given web log @@ -87,7 +87,7 @@ type PostgresPageData (log : ILogger) = if List.isEmpty permalinks then return None else let linkSql, linkParam = - arrayContains (nameof Page.empty.PriorPermalinks) Permalink.toString permalinks + arrayContains (nameof Page.empty.PriorPermalinks) (fun (it: Permalink) -> it.Value) permalinks return! Custom.single $"""SELECT data ->> '{nameof Page.empty.Permalink}' AS permalink @@ -125,7 +125,7 @@ type PostgresPageData (log : ILogger) = fromData /// Restore pages from a backup - let restore (pages : Page list) = backgroundTask { + 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! _ = @@ -134,15 +134,15 @@ type PostgresPageData (log : ILogger) = |> Sql.executeTransactionAsync [ Query.insert Table.Page, pages - |> List.map (fun page -> Query.docParameters (PageId.toString page.Id) { page with Revisions = [] }) + |> List.map (fun page -> Query.docParameters page.Id.Value { page with Revisions = [] }) Revisions.insertSql Table.PageRevision, - revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId PageId.toString rev) + revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId (_.Value) rev) ] () } /// Save a page - let save (page : Page) = backgroundTask { + let save (page: Page) = backgroundTask { log.LogTrace "Page.save" let! oldPage = findFullById page.Id page.WebLogId do! save Table.Page { page with Revisions = [] } @@ -155,7 +155,7 @@ type PostgresPageData (log : ILogger) = log.LogTrace "Page.updatePriorPermalinks" match! pageExists pageId webLogId with | true -> - do! Update.partialById Table.Page (PageId.toString pageId) {| PriorPermalinks = permalinks |} + do! Update.partialById Table.Page pageId.Value {| PriorPermalinks = permalinks |} return true | false -> return false } diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index 70a6c54..c1f6248 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -7,15 +7,15 @@ open MyWebLog.Data open NodaTime.Text open Npgsql.FSharp -/// PostgreSQL myWebLog post data implementation -type PostgresPostData (log : ILogger) = +/// PostgreSQL myWebLog post data implementation +type PostgresPostData(log: ILogger) = // SUPPORT FUNCTIONS /// Append revisions to a post - let appendPostRevisions (post : Post) = backgroundTask { + let appendPostRevisions (post: Post) = backgroundTask { log.LogTrace "Post.appendPostRevisions" - let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id PostId.toString + let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id _.Value return { post with Revisions = revisions } } @@ -24,34 +24,33 @@ type PostgresPostData (log : ILogger) = { fromData row with Text = "" } /// Update a post's revisions - let updatePostRevisions postId oldRevs newRevs = + let updatePostRevisions (postId: PostId) oldRevs newRevs = log.LogTrace "Post.updatePostRevisions" - Revisions.update Table.PostRevision Table.Post postId PostId.toString oldRevs newRevs + Revisions.update Table.PostRevision Table.Post postId (_.Value) oldRevs newRevs /// Does the given post exist? - let postExists postId webLogId = + let postExists (postId: PostId) webLogId = log.LogTrace "Post.postExists" - Document.existsByWebLog Table.Post postId PostId.toString webLogId + Document.existsByWebLog Table.Post postId (_.Value) webLogId // IMPLEMENTATION FUNCTIONS /// Count posts in a status for the given web log - let countByStatus status webLogId = + let countByStatus (status: PostStatus) webLogId = log.LogTrace "Post.countByStatus" - Count.byContains Table.Post {| webLogDoc webLogId with Status = PostStatus.toString status |} + Count.byContains Table.Post {| webLogDoc webLogId with Status = status.Value |} /// Find a post by its ID for the given web log (excluding revisions) let findById postId webLogId = log.LogTrace "Post.findById" - Document.findByIdAndWebLog Table.Post postId PostId.toString webLogId + Document.findByIdAndWebLog Table.Post postId (_.Value) webLogId /// Find a post by its permalink for the given web log (excluding revisions and prior permalinks) - let findByPermalink permalink webLogId = + let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Post.findByPermalink" Custom.single (selectWithCriteria Table.Post) - [ "@criteria", - Query.jsonbDocParam {| webLogDoc webLogId with Permalink = Permalink.toString permalink |} - ] fromData + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Permalink = permalink.Value |} ] + fromData /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { @@ -68,11 +67,10 @@ type PostgresPostData (log : ILogger) = log.LogTrace "Post.delete" match! postExists postId webLogId with | true -> - let theId = PostId.toString postId do! Custom.nonQuery $"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"}; DELETE FROM {Table.Post} WHERE id = @id""" - [ "@id", Sql.string theId; "@criteria", Query.jsonbDocParam {| PostId = theId |} ] + [ "@id", Sql.string postId.Value; "@criteria", Query.jsonbDocParam {| PostId = postId.Value |} ] return true | false -> return false } @@ -83,7 +81,7 @@ type PostgresPostData (log : ILogger) = if List.isEmpty permalinks then return None else let linkSql, linkParam = - arrayContains (nameof Post.empty.PriorPermalinks) Permalink.toString permalinks + arrayContains (nameof Post.empty.PriorPermalinks) (fun (it: Permalink) -> it.Value) permalinks return! Custom.single $"""SELECT data ->> '{nameof Post.empty.Permalink}' AS permalink @@ -106,13 +104,14 @@ type PostgresPostData (log : ILogger) = /// Get a page of categorized posts for the given web log (excludes revisions) let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = log.LogTrace "Post.findPageOfCategorizedPosts" - let catSql, catParam = arrayContains (nameof Post.empty.CategoryIds) (_.Value) categoryIds + let catSql, catParam = + arrayContains (nameof Post.empty.CategoryIds) (fun (it: CategoryId) -> it.Value) categoryIds Custom.list $"{selectWithCriteria Table.Post} AND {catSql} ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = PostStatus.toString Published |} + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} catParam ] fromData @@ -133,7 +132,7 @@ type PostgresPostData (log : ILogger) = $"{selectWithCriteria Table.Post} ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = PostStatus.toString Published |} ] + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} ] fromData /// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks) @@ -144,7 +143,7 @@ type PostgresPostData (log : ILogger) = AND data['{nameof Post.empty.Tags}'] @> @tag ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = PostStatus.toString Published |} + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} "@tag", Query.jsonbDocParam [| tag |] ] fromData @@ -152,7 +151,7 @@ type PostgresPostData (log : ILogger) = let findSurroundingPosts webLogId publishedOn = backgroundTask { log.LogTrace "Post.findSurroundingPosts" let queryParams () = [ - "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = PostStatus.toString Published |} + "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn).Substring (0, 19)) ] let pubField = nameof Post.empty.PublishedOn @@ -188,10 +187,9 @@ type PostgresPostData (log : ILogger) = |> Sql.fromDataSource |> Sql.executeTransactionAsync [ Query.insert Table.Post, - posts - |> List.map (fun post -> Query.docParameters (PostId.toString post.Id) { post with Revisions = [] }) + posts |> List.map (fun post -> Query.docParameters post.Id.Value { post with Revisions = [] }) Revisions.insertSql Table.PostRevision, - revisions |> List.map (fun (postId, rev) -> Revisions.revParams postId PostId.toString rev) + revisions |> List.map (fun (postId, rev) -> Revisions.revParams postId (_.Value) rev) ] () } @@ -201,7 +199,7 @@ type PostgresPostData (log : ILogger) = log.LogTrace "Post.updatePriorPermalinks" match! postExists postId webLogId with | true -> - do! Update.partialById Table.Post (PostId.toString postId) {| PriorPermalinks = permalinks |} + do! Update.partialById Table.Post postId.Value {| PriorPermalinks = permalinks |} return true | false -> return false } diff --git a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs index 97e36eb..136da11 100644 --- a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs @@ -22,7 +22,7 @@ type PostgresUploadData (log : ILogger) = webLogIdParam upload.WebLogId typedParam "updatedOn" upload.UpdatedOn "@id", Sql.string (UploadId.toString upload.Id) - "@path", Sql.string (Permalink.toString upload.Path) + "@path", Sql.string upload.Path.Value "@data", Sql.bytea upload.Data ] diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 73a625f..e653b1f 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -917,7 +917,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger return Result.Error $"Upload ID {UploadId.toString uploadId} not found" } diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 08ab5a4..cdd31a2 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -254,7 +254,7 @@ module Map = Id = getString "id" rdr |> PostId WebLogId = getString "web_log_id" rdr |> WebLogId AuthorId = getString "author_id" rdr |> WebLogUserId - Status = getString "status" rdr |> PostStatus.parse + Status = getString "status" rdr |> PostStatus.Parse Title = getString "title" rdr Permalink = toPermalink rdr PublishedOn = tryInstant "published_on" rdr @@ -270,7 +270,7 @@ module Map = /// 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 + Text = getString "revision_text" rdr |> MarkupText.Parse } /// Create a tag mapping from the current row in the given data reader diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index 5562bcc..c3ae850 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -6,18 +6,18 @@ open MyWebLog open MyWebLog.Data open Newtonsoft.Json -/// SQLite myWebLog page data implementation -type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = +/// SQLite myWebLog page data implementation +type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = // SUPPORT FUNCTIONS /// Add parameters for page INSERT or UPDATE statements - let addPageParameters (cmd : SqliteCommand) (page : Page) = - [ cmd.Parameters.AddWithValue ("@id", PageId.toString page.Id) + let addPageParameters (cmd: SqliteCommand) (page: Page) = + [ cmd.Parameters.AddWithValue ("@id", page.Id.Value) 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 ("@permalink", page.Permalink.Value) cmd.Parameters.AddWithValue ("@publishedOn", instantParam page.PublishedOn) cmd.Parameters.AddWithValue ("@updatedOn", instantParam page.UpdatedOn) cmd.Parameters.AddWithValue ("@isInPageList", page.IsInPageList) @@ -30,7 +30,7 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = /// 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.Parameters.AddWithValue ("@pageId", page.Id.Value) |> ignore cmd.CommandText <- "SELECT permalink FROM page_permalink WHERE page_id = @pageId" use! rdr = cmd.ExecuteReaderAsync () @@ -51,17 +51,17 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = { toPage rdr with Text = "" } /// Update a page's prior permalinks - let updatePagePermalinks pageId oldLinks newLinks = backgroundTask { + let updatePagePermalinks (pageId: PageId) oldLinks newLinks = backgroundTask { let toDelete, toAdd = Utils.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.AddWithValue ("@pageId", pageId.Value) cmd.Parameters.Add ("@link", SqliteType.Text) ] |> ignore - let runCmd link = backgroundTask { - cmd.Parameters["@link"].Value <- Permalink.toString link + let runCmd (link: Permalink) = backgroundTask { + cmd.Parameters["@link"].Value <- link.Value do! write cmd } cmd.CommandText <- "DELETE FROM page_permalink WHERE page_id = @pageId AND permalink = @link" @@ -77,7 +77,7 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = } /// Update a page's revisions - let updatePageRevisions pageId oldRevs newRevs = backgroundTask { + let updatePageRevisions (pageId: PageId) oldRevs newRevs = backgroundTask { let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs if List.isEmpty toDelete && List.isEmpty toAdd then return () @@ -85,10 +85,10 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = use cmd = conn.CreateCommand () let runCmd withText rev = backgroundTask { cmd.Parameters.Clear () - [ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId) + [ cmd.Parameters.AddWithValue ("@pageId", pageId.Value) cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) ] |> ignore - if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore + if withText then cmd.Parameters.AddWithValue ("@text", rev.Text.Value) |> ignore do! write cmd } cmd.CommandText <- "DELETE FROM page_revision WHERE page_id = @pageId AND as_of = @asOf" @@ -154,12 +154,12 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = } /// Find a page by its ID (without revisions and prior permalinks) - let findById pageId webLogId = backgroundTask { + let findById (pageId: PageId) webLogId = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT * FROM page WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore + cmd.Parameters.AddWithValue ("@id", pageId.Value) |> ignore use! rdr = cmd.ExecuteReaderAsync () - return Helpers.verifyWebLog webLogId (fun it -> it.WebLogId) (Map.toPage ser) rdr + return verifyWebLog webLogId (_.WebLogId) (Map.toPage ser) rdr } /// Find a complete page by its ID @@ -175,7 +175,7 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = match! findById pageId webLogId with | Some _ -> use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore + cmd.Parameters.AddWithValue ("@id", pageId.Value) |> ignore cmd.CommandText <- "DELETE FROM page_revision WHERE page_id = @id; DELETE FROM page_permalink WHERE page_id = @id; @@ -186,11 +186,11 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = } /// Find a page by its permalink for the given web log - let findByPermalink permalink webLogId = backgroundTask { + let findByPermalink (permalink: 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 + cmd.Parameters.AddWithValue ("@link", permalink.Value) |> ignore use! rdr = cmd.ExecuteReaderAsync () return if rdr.Read () then Some (toPage rdr) else None } @@ -198,7 +198,7 @@ type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = /// 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 () - let linkSql, linkParams = inClause "AND pp.permalink" "link" Permalink.toString permalinks + let linkSql, linkParams = inClause "AND pp.permalink" "link" (fun (it: Permalink) -> it.Value) permalinks cmd.CommandText <- $" SELECT p.permalink FROM page p diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index d73cf86..c12ecab 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -7,19 +7,19 @@ open MyWebLog.Data open Newtonsoft.Json open NodaTime -/// SQLite myWebLog post data implementation -type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = +/// SQLite myWebLog post data implementation +type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = // SUPPORT FUNCTIONS /// Add parameters for post INSERT or UPDATE statements - let addPostParameters (cmd : SqliteCommand) (post : Post) = - [ cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) + let addPostParameters (cmd: SqliteCommand) (post: Post) = + [ cmd.Parameters.AddWithValue ("@id", post.Id.Value) 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 ("@status", post.Status.Value) cmd.Parameters.AddWithValue ("@title", post.Title) - cmd.Parameters.AddWithValue ("@permalink", Permalink.toString post.Permalink) + cmd.Parameters.AddWithValue ("@permalink", post.Permalink.Value) cmd.Parameters.AddWithValue ("@publishedOn", maybeInstant post.PublishedOn) cmd.Parameters.AddWithValue ("@updatedOn", instantParam post.UpdatedOn) cmd.Parameters.AddWithValue ("@template", maybe post.Template) @@ -32,9 +32,9 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = ] |> ignore /// Append category IDs and tags to a post - let appendPostCategoryAndTag (post : Post) = backgroundTask { + let appendPostCategoryAndTag (post: Post) = backgroundTask { use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) |> ignore + cmd.Parameters.AddWithValue ("@id", post.Id.Value) |> ignore cmd.CommandText <- "SELECT category_id AS id FROM post_category WHERE post_id = @id" use! rdr = cmd.ExecuteReaderAsync () @@ -47,9 +47,9 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = } /// Append revisions and permalinks to a post - let appendPostRevisionsAndPermalinks (post : Post) = backgroundTask { + let appendPostRevisionsAndPermalinks (post: Post) = backgroundTask { use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@postId", PostId.toString post.Id) |> ignore + cmd.Parameters.AddWithValue ("@postId", post.Id.Value) |> ignore cmd.CommandText <- "SELECT permalink FROM post_permalink WHERE post_id = @postId" use! rdr = cmd.ExecuteReaderAsync () @@ -69,12 +69,12 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = Map.toPost ser /// Find just-the-post by its ID for the given web log (excludes category, tag, meta, revisions, and permalinks) - let findPostById postId webLogId = backgroundTask { + let findPostById (postId: PostId) webLogId = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- $"{selectPost} WHERE p.id = @id" - cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore + cmd.Parameters.AddWithValue ("@id", postId.Value) |> ignore use! rdr = cmd.ExecuteReaderAsync () - return Helpers.verifyWebLog webLogId (fun p -> p.WebLogId) toPost rdr + return verifyWebLog webLogId (_.WebLogId) toPost rdr } /// Return a post with no revisions, prior permalinks, or text @@ -82,13 +82,13 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = { toPost rdr with Text = "" } /// Update a post's assigned categories - let updatePostCategories postId oldCats newCats = backgroundTask { + let updatePostCategories (postId: PostId) oldCats newCats = backgroundTask { let toDelete, toAdd = Utils.diffLists oldCats newCats _.Value if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) + [ cmd.Parameters.AddWithValue ("@postId", postId.Value) cmd.Parameters.Add ("@categoryId", SqliteType.Text) ] |> ignore let runCmd (catId: CategoryId) = backgroundTask { @@ -108,16 +108,16 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = } /// Update a post's assigned categories - let updatePostTags postId (oldTags : string list) newTags = backgroundTask { + let updatePostTags (postId: PostId) (oldTags: string list) newTags = backgroundTask { let toDelete, toAdd = Utils.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.AddWithValue ("@postId", postId.Value) cmd.Parameters.Add ("@tag", SqliteType.Text) ] |> ignore - let runCmd (tag : string) = backgroundTask { + let runCmd (tag: string) = backgroundTask { cmd.Parameters["@tag"].Value <- tag do! write cmd } @@ -134,17 +134,17 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = } /// Update a post's prior permalinks - let updatePostPermalinks postId oldLinks newLinks = backgroundTask { + let updatePostPermalinks (postId: PostId) oldLinks newLinks = backgroundTask { let toDelete, toAdd = Utils.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.AddWithValue ("@postId", postId.Value) cmd.Parameters.Add ("@link", SqliteType.Text) ] |> ignore - let runCmd link = backgroundTask { - cmd.Parameters["@link"].Value <- Permalink.toString link + let runCmd (link: Permalink) = backgroundTask { + cmd.Parameters["@link"].Value <- link.Value do! write cmd } cmd.CommandText <- "DELETE FROM post_permalink WHERE post_id = @postId AND permalink = @link" @@ -160,7 +160,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = } /// Update a post's revisions - let updatePostRevisions postId oldRevs newRevs = backgroundTask { + let updatePostRevisions (postId: PostId) oldRevs newRevs = backgroundTask { let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs if List.isEmpty toDelete && List.isEmpty toAdd then return () @@ -168,10 +168,10 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = use cmd = conn.CreateCommand () let runCmd withText rev = backgroundTask { cmd.Parameters.Clear () - [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) + [ cmd.Parameters.AddWithValue ("@postId", postId.Value) cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) ] |> ignore - if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore + if withText then cmd.Parameters.AddWithValue ("@text", rev.Text.Value) |> ignore do! write cmd } cmd.CommandText <- "DELETE FROM post_revision WHERE post_id = @postId AND as_of = @asOf" @@ -208,11 +208,11 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = } /// Count posts in a status for the given web log - let countByStatus status webLogId = backgroundTask { + let countByStatus (status: PostStatus) 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 + cmd.Parameters.AddWithValue ("@status", status.Value) |> ignore return! count cmd } @@ -226,11 +226,11 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = } /// Find a post by its permalink for the given web log (excluding revisions and prior permalinks) - let findByPermalink permalink webLogId = backgroundTask { + let findByPermalink (permalink: 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 + cmd.Parameters.AddWithValue ("@link", permalink.Value) |> ignore use! rdr = cmd.ExecuteReaderAsync () if rdr.Read () then let! post = appendPostCategoryAndTag (toPost rdr) @@ -253,7 +253,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = match! findFullById postId webLogId with | Some _ -> use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore + cmd.Parameters.AddWithValue ("@id", postId.Value) |> ignore cmd.CommandText <- "DELETE FROM post_revision WHERE post_id = @id; DELETE FROM post_permalink WHERE post_id = @id; @@ -269,7 +269,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = /// 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 () - let linkSql, linkParams = inClause "AND pp.permalink" "link" Permalink.toString permalinks + let linkSql, linkParams = inClause "AND pp.permalink" "link" (fun (it: Permalink) -> it.Value) permalinks cmd.CommandText <- $" SELECT p.permalink FROM post p @@ -301,7 +301,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = /// 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 () - let catSql, catParams = inClause "AND pc.category_id" "catId" (_.Value) categoryIds + let catSql, catParams = inClause "AND pc.category_id" "catId" (fun (it: CategoryId) -> it.Value) categoryIds cmd.CommandText <- $" {selectPost} INNER JOIN post_category pc ON pc.post_id = p.id @@ -311,7 +311,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = ORDER BY published_on DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore + cmd.Parameters.AddWithValue ("@status", Published.Value) |> ignore cmd.Parameters.AddRange catParams use! rdr = cmd.ExecuteReaderAsync () let! posts = @@ -348,7 +348,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = ORDER BY p.published_on DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore + cmd.Parameters.AddWithValue ("@status", Published.Value) |> ignore use! rdr = cmd.ExecuteReaderAsync () let! posts = toList toPost rdr @@ -369,7 +369,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = 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 ("@status", Published.Value) cmd.Parameters.AddWithValue ("@tag", tag) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () @@ -391,7 +391,7 @@ type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = ORDER BY p.published_on DESC LIMIT 1" addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) + [ cmd.Parameters.AddWithValue ("@status", Published.Value) cmd.Parameters.AddWithValue ("@publishedOn", instantParam publishedOn) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () diff --git a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs index 886e113..3614b79 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs @@ -12,7 +12,7 @@ type SQLiteUploadData (conn : SqliteConnection) = 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 ("@path", upload.Path.Value) cmd.Parameters.AddWithValue ("@updatedOn", instantParam upload.UpdatedOn) cmd.Parameters.AddWithValue ("@dataLength", upload.Data.Length) ] |> ignore @@ -53,7 +53,7 @@ type SQLiteUploadData (conn : SqliteConnection) = 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) + return Ok upload.Path.Value else return Error $"""Upload ID {cmd.Parameters["@id"]} not found""" } diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index f4b64e7..11a347c 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -46,7 +46,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = [ 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) + cmd.Parameters.AddWithValue ("@path", feed.Path.Value) cmd.Parameters.AddWithValue ("@podcast", maybe (if Option.isSome feed.Podcast then Some (Utils.serialize ser feed.Podcast) else None)) diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 61d5f48..c25d9c2 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -195,7 +195,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS FundingUrl = Map.tryString "funding_url" podcastRdr FundingText = Map.tryString "funding_text" podcastRdr Medium = Map.tryString "medium" podcastRdr - |> Option.map PodcastMedium.parse + |> Option.map PodcastMedium.Parse } } |> List.ofSeq podcastRdr.Close () @@ -241,7 +241,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS |> 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", PostId.toString postId) ] |> ignore + cmd.Parameters.AddWithValue ("@id", postId.Value) ] |> ignore let _ = cmd.ExecuteNonQuery () cmd.Parameters.Clear ()) diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index 14f94aa..285a5f2 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -34,11 +34,11 @@ let diffMetaItems (oldItems : MetaItem list) newItems = /// Find the permalinks added and removed let diffPermalinks oldLinks newLinks = - diffLists oldLinks newLinks Permalink.toString + diffLists oldLinks newLinks (fun (it: Permalink) -> it.Value) /// Find the revisions added and removed let diffRevisions oldRevs newRevs = - diffLists oldRevs newRevs (fun (rev: Revision) -> $"{rev.AsOf.ToUnixTimeTicks()}|{MarkupText.toString rev.Text}") + diffLists oldRevs newRevs (fun (rev: Revision) -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text.Value}") open MyWebLog.Converters open Newtonsoft.Json diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index baf4742..ad0c0d1 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -77,7 +77,7 @@ module Comment = /// An empty comment let empty = { Id = CommentId.Empty - PostId = PostId.empty + PostId = PostId.Empty InReplyToId = None Name = "" Email = "" @@ -136,11 +136,11 @@ module Page = /// An empty page let empty = { - Id = PageId.empty + Id = PageId.Empty WebLogId = WebLogId.empty AuthorId = WebLogUserId.empty Title = "" - Permalink = Permalink.empty + Permalink = Permalink.Empty PublishedOn = Noda.epoch UpdatedOn = Noda.epoch IsInPageList = false @@ -209,12 +209,12 @@ module Post = /// An empty post let empty = { - Id = PostId.empty + Id = PostId.Empty WebLogId = WebLogId.empty AuthorId = WebLogUserId.empty Status = Draft Title = "" - Permalink = Permalink.empty + Permalink = Permalink.Empty PublishedOn = None UpdatedOn = Noda.epoch Text = "" @@ -330,7 +330,7 @@ module Upload = let empty = { Id = UploadId.empty WebLogId = WebLogId.empty - Path = Permalink.empty + Path = Permalink.Empty UpdatedOn = Noda.epoch Data = [||] } @@ -406,16 +406,16 @@ module WebLog = $"{scheme[0]}://{host[0]}", if host.Length > 1 then $"""/{String.Join("/", host |> Array.skip 1)}""" else "" /// Generate an absolute URL for the given link - let absoluteUrl webLog permalink = - $"{webLog.UrlBase}/{Permalink.toString permalink}" + let absoluteUrl webLog (permalink: Permalink) = + $"{webLog.UrlBase}/{permalink.Value}" /// Generate a relative URL for the given link - let relativeUrl webLog permalink = + let relativeUrl webLog (permalink: Permalink) = let _, leadPath = hostAndPath webLog - $"{leadPath}/{Permalink.toString permalink}" + $"{leadPath}/{permalink.Value}" /// Convert an Instant (UTC reference) to the web log's local date/time - let localTime webLog (date : Instant) = + let localTime webLog (date: Instant) = match DateTimeZoneProviders.Tzdb[webLog.TimeZone] with | null -> date.ToDateTimeUtc() | tz -> date.InZone(tz).ToDateTimeUnspecified() diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index e6ac59c..ed25389 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -1,16 +1,22 @@ namespace MyWebLog open System +open Markdig open NodaTime /// Support functions for domain definition [] 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('+', '-')[..22] + + /// Pipeline with most extensions enabled + let markdownPipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build() /// Functions to support NodaTime manipulation @@ -275,9 +281,6 @@ type Episode = { this.Duration |> Option.map (DurationPattern.CreateWithInvariantCulture("H:mm:ss").Format) -open Markdig -open Markdown.ColorCode - /// Types of markup text type MarkupText = /// Markdown text @@ -285,30 +288,27 @@ 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) = + static member Parse(it: string) = match it with | text when text.StartsWith "Markdown: " -> Markdown text[10..] | text when text.StartsWith "HTML: " -> Html text[6..] | text -> invalidOp $"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 + member this.Value = $"{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 @@ -319,15 +319,13 @@ type MetaItem = { /// 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 [] type Revision = { @@ -336,46 +334,45 @@ type Revision = { /// The text of the revision Text : MarkupText -} - -/// Functions to support revisions -module Revision = +} with /// An empty revision - let empty = + static member Empty = { AsOf = Noda.epoch; Text = Html "" } /// A permanent link -type Permalink = Permalink of string +[] +type Permalink = + | Permalink of string -/// Functions to support permalinks -module Permalink = - /// An empty permalink - let empty = Permalink "" - - /// Convert a permalink to a string - let toString = function Permalink p -> p + static member Empty = Permalink "" + + /// The string value of this permalink + member this.Value = + match this with Permalink it -> it /// An identifier for a page -type PageId = PageId of string +[] +type PageId = + | PageId of string -/// Functions to support page IDs -module PageId = - /// 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 = newId >> PageId + static member Create = + newId >> PageId + + /// The string value of this page ID + member this.Value = + match this with PageId it -> it /// PodcastIndex.org podcast:medium allowed values +[] type PodcastMedium = | Podcast | Music @@ -385,87 +382,82 @@ type PodcastMedium = | Newsletter | Blog -/// Functions to support podcast medium -module PodcastMedium = - - /// Convert a podcast medium to a string - let toString = - function - | Podcast -> "podcast" - | Music -> "music" - | Video -> "video" - | Film -> "film" - | Audiobook -> "audiobook" - | 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 + static member Parse = + function + | "podcast" -> Podcast + | "music" -> Music + | "video" -> Video + | "film" -> Film + | "audiobook" -> Audiobook | "newsletter" -> Newsletter - | "blog" -> Blog - | it -> invalidArg "medium" $"{it} is not a valid podcast medium" + | "blog" -> Blog + | it -> invalidArg "medium" $"{it} is not a valid podcast medium" + + /// The string value of this podcast medium + member this.Value = + match this with + | Podcast -> "podcast" + | Music -> "music" + | Video -> "video" + | Film -> "film" + | Audiobook -> "audiobook" + | Newsletter -> "newsletter" + | Blog -> "blog" /// Statuses for posts +[] 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 = + function | "Draft" -> Draft | "Published" -> Published - | it -> invalidArg "status" $"{it} is not a valid post status" + | it -> invalidArg "status" $"{it} is not a valid post status" + + /// The string representation of this post status + member this.Value = + match this with Draft -> "Draft" | Published -> "Published" /// An identifier for a post -type PostId = PostId of string +[] +type PostId = + | PostId of string -/// Functions to support post IDs -module PostId = - /// 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 = newId >> PostId + static member Create = + newId >> PostId + + /// Convert a post ID to a string + member this.Value = + match this with PostId it -> it /// A redirection for a previously valid URL +[] type RedirectRule = { /// The From string or pattern - From : string + From: string /// The To string or pattern - To : string + To: string /// Whether to use regular expressions on this rule - IsRegex : bool -} - -/// Functions to support redirect rules -module RedirectRule = - + IsRegex: bool +} with + /// An empty redirect rule - let empty = { + static member Empty = { From = "" To = "" IsRegex = false diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 28c85e5..2f9a176 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -89,14 +89,14 @@ type DisplayCustomFeed = { module DisplayCustomFeed = /// Create a display version from a custom feed - let fromFeed (cats : DisplayCategory[]) (feed : CustomFeed) : DisplayCustomFeed = + let fromFeed (cats: DisplayCategory[]) (feed: CustomFeed) : DisplayCustomFeed = let source = match feed.Source with | Category (CategoryId catId) -> $"Category: {(cats |> Array.find (fun cat -> cat.Id = catId)).Name}" | Tag tag -> $"Tag: {tag}" { Id = CustomFeedId.toString feed.Id Source = source - Path = Permalink.toString feed.Path + Path = feed.Path.Value IsPodcast = Option.isSome feed.Podcast } @@ -136,32 +136,30 @@ type DisplayPage = } /// Create a minimal display page (no text or metadata) from a database page - static member FromPageMinimal webLog (page : Page) = - let pageId = PageId.toString page.Id - { Id = pageId - AuthorId = WebLogUserId.toString page.AuthorId - Title = page.Title - Permalink = Permalink.toString page.Permalink - PublishedOn = WebLog.localTime webLog page.PublishedOn - UpdatedOn = WebLog.localTime webLog page.UpdatedOn - IsInPageList = page.IsInPageList - IsDefault = pageId = webLog.DefaultPage - Text = "" - Metadata = [] - } + static member FromPageMinimal webLog (page: Page) = { + Id = page.Id.Value + AuthorId = WebLogUserId.toString page.AuthorId + Title = page.Title + Permalink = page.Permalink.Value + PublishedOn = WebLog.localTime webLog page.PublishedOn + UpdatedOn = WebLog.localTime webLog page.UpdatedOn + IsInPageList = page.IsInPageList + IsDefault = page.Id.Value = webLog.DefaultPage + Text = "" + Metadata = [] + } /// Create a display page from a database page static member FromPage webLog (page : Page) = let _, extra = WebLog.hostAndPath webLog - let pageId = PageId.toString page.Id - { Id = pageId + { Id = page.Id.Value AuthorId = WebLogUserId.toString page.AuthorId Title = page.Title - Permalink = Permalink.toString page.Permalink + Permalink = page.Permalink.Value PublishedOn = WebLog.localTime webLog page.PublishedOn UpdatedOn = WebLog.localTime webLog page.UpdatedOn IsInPageList = page.IsInPageList - IsDefault = pageId = webLog.DefaultPage + IsDefault = page.Id.Value = webLog.DefaultPage Text = addBaseToRelativeUrls extra page.Text Metadata = page.Metadata } @@ -187,7 +185,7 @@ module DisplayRevision = let fromRevision webLog (rev : Revision) = { AsOf = rev.AsOf.ToDateTimeUtc () AsOfLocal = WebLog.localTime webLog rev.AsOf - Format = MarkupText.sourceType rev.Text + Format = rev.Text.SourceType } @@ -253,7 +251,7 @@ module DisplayUpload = /// Create a display uploaded file let fromUpload webLog source (upload : Upload) = - let path = Permalink.toString upload.Path + let path = upload.Path.Value let name = Path.GetFileName path { Id = UploadId.toString upload.Id Name = name @@ -436,13 +434,13 @@ type EditCustomFeedModel = } /// Create a model from a custom feed - static member fromFeed (feed : CustomFeed) = + static member fromFeed (feed: CustomFeed) = let rss = { EditCustomFeedModel.empty with Id = CustomFeedId.toString feed.Id SourceType = match feed.Source with Category _ -> "category" | Tag _ -> "tag" SourceValue = match feed.Source with Category (CategoryId catId) -> catId | Tag tag -> tag - Path = Permalink.toString feed.Path + Path = feed.Path.Value } match feed.Podcast with | Some p -> @@ -454,7 +452,7 @@ type EditCustomFeedModel = Summary = p.Summary DisplayedAuthor = p.DisplayedAuthor Email = p.Email - ImageUrl = Permalink.toString p.ImageUrl + ImageUrl = p.ImageUrl.Value AppleCategory = p.AppleCategory AppleSubcategory = defaultArg p.AppleSubcategory "" Explicit = p.Explicit.Value @@ -462,10 +460,8 @@ type EditCustomFeedModel = MediaBaseUrl = defaultArg p.MediaBaseUrl "" FundingUrl = defaultArg p.FundingUrl "" FundingText = defaultArg p.FundingText "" - PodcastGuid = p.PodcastGuid - |> Option.map (fun it -> it.ToString().ToLowerInvariant ()) - |> Option.defaultValue "" - Medium = p.Medium |> Option.map PodcastMedium.toString |> Option.defaultValue "" + PodcastGuid = p.PodcastGuid |> Option.map _.ToString().ToLowerInvariant() |> Option.defaultValue "" + Medium = p.Medium |> Option.map _.Value |> Option.defaultValue "" } | None -> rss @@ -492,7 +488,7 @@ type EditCustomFeedModel = PodcastGuid = noneIfBlank this.PodcastGuid |> Option.map Guid.Parse FundingUrl = noneIfBlank this.FundingUrl FundingText = noneIfBlank this.FundingText - Medium = noneIfBlank this.Medium |> Option.map PodcastMedium.parse + Medium = noneIfBlank this.Medium |> Option.map PodcastMedium.Parse } else None @@ -530,61 +526,61 @@ type EditMyInfoModel = /// View model to edit a page [] -type EditPageModel = - { /// The ID of the page being edited - PageId : string +type EditPageModel = { + /// The ID of the page being edited + PageId: string - /// The title of the page - Title : string + /// The title of the page + Title: string - /// The permalink for the page - Permalink : string + /// The permalink for the page + Permalink: string - /// The template to use to display the page - Template : string - - /// Whether this page is shown in the page list - IsShownInPageList : bool + /// The template to use to display the page + Template: string + + /// Whether this page is shown in the page list + IsShownInPageList: bool - /// The source format for the text - Source : string + /// The source format for the text + Source: string - /// The text of the page - Text : string - - /// Names of metadata items - MetaNames : string[] - - /// Values of metadata items - MetaValues : string[] - } + /// The text of the page + Text: string + + /// Names of metadata items + MetaNames: string array + + /// Values of metadata items + MetaValues: string array +} with /// Create an edit model from an existing page - static member fromPage (page : Page) = + static member fromPage (page: Page) = let latest = - match page.Revisions |> List.sortByDescending (fun r -> r.AsOf) |> List.tryHead with + match page.Revisions |> List.sortByDescending _.AsOf |> List.tryHead with | Some rev -> rev - | None -> Revision.empty - let page = if page.Metadata |> List.isEmpty then { page with Metadata = [ MetaItem.empty ] } else page - { PageId = PageId.toString page.Id + | None -> Revision.Empty + let page = if page.Metadata |> List.isEmpty then { page with Metadata = [ MetaItem.Empty ] } else page + { PageId = page.Id.Value Title = page.Title - Permalink = Permalink.toString page.Permalink + Permalink = page.Permalink.Value Template = defaultArg page.Template "" IsShownInPageList = page.IsInPageList - Source = MarkupText.sourceType latest.Text - Text = MarkupText.text latest.Text - MetaNames = page.Metadata |> List.map (fun m -> m.Name) |> Array.ofList - MetaValues = page.Metadata |> List.map (fun m -> m.Value) |> Array.ofList + Source = latest.Text.SourceType + Text = latest.Text.Text + MetaNames = page.Metadata |> List.map _.Name |> Array.ofList + MetaValues = page.Metadata |> List.map _.Value |> Array.ofList } /// Whether this is a new page member this.IsNew = this.PageId = "new" /// Update a page with values from this model - member this.UpdatePage (page : Page) now = - let revision = { AsOf = now; Text = MarkupText.parse $"{this.Source}: {this.Text}" } + member this.UpdatePage (page: Page) now = + let revision = { AsOf = now; Text = MarkupText.Parse $"{this.Source}: {this.Text}" } // Detect a permalink change, and add the prior one to the prior list - match Permalink.toString page.Permalink with + match page.Permalink.Value with | "" -> page | link when link = this.Permalink -> page | _ -> { page with PriorPermalinks = page.Permalink :: page.PriorPermalinks } @@ -596,7 +592,7 @@ type EditPageModel = UpdatedOn = now IsInPageList = this.IsShownInPageList Template = match this.Template with "" -> None | tmpl -> Some tmpl - Text = MarkupText.toHtml revision.Text + Text = revision.Text.AsHtml() Metadata = Seq.zip this.MetaNames this.MetaValues |> Seq.filter (fun it -> fst it > "") |> Seq.map (fun it -> { Name = fst it; Value = snd it }) @@ -610,127 +606,127 @@ type EditPageModel = /// View model to edit a post [] -type EditPostModel = - { /// The ID of the post being edited - PostId : string +type EditPostModel = { + /// The ID of the post being edited + PostId: string - /// The title of the post - Title : string + /// The title of the post + Title: string - /// The permalink for the post - Permalink : string + /// The permalink for the post + Permalink: string - /// The source format for the text - Source : string + /// The source format for the text + Source: string - /// The text of the post - Text : string - - /// The tags for the post - Tags : string - - /// The template used to display the post - Template : string - - /// The category IDs for the post - CategoryIds : string[] - - /// The post status - Status : string - - /// Whether this post should be published - DoPublish : bool - - /// Names of metadata items - MetaNames : string[] - - /// Values of metadata items - MetaValues : string[] - - /// Whether to override the published date/time - SetPublished : bool - - /// The published date/time to override - PubOverride : Nullable - - /// Whether all revisions should be purged and the override date set as the updated date as well - SetUpdated : bool - - /// Whether this post has a podcast episode - IsEpisode : bool - - /// The URL for the media for this episode (may be permalink) - Media : string - - /// The size (in bytes) of the media for this episode - Length : int64 - - /// The duration of the media for this episode - Duration : string - - /// The media type (optional, defaults to podcast-defined media type) - MediaType : string - - /// The URL for the image for this episode (may be permalink; optional, defaults to podcast image) - ImageUrl : string - - /// A subtitle for the episode (optional) - Subtitle : string - - /// The explicit rating for this episode (optional, defaults to podcast setting) - Explicit : string - - /// The URL for the chapter file for the episode (may be permalink; optional) - ChapterFile : string - - /// The type of the chapter file (optional; defaults to application/json+chapters if chapterFile is provided) - ChapterType : string - - /// The URL for the transcript (may be permalink; optional) - TranscriptUrl : string - - /// The MIME type for the transcript (optional, recommended if transcriptUrl is provided) - TranscriptType : string - - /// The language of the transcript (optional) - TranscriptLang : string - - /// Whether the provided transcript should be presented as captions - TranscriptCaptions : bool - - /// The season number (optional) - SeasonNumber : int - - /// A description of this season (optional, ignored if season number is not provided) - SeasonDescription : string - - /// The episode number (decimal; optional) - EpisodeNumber : string - - /// A description of this episode (optional, ignored if episode number is not provided) - EpisodeDescription : string - } + /// The text of the post + Text: string + + /// The tags for the post + Tags: string + + /// The template used to display the post + Template: string + + /// The category IDs for the post + CategoryIds: string array + + /// The post status + Status: string + + /// Whether this post should be published + DoPublish: bool + + /// Names of metadata items + MetaNames: string array + + /// Values of metadata items + MetaValues: string array + + /// Whether to override the published date/time + SetPublished: bool + + /// The published date/time to override + PubOverride: Nullable + + /// Whether all revisions should be purged and the override date set as the updated date as well + SetUpdated: bool + + /// Whether this post has a podcast episode + IsEpisode: bool + + /// The URL for the media for this episode (may be permalink) + Media: string + + /// The size (in bytes) of the media for this episode + Length: int64 + + /// The duration of the media for this episode + Duration: string + + /// The media type (optional, defaults to podcast-defined media type) + MediaType: string + + /// The URL for the image for this episode (may be permalink; optional, defaults to podcast image) + ImageUrl: string + + /// A subtitle for the episode (optional) + Subtitle: string + + /// The explicit rating for this episode (optional, defaults to podcast setting) + Explicit: string + + /// The URL for the chapter file for the episode (may be permalink; optional) + ChapterFile: string + + /// The type of the chapter file (optional; defaults to application/json+chapters if chapterFile is provided) + ChapterType: string + + /// The URL for the transcript (may be permalink; optional) + TranscriptUrl: string + + /// The MIME type for the transcript (optional, recommended if transcriptUrl is provided) + TranscriptType: string + + /// The language of the transcript (optional) + TranscriptLang: string + + /// Whether the provided transcript should be presented as captions + TranscriptCaptions: bool + + /// The season number (optional) + SeasonNumber: int + + /// A description of this season (optional, ignored if season number is not provided) + SeasonDescription: string + + /// The episode number (decimal; optional) + EpisodeNumber: string + + /// A description of this episode (optional, ignored if episode number is not provided) + EpisodeDescription: string +} with /// Create an edit model from an existing past - static member fromPost webLog (post : Post) = + static member fromPost webLog (post: Post) = let latest = - match post.Revisions |> List.sortByDescending (_.AsOf) |> List.tryHead with + match post.Revisions |> List.sortByDescending _.AsOf |> List.tryHead with | Some rev -> rev - | None -> Revision.empty - let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.empty ] } else post + | None -> Revision.Empty + let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.Empty ] } else post let episode = defaultArg post.Episode Episode.Empty - { PostId = PostId.toString post.Id + { PostId = post.Id.Value Title = post.Title - Permalink = Permalink.toString post.Permalink - Source = MarkupText.sourceType latest.Text - Text = MarkupText.text latest.Text + Permalink = post.Permalink.Value + Source = latest.Text.SourceType + Text = latest.Text.Text Tags = String.Join (", ", post.Tags) Template = defaultArg post.Template "" - CategoryIds = post.CategoryIds |> List.map (_.Value) |> Array.ofList - Status = PostStatus.toString post.Status + CategoryIds = post.CategoryIds |> List.map _.Value |> Array.ofList + Status = post.Status.Value DoPublish = false - MetaNames = post.Metadata |> List.map (_.Name) |> Array.ofList - MetaValues = post.Metadata |> List.map (_.Value) |> Array.ofList + MetaNames = post.Metadata |> List.map _.Name |> Array.ofList + MetaValues = post.Metadata |> List.map _.Value |> Array.ofList SetPublished = false PubOverride = post.PublishedOn |> Option.map (WebLog.localTime webLog) |> Option.toNullable SetUpdated = false @@ -741,7 +737,7 @@ type EditPostModel = MediaType = defaultArg episode.MediaType "" ImageUrl = defaultArg episode.ImageUrl "" Subtitle = defaultArg episode.Subtitle "" - Explicit = defaultArg (episode.Explicit |> Option.map (_.Value)) "" + Explicit = defaultArg (episode.Explicit |> Option.map _.Value) "" ChapterFile = defaultArg episode.ChapterFile "" ChapterType = defaultArg episode.ChapterType "" TranscriptUrl = defaultArg episode.TranscriptUrl "" @@ -758,10 +754,10 @@ type EditPostModel = member this.IsNew = this.PostId = "new" /// Update a post with values from the submitted form - member this.UpdatePost (post : Post) now = - let revision = { AsOf = now; Text = MarkupText.parse $"{this.Source}: {this.Text}" } + member this.UpdatePost (post: Post) now = + let revision = { AsOf = now; Text = MarkupText.Parse $"{this.Source}: {this.Text}" } // Detect a permalink change, and add the prior one to the prior list - match Permalink.toString post.Permalink with + match post.Permalink.Value with | "" -> post | link when link = this.Permalink -> post | _ -> { post with PriorPermalinks = post.Permalink :: post.PriorPermalinks } @@ -772,7 +768,7 @@ type EditPostModel = Permalink = Permalink this.Permalink PublishedOn = if this.DoPublish then Some now else post.PublishedOn UpdatedOn = now - Text = MarkupText.toHtml revision.Text + Text = revision.Text.AsHtml() Tags = this.Tags.Split "," |> Seq.ofArray |> Seq.map (fun it -> it.Trim().ToLower ()) @@ -1005,39 +1001,39 @@ type LogOnModel = /// View model to manage permalinks [] -type ManagePermalinksModel = - { /// The ID for the entity being edited - Id : string - - /// The type of entity being edited ("page" or "post") - Entity : string - - /// The current title of the page or post - CurrentTitle : string - - /// The current permalink of the page or post - CurrentPermalink : string - - /// The prior permalinks for the page or post - Prior : string[] - } +type ManagePermalinksModel = { + /// The ID for the entity being edited + Id: string + + /// The type of entity being edited ("page" or "post") + Entity: string + + /// The current title of the page or post + CurrentTitle: string + + /// The current permalink of the page or post + CurrentPermalink: string + + /// The prior permalinks for the page or post + Prior: string array +} with /// Create a permalink model from a page - static member fromPage (pg : Page) = - { Id = PageId.toString pg.Id + static member fromPage (pg: Page) = + { Id = pg.Id.Value Entity = "page" CurrentTitle = pg.Title - CurrentPermalink = Permalink.toString pg.Permalink - Prior = pg.PriorPermalinks |> List.map Permalink.toString |> Array.ofList + CurrentPermalink = pg.Permalink.Value + Prior = pg.PriorPermalinks |> List.map _.Value |> Array.ofList } /// Create a permalink model from a post - static member fromPost (post : Post) = - { Id = PostId.toString post.Id + static member fromPost (post: Post) = + { Id = post.Id.Value Entity = "post" CurrentTitle = post.Title - CurrentPermalink = Permalink.toString post.Permalink - Prior = post.PriorPermalinks |> List.map Permalink.toString |> Array.ofList + CurrentPermalink = post.Permalink.Value + Prior = post.PriorPermalinks |> List.map _.Value |> Array.ofList } @@ -1054,20 +1050,20 @@ type ManageRevisionsModel = CurrentTitle : string /// The revisions for the page or post - Revisions : DisplayRevision[] + Revisions : DisplayRevision array } /// Create a revision model from a page - static member fromPage webLog (pg : Page) = - { Id = PageId.toString pg.Id + static member fromPage webLog (pg: Page) = + { Id = pg.Id.Value Entity = "page" CurrentTitle = pg.Title Revisions = pg.Revisions |> List.map (DisplayRevision.fromRevision webLog) |> Array.ofList } /// Create a revision model from a post - static member fromPost webLog (post : Post) = - { Id = PostId.toString post.Id + static member fromPost webLog (post: Post) = + { Id = post.Id.Value Entity = "post" CurrentTitle = post.Title Revisions = post.Revisions |> List.map (DisplayRevision.fromRevision webLog) |> Array.ofList @@ -1076,53 +1072,53 @@ type ManageRevisionsModel = /// View model for posts in a list [] -type PostListItem = - { /// The ID of the post - Id : string - - /// The ID of the user who authored the post - AuthorId : string - - /// The status of the post - Status : string - - /// The title of the post - Title : string - - /// The permalink for the post - Permalink : string - - /// When this post was published - PublishedOn : Nullable - - /// When this post was last updated - UpdatedOn : DateTime - - /// The text of the post - Text : string - - /// The IDs of the categories for this post - CategoryIds : string list - - /// Tags for the post - Tags : string list - - /// The podcast episode information for this post - Episode : Episode option - - /// Metadata for the post - Metadata : MetaItem list - } +type PostListItem = { + /// The ID of the post + Id: string + + /// The ID of the user who authored the post + AuthorId: string + + /// The status of the post + Status: string + + /// The title of the post + Title: string + + /// The permalink for the post + Permalink: string + + /// When this post was published + PublishedOn: Nullable + + /// When this post was last updated + UpdatedOn: DateTime + + /// The text of the post + Text: string + + /// The IDs of the categories for this post + CategoryIds: string list + + /// Tags for the post + Tags: string list + + /// The podcast episode information for this post + Episode: Episode option + + /// Metadata for the post + Metadata: MetaItem list +} with /// Create a post list item from a post - static member fromPost (webLog : WebLog) (post : Post) = + static member fromPost (webLog: WebLog) (post: Post) = let _, extra = WebLog.hostAndPath webLog let inTZ = WebLog.localTime webLog - { Id = PostId.toString post.Id + { Id = post.Id.Value AuthorId = WebLogUserId.toString post.AuthorId - Status = PostStatus.toString post.Status + Status = post.Status.Value Title = post.Title - Permalink = Permalink.toString post.Permalink + Permalink = post.Permalink.Value PublishedOn = post.PublishedOn |> Option.map inTZ |> Option.toNullable UpdatedOn = inTZ post.UpdatedOn Text = addBaseToRelativeUrls extra post.Text diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 83e9a3f..45006b7 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -101,10 +101,10 @@ type ThemeAssetFilter () = /// Create various items in the page header based on the state of the page being generated -type PageHeadTag () = - inherit Tag () +type PageHeadTag() = + inherit Tag() - override this.Render (context : Context, result : TextWriter) = + override this.Render(context: Context, result: TextWriter) = let webLog = context.WebLog // spacer let s = " " @@ -115,9 +115,9 @@ type PageHeadTag () = // Theme assets if assetExists "style.css" webLog then - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" if assetExists "favicon.ico" webLog then - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" // RSS feeds and canonical URLs let feedLink title url = @@ -126,16 +126,16 @@ type PageHeadTag () = $"""{s}""" if webLog.Rss.IsFeedEnabled && getBool "is_home" then - result.WriteLine (feedLink webLog.Name webLog.Rss.FeedName) - result.WriteLine $"""{s}""" + result.WriteLine(feedLink webLog.Name webLog.Rss.FeedName) + result.WriteLine $"""{s}""" if webLog.Rss.IsCategoryEnabled && getBool "is_category_home" then let slug = context.Environments[0].["slug"] :?> string - result.WriteLine (feedLink webLog.Name $"category/{slug}/{webLog.Rss.FeedName}") + result.WriteLine(feedLink webLog.Name $"category/{slug}/{webLog.Rss.FeedName}") if webLog.Rss.IsTagEnabled && getBool "is_tag_home" then let slug = context.Environments[0].["slug"] :?> string - result.WriteLine (feedLink webLog.Name $"tag/{slug}/{webLog.Rss.FeedName}") + result.WriteLine(feedLink webLog.Name $"tag/{slug}/{webLog.Rss.FeedName}") if getBool "is_post" then let post = context.Environments[0].["model"] :?> PostDisplay diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index de59270..0e9af33 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -233,7 +233,7 @@ module RedirectRules = if idx = -1 then return! hashForPage "Add Redirect Rule" - |> addToHash "model" (EditRedirectRuleModel.fromRule -1 RedirectRule.empty) + |> addToHash "model" (EditRedirectRuleModel.fromRule -1 RedirectRule.Empty) |> withAntiCsrf ctx |> adminBareView "redirect-edit" next ctx else @@ -260,7 +260,7 @@ module RedirectRules = let! model = ctx.BindFormAsync () let isNew = idx = -1 let rules = ctx.WebLog.RedirectRules - let rule = model.UpdateRule (if isNew then RedirectRule.empty else List.item idx rules) + let rule = model.UpdateRule (if isNew then RedirectRule.Empty else List.item idx rules) let newRules = match isNew with | true when model.InsertAtTop -> List.insertAt 0 rule rules @@ -545,7 +545,7 @@ module WebLog = match! TemplateCache.get adminTheme "tag-mapping-list-body" ctx.Data with | Ok tagMapTemplate -> let! allPages = data.Page.All ctx.WebLog.Id - let! themes = data.Theme.All () + let! themes = data.Theme.All() let! users = data.WebLogUser.FindByWebLog ctx.WebLog.Id let! hash = hashForPage "Web Log Settings" @@ -553,10 +553,10 @@ module WebLog = |> addToHash ViewContext.Model (SettingsModel.fromWebLog ctx.WebLog) |> addToHash "pages" ( seq { - KeyValuePair.Create ("posts", "- First Page of Posts -") + 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)) + |> List.sortBy _.Title.ToLower() + |> List.map (fun p -> KeyValuePair.Create(p.Id.Value, p.Title)) } |> Array.ofSeq) |> addToHash "themes" ( diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 2db2de4..1d8dcda 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -37,13 +37,12 @@ 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 it.Path.Value) 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 @@ -142,7 +141,7 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po | link when Option.isSome podcast.MediaBaseUrl -> $"{podcast.MediaBaseUrl.Value}{link}" | link -> WebLog.absoluteUrl webLog (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 epImageUrl = defaultArg episode.ImageUrl podcast.ImageUrl.Value |> toAbsolute webLog let epExplicit = (defaultArg episode.Explicit podcast.Explicit).Value let xmlDoc = XmlDocument() @@ -310,8 +309,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, med.Value)) /// Get the feed's self reference and non-feed link let private selfAndLink webLog feedType ctx = @@ -370,7 +368,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.Value}] \"{stripHtml post.Title}\" has no media" item | _ -> item @@ -437,14 +435,14 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next |> withAntiCsrf ctx |> addToHash ViewContext.Model (EditCustomFeedModel.fromFeed f) |> addToHash "medium_values" [| - KeyValuePair.Create ("", "– Unspecified –") - 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") + KeyValuePair.Create("", "– Unspecified –") + KeyValuePair.Create(Podcast.Value, "Podcast") + KeyValuePair.Create(Music.Value, "Music") + KeyValuePair.Create(Video.Value, "Video") + KeyValuePair.Create(Film.Value, "Film") + KeyValuePair.Create(Audiobook.Value, "Audiobook") + KeyValuePair.Create(Newsletter.Value, "Newsletter") + KeyValuePair.Create(Blog.Value, "Blog") |] |> adminView "custom-feed-edit" next ctx | None -> Error.notFound next ctx diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index cfdebbd..1eece85 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -133,7 +133,7 @@ let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun return! {| content = [ """
""" - (MarkupText.toHtml >> addBaseToRelativeUrls extra) rev.Text + rev.Text.AsHtml() |> addBaseToRelativeUrls extra "
" ] |> String.concat "" @@ -174,13 +174,13 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun // POST /admin/page/save let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let data = ctx.Data let now = Noda.now () let tryPage = if model.IsNew then { Page.empty with - Id = PageId.create () + Id = PageId.Create() WebLogId = ctx.WebLog.Id AuthorId = ctx.UserId PublishedOn = now @@ -193,7 +193,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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 + return! redirectToGet $"admin/page/{page.Id.Value}/edit" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 0f5ea97..d9e87cd 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -39,7 +39,7 @@ open MyWebLog.Data open MyWebLog.ViewModels /// Convert a list of posts into items ready to be displayed -let preparePostList webLog posts listType (url : string) pageNbr perPage (data : IData) = task { +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) @@ -58,7 +58,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data : | _ -> Task.FromResult (None, None) let newerLink = match listType, pageNbr with - | SinglePost, _ -> newerPost |> Option.map (fun p -> Permalink.toString p.Permalink) + | SinglePost, _ -> newerPost |> Option.map _.Permalink.Value | _, 1 -> None | PostList, 2 when webLog.DefaultPage = "posts" -> Some "" | PostList, _ -> relUrl $"page/{pageNbr - 1}" @@ -70,7 +70,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 _.Permalink.Value | _, false -> None | PostList, true -> relUrl $"page/{pageNbr + 1}" | CategoryList, true -> relUrl $"category/{url}/page/{pageNbr + 1}" @@ -81,9 +81,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 {||} @@ -333,7 +333,7 @@ let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f return! {| content = [ """
""" - (MarkupText.toHtml >> addBaseToRelativeUrls extra) rev.Text + rev.Text.AsHtml() |> addBaseToRelativeUrls extra "
" ] |> String.concat "" @@ -374,12 +374,12 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu // POST /admin/post/save let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let data = ctx.Data let tryPost = if model.IsNew then { Post.empty with - Id = PostId.create () + Id = PostId.Create() WebLogId = ctx.WebLog.Id AuthorId = ctx.UserId } |> someTask @@ -410,7 +410,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> 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 + return! redirectToGet $"admin/post/{post.Id.Value}/edit" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 5c6d371..c128864 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -11,20 +11,20 @@ module CatchAll = open MyWebLog.ViewModels /// Sequence where the first returned value is the proper handler for the link - let private deriveAction (ctx : HttpContext) : HttpHandler seq = + let private deriveAction (ctx: HttpContext): HttpHandler seq = let webLog = ctx.WebLog let data = ctx.Data let debug = debug "Routes.CatchAll" ctx let textLink = let _, extra = WebLog.hostAndPath webLog let url = string ctx.Request.Path - (if extra = "" then url else url.Substring extra.Length).ToLowerInvariant () + (if extra = "" then url else url.Substring 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 webLog Permalink.Empty) + let permalink = Permalink textLink[1..] // Current post match data.Post.FindByPermalink permalink webLog.Id |> await with | Some post -> @@ -80,7 +80,7 @@ module CatchAll = } // GET {all-of-the-above} - let route : HttpHandler = fun next ctx -> + let route: HttpHandler = fun next ctx -> match deriveAction ctx |> Seq.tryHead with Some handler -> handler next ctx | None -> Error.notFound next ctx diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index ee7d934..8d0f68f 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -23,12 +23,12 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { // Create the web log let webLogId = WebLogId.create () let userId = WebLogUserId.create () - let homePageId = PageId.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! webLogs = data.WebLog.All() let accessLevel = if List.isEmpty webLogs then Administrator else WebLogAdmin do! data.WebLog.Add @@ -37,7 +37,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { Name = args[2] Slug = slug UrlBase = args[1] - DefaultPage = PageId.toString homePageId + DefaultPage = homePageId.Value TimeZone = timeZone } @@ -110,8 +110,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.Value} -> {current.Value}" + | None -> eprintfn $"Cannot find current post for {current.Value}" printfn "Done!" | None -> eprintfn $"No web log found at {urlBase}" } @@ -336,8 +336,8 @@ module Backup = 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 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 -- 2.45.1 From d8ce59a6cd12356b60f1df8e49c76bd7a182cc6c Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Dec 2023 12:24:45 -0500 Subject: [PATCH 016/123] WIP on module/member conversion Support types done --- src/MyWebLog.Data/Converters.fs | 100 +++--- .../Postgres/PostgresCategoryData.fs | 16 +- src/MyWebLog.Data/Postgres/PostgresHelpers.fs | 4 +- .../Postgres/PostgresPageData.fs | 25 +- .../Postgres/PostgresPostData.fs | 40 +-- .../Postgres/PostgresTagMapData.fs | 10 +- .../Postgres/PostgresThemeData.fs | 26 +- .../Postgres/PostgresUploadData.fs | 8 +- .../Postgres/PostgresWebLogData.fs | 17 +- .../Postgres/PostgresWebLogUserData.fs | 25 +- src/MyWebLog.Data/RethinkDbData.fs | 12 +- src/MyWebLog.Data/SQLite/Helpers.fs | 8 +- .../SQLite/SQLiteCategoryData.fs | 30 +- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 28 +- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 54 +-- src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs | 14 +- src/MyWebLog.Data/SQLite/SQLiteThemeData.fs | 33 +- src/MyWebLog.Data/SQLite/SQLiteUploadData.fs | 16 +- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 30 +- .../SQLite/SQLiteWebLogUserData.fs | 31 +- src/MyWebLog.Data/SQLiteData.fs | 4 +- src/MyWebLog.Data/Utils.fs | 12 +- src/MyWebLog.Domain/DataTypes.fs | 30 +- src/MyWebLog.Domain/SupportTypes.fs | 326 +++++++++--------- src/MyWebLog.Domain/ViewModels.fs | 294 ++++++++-------- src/MyWebLog/Caches.fs | 18 +- src/MyWebLog/DotLiquidBespoke.fs | 6 +- src/MyWebLog/Handlers/Admin.fs | 42 +-- src/MyWebLog/Handlers/Feed.fs | 65 ++-- src/MyWebLog/Handlers/Helpers.fs | 4 +- src/MyWebLog/Handlers/Page.fs | 2 +- src/MyWebLog/Handlers/Post.fs | 12 +- src/MyWebLog/Handlers/Routes.fs | 6 +- src/MyWebLog/Handlers/Upload.fs | 20 +- src/MyWebLog/Handlers/User.fs | 28 +- src/MyWebLog/Maintenance.fs | 28 +- src/MyWebLog/Program.fs | 2 +- 37 files changed, 705 insertions(+), 721 deletions(-) diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index d68025d..b4e07a1 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -12,120 +12,120 @@ module Json = type CategoryIdConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: CategoryId, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: CategoryId, _: bool, _: JsonSerializer) = (string >> CategoryId) reader.Value type CommentIdConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: CommentId, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: CommentId, _: bool, _: JsonSerializer) = (string >> CommentId) reader.Value type CommentStatusConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: CommentStatus, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: CommentStatus, _: bool, _: JsonSerializer) = (string >> CommentStatus.Parse) reader.Value - type CustomFeedIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CustomFeedId, _ : JsonSerializer) = - writer.WriteValue (CustomFeedId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedId, _ : bool, _ : JsonSerializer) = + type CustomFeedIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: CustomFeedId, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedId, _: bool, _: JsonSerializer) = (string >> CustomFeedId) reader.Value - type CustomFeedSourceConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CustomFeedSource, _ : JsonSerializer) = - writer.WriteValue (CustomFeedSource.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedSource, _ : bool, _ : JsonSerializer) = - (string >> CustomFeedSource.parse) reader.Value + type CustomFeedSourceConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: CustomFeedSource, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedSource, _: bool, _: JsonSerializer) = + (string >> CustomFeedSource.Parse) reader.Value type ExplicitRatingConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: ExplicitRating, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: ExplicitRating, _: bool, _: JsonSerializer) = (string >> ExplicitRating.Parse) reader.Value type MarkupTextConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: MarkupText, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: MarkupText, _: bool, _: JsonSerializer) = (string >> MarkupText.Parse) reader.Value type PermalinkConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: Permalink, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: Permalink, _: bool, _: JsonSerializer) = (string >> Permalink) reader.Value type PageIdConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: PageId, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: PageId, _: bool, _: JsonSerializer) = (string >> PageId) reader.Value type PodcastMediumConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: PodcastMedium, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: PodcastMedium, _: bool, _: JsonSerializer) = (string >> PodcastMedium.Parse) reader.Value type PostIdConverter() = inherit JsonConverter() override _.WriteJson(writer: JsonWriter, value: PostId, _: JsonSerializer) = - writer.WriteValue value.Value + writer.WriteValue(string value) override _.ReadJson(reader: JsonReader, _: Type, _: PostId, _: bool, _: JsonSerializer) = (string >> PostId) reader.Value - type TagMapIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : TagMapId, _ : JsonSerializer) = - writer.WriteValue (TagMapId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : TagMapId, _ : bool, _ : JsonSerializer) = + type TagMapIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: TagMapId, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: TagMapId, _: bool, _: JsonSerializer) = (string >> TagMapId) reader.Value - type ThemeAssetIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : ThemeAssetId, _ : JsonSerializer) = - writer.WriteValue (ThemeAssetId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeAssetId, _ : bool, _ : JsonSerializer) = - (string >> ThemeAssetId.ofString) reader.Value + type ThemeAssetIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: ThemeAssetId, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: ThemeAssetId, _: bool, _: JsonSerializer) = + (string >> ThemeAssetId.Parse) reader.Value - type ThemeIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : ThemeId, _ : JsonSerializer) = - writer.WriteValue (ThemeId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeId, _ : bool, _ : JsonSerializer) = + type ThemeIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: ThemeId, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: ThemeId, _: bool, _: JsonSerializer) = (string >> ThemeId) reader.Value - type UploadIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : UploadId, _ : JsonSerializer) = - writer.WriteValue (UploadId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : UploadId, _ : bool, _ : JsonSerializer) = + type UploadIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: UploadId, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: UploadId, _: bool, _: JsonSerializer) = (string >> UploadId) reader.Value - type WebLogIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : WebLogId, _ : JsonSerializer) = - writer.WriteValue (WebLogId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogId, _ : bool, _ : JsonSerializer) = + type WebLogIdConverter() = + inherit JsonConverter() + override _.WriteJson(writer: JsonWriter, value: WebLogId, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: WebLogId, _: bool, _: JsonSerializer) = (string >> WebLogId) reader.Value - type WebLogUserIdConverter () = + type WebLogUserIdConverter() = inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : WebLogUserId, _ : JsonSerializer) = - writer.WriteValue (WebLogUserId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogUserId, _ : bool, _ : JsonSerializer) = + override _.WriteJson(writer: JsonWriter, value: WebLogUserId, _: JsonSerializer) = + writer.WriteValue(string value) + override _.ReadJson(reader: JsonReader, _: Type, _: WebLogUserId, _: bool, _: JsonSerializer) = (string >> WebLogUserId) reader.Value open Microsoft.FSharpLu.Json diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index 08d041c..b78be64 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -43,7 +43,7 @@ type PostgresCategoryData(log: ILogger) = FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"} AND {catIdSql}""" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} catIdParams ] Map.toCount |> Async.AwaitTask @@ -64,7 +64,7 @@ type PostgresCategoryData(log: ILogger) = /// Find a category by its ID for the given web log let findById catId webLogId = log.LogTrace "Category.findById" - Document.findByIdAndWebLog Table.Category catId (_.Value) webLogId + Document.findByIdAndWebLog Table.Category catId string webLogId /// Find all categories for the given web log let findByWebLog webLogId = @@ -73,7 +73,7 @@ type PostgresCategoryData(log: ILogger) = /// Create parameters for a category insert / update let catParameters (cat : Category) = - Query.docParameters cat.Id.Value cat + Query.docParameters (string cat.Id) cat /// Delete a category let delete catId webLogId = backgroundTask { @@ -81,7 +81,7 @@ type PostgresCategoryData(log: ILogger) = match! findById catId webLogId with | Some cat -> // Reassign any children to the category's parent category - let! children = Find.byContains Table.Category {| ParentId = catId.Value |} + let! children = Find.byContains Table.Category {| ParentId = string catId |} let hasChildren = not (List.isEmpty children) if hasChildren then let! _ = @@ -90,7 +90,7 @@ type PostgresCategoryData(log: ILogger) = |> Sql.executeTransactionAsync [ Query.Update.partialById Table.Category, children |> List.map (fun child -> [ - "@id", Sql.string child.Id.Value + "@id", Sql.string (string child.Id) "@data", Query.jsonbDocParam {| ParentId = cat.ParentId |} ]) ] @@ -98,7 +98,7 @@ type PostgresCategoryData(log: ILogger) = // Delete the category off all posts where it is assigned let! posts = Custom.list $"SELECT data FROM {Table.Post} WHERE data -> '{nameof Post.empty.CategoryIds}' @> @id" - [ "@id", Query.jsonbDocParam [| catId.Value |] ] fromData + [ "@id", Query.jsonbDocParam [| string catId |] ] fromData if not (List.isEmpty posts) then let! _ = Configuration.dataSource () @@ -106,14 +106,14 @@ type PostgresCategoryData(log: ILogger) = |> Sql.executeTransactionAsync [ Query.Update.partialById Table.Post, posts |> List.map (fun post -> [ - "@id", Sql.string post.Id.Value + "@id", Sql.string (string post.Id) "@data", Query.jsonbDocParam {| CategoryIds = post.CategoryIds |> List.filter (fun cat -> cat <> catId) |} ]) ] () // Delete the category itself - do! Delete.byId Table.Category catId.Value + do! Delete.byId Table.Category (string catId) return if hasChildren then ReassignedChildCategories else CategoryDeleted | None -> return CategoryNotFound } diff --git a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs index b51b1e6..ae73f49 100644 --- a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs +++ b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs @@ -70,7 +70,7 @@ open Npgsql.FSharp /// Create a SQL parameter for the web log ID let webLogIdParam webLogId = - "@webLogId", Sql.string (WebLogId.toString webLogId) + "@webLogId", Sql.string (string webLogId) /// Create an anonymous record with the given web log ID let webLogDoc (webLogId : WebLogId) = @@ -206,7 +206,7 @@ module Revisions = let revParams<'TKey> (key : 'TKey) (keyFunc : 'TKey -> string) rev = [ typedParam "asOf" rev.AsOf "@id", Sql.string (keyFunc key) - "@text", Sql.string rev.Text.Value + "@text", Sql.string (string rev.Text) ] /// The SQL statement to insert a revision diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 8be3d1b..7bf8c80 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -14,7 +14,7 @@ type PostgresPageData (log: ILogger) = /// Append revisions to a page let appendPageRevisions (page: Page) = backgroundTask { log.LogTrace "Page.appendPageRevisions" - let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id _.Value + let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id string return { page with Revisions = revisions } } @@ -25,12 +25,12 @@ type PostgresPageData (log: ILogger) = /// Update a page's revisions let updatePageRevisions (pageId: PageId) oldRevs newRevs = log.LogTrace "Page.updatePageRevisions" - Revisions.update Table.PageRevision Table.Page pageId (_.Value) oldRevs newRevs + Revisions.update Table.PageRevision Table.Page pageId string oldRevs newRevs /// Does the given page exist? let pageExists (pageId: PageId) webLogId = log.LogTrace "Page.pageExists" - Document.existsByWebLog Table.Page pageId (_.Value) webLogId + Document.existsByWebLog Table.Page pageId string webLogId // IMPLEMENTATION FUNCTIONS @@ -51,9 +51,9 @@ type PostgresPageData (log: ILogger) = Count.byContains Table.Page {| webLogDoc webLogId with IsInPageList = true |} /// Find a page by its ID (without revisions) - let findById (pageId: PageId) webLogId = + let findById pageId webLogId = log.LogTrace "Page.findById" - Document.findByIdAndWebLog Table.Page pageId (_.Value) webLogId + Document.findByIdAndWebLog Table.Page pageId string webLogId /// Find a complete page by its ID let findFullById pageId webLogId = backgroundTask { @@ -70,7 +70,7 @@ type PostgresPageData (log: ILogger) = log.LogTrace "Page.delete" match! pageExists pageId webLogId with | true -> - do! Delete.byId Table.Page pageId.Value + do! Delete.byId Table.Page (string pageId) return true | false -> return false } @@ -78,16 +78,15 @@ type PostgresPageData (log: ILogger) = /// Find a page by its permalink for the given web log let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Page.findByPermalink" - Find.byContains Table.Page {| webLogDoc webLogId with Permalink = permalink.Value |} + Find.byContains Table.Page {| webLogDoc webLogId with Permalink = string permalink |} |> tryHead /// Find the current permalink within a set of potential prior permalinks for the given web log - let findCurrentPermalink permalinks webLogId = backgroundTask { + 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) (fun (it: Permalink) -> it.Value) permalinks + let linkSql, linkParam = arrayContains (nameof Page.empty.PriorPermalinks) string permalinks return! Custom.single $"""SELECT data ->> '{nameof Page.empty.Permalink}' AS permalink @@ -134,9 +133,9 @@ type PostgresPageData (log: ILogger) = |> Sql.executeTransactionAsync [ Query.insert Table.Page, pages - |> List.map (fun page -> Query.docParameters page.Id.Value { page with Revisions = [] }) + |> List.map (fun page -> Query.docParameters (string page.Id) { page with Revisions = [] }) Revisions.insertSql Table.PageRevision, - revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId (_.Value) rev) + revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId string rev) ] () } @@ -155,7 +154,7 @@ type PostgresPageData (log: ILogger) = log.LogTrace "Page.updatePriorPermalinks" match! pageExists pageId webLogId with | true -> - do! Update.partialById Table.Page pageId.Value {| PriorPermalinks = permalinks |} + do! Update.partialById Table.Page (string pageId) {| PriorPermalinks = permalinks |} return true | false -> return false } diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index c1f6248..7984d35 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -15,7 +15,7 @@ type PostgresPostData(log: ILogger) = /// Append revisions to a post let appendPostRevisions (post: Post) = backgroundTask { log.LogTrace "Post.appendPostRevisions" - let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id _.Value + let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id string return { post with Revisions = revisions } } @@ -26,30 +26,30 @@ type PostgresPostData(log: ILogger) = /// Update a post's revisions let updatePostRevisions (postId: PostId) oldRevs newRevs = log.LogTrace "Post.updatePostRevisions" - Revisions.update Table.PostRevision Table.Post postId (_.Value) oldRevs newRevs + Revisions.update Table.PostRevision Table.Post postId string oldRevs newRevs /// Does the given post exist? let postExists (postId: PostId) webLogId = log.LogTrace "Post.postExists" - Document.existsByWebLog Table.Post postId (_.Value) webLogId + Document.existsByWebLog Table.Post postId string webLogId // IMPLEMENTATION FUNCTIONS /// 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.Value |} + 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 = log.LogTrace "Post.findById" - Document.findByIdAndWebLog Table.Post postId (_.Value) webLogId + Document.findByIdAndWebLog Table.Post postId string webLogId /// Find a post by its permalink for the given web log (excluding revisions and prior permalinks) let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Post.findByPermalink" Custom.single (selectWithCriteria Table.Post) - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Permalink = permalink.Value |} ] + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Permalink = string permalink |} ] fromData /// Find a complete post by its ID for the given web log @@ -70,18 +70,17 @@ type PostgresPostData(log: ILogger) = do! Custom.nonQuery $"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"}; DELETE FROM {Table.Post} WHERE id = @id""" - [ "@id", Sql.string postId.Value; "@criteria", Query.jsonbDocParam {| PostId = postId.Value |} ] + [ "@id", Sql.string (string postId); "@criteria", Query.jsonbDocParam {| 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 webLogId = backgroundTask { + 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) (fun (it: Permalink) -> it.Value) permalinks + let linkSql, linkParam = arrayContains (nameof Post.empty.PriorPermalinks) string permalinks return! Custom.single $"""SELECT data ->> '{nameof Post.empty.Permalink}' AS permalink @@ -102,16 +101,15 @@ type PostgresPostData(log: ILogger) = } /// Get a page of categorized posts for the given web log (excludes revisions) - let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = + let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = log.LogTrace "Post.findPageOfCategorizedPosts" - let catSql, catParam = - arrayContains (nameof Post.empty.CategoryIds) (fun (it: CategoryId) -> it.Value) categoryIds + 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}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} catParam ] fromData @@ -132,7 +130,7 @@ type PostgresPostData(log: ILogger) = $"{selectWithCriteria Table.Post} ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} ] + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} ] fromData /// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks) @@ -143,7 +141,7 @@ type PostgresPostData(log: ILogger) = AND data['{nameof Post.empty.Tags}'] @> @tag ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} "@tag", Query.jsonbDocParam [| tag |] ] fromData @@ -151,8 +149,8 @@ type PostgresPostData(log: ILogger) = let findSurroundingPosts webLogId publishedOn = backgroundTask { log.LogTrace "Post.findSurroundingPosts" let queryParams () = [ - "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published.Value |} - "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn).Substring (0, 19)) + "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} + "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn)[..19]) ] let pubField = nameof Post.empty.PublishedOn let! older = @@ -187,9 +185,9 @@ type PostgresPostData(log: ILogger) = |> Sql.fromDataSource |> Sql.executeTransactionAsync [ Query.insert Table.Post, - posts |> List.map (fun post -> Query.docParameters post.Id.Value { post with Revisions = [] }) + posts |> List.map (fun post -> Query.docParameters (string post.Id) { post with Revisions = [] }) Revisions.insertSql Table.PostRevision, - revisions |> List.map (fun (postId, rev) -> Revisions.revParams postId (_.Value) rev) + revisions |> List.map (fun (postId, rev) -> Revisions.revParams postId string rev) ] () } @@ -199,7 +197,7 @@ type PostgresPostData(log: ILogger) = log.LogTrace "Post.updatePriorPermalinks" match! postExists postId webLogId with | true -> - do! Update.partialById Table.Post postId.Value {| PriorPermalinks = permalinks |} + do! Update.partialById Table.Post (string postId) {| PriorPermalinks = permalinks |} return true | false -> return false } diff --git a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs index 210dc14..100523a 100644 --- a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -12,14 +12,14 @@ 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 Table.TagMap tagMapId TagMapId.toString webLogId + Document.findByIdAndWebLog Table.TagMap tagMapId string webLogId /// Delete a tag mapping for the given web log - let delete tagMapId webLogId = backgroundTask { + let delete (tagMapId: TagMapId) webLogId = backgroundTask { log.LogTrace "TagMap.delete" - let! exists = Document.existsByWebLog Table.TagMap tagMapId TagMapId.toString webLogId + let! exists = Document.existsByWebLog Table.TagMap tagMapId string webLogId if exists then - do! Delete.byId Table.TagMap (TagMapId.toString tagMapId) + do! Delete.byId Table.TagMap (string tagMapId) return true else return false } @@ -55,7 +55,7 @@ type PostgresTagMapData (log : ILogger) = |> Sql.fromDataSource |> Sql.executeTransactionAsync [ Query.insert Table.TagMap, - tagMaps |> List.map (fun tagMap -> Query.docParameters (TagMapId.toString tagMap.Id) tagMap) + tagMaps |> List.map (fun tagMap -> Query.docParameters (string tagMap.Id) tagMap) ] () } diff --git a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs index cf3a569..ed7e4bb 100644 --- a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs @@ -20,26 +20,26 @@ type PostgresThemeData (log : ILogger) = Custom.list $"{Query.selectFromTable Table.Theme} WHERE id <> 'admin' ORDER BY id" [] withoutTemplateText /// Does a given theme exist? - let exists themeId = + let exists (themeId: ThemeId) = log.LogTrace "Theme.exists" - Exists.byId Table.Theme (ThemeId.toString themeId) + Exists.byId Table.Theme (string themeId) /// Find a theme by its ID - let findById themeId = + let findById (themeId: ThemeId) = log.LogTrace "Theme.findById" - Find.byId Table.Theme (ThemeId.toString themeId) + Find.byId Table.Theme (string themeId) /// Find a theme by its ID (excludes the text of templates) - let findByIdWithoutText themeId = + let findByIdWithoutText (themeId: ThemeId) = log.LogTrace "Theme.findByIdWithoutText" - Custom.single (Query.Find.byId Table.Theme) [ "@id", Sql.string (ThemeId.toString themeId) ] withoutTemplateText + Custom.single (Query.Find.byId Table.Theme) [ "@id", Sql.string (string themeId) ] withoutTemplateText /// Delete a theme by its ID let delete themeId = backgroundTask { log.LogTrace "Theme.delete" match! exists themeId with | true -> - do! Delete.byId Table.Theme (ThemeId.toString themeId) + do! Delete.byId Table.Theme (string themeId) return true | false -> return false } @@ -67,10 +67,10 @@ type PostgresThemeAssetData (log : ILogger) = Custom.list $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset}" [] (Map.toThemeAsset false) /// Delete all assets for the given theme - let deleteByTheme themeId = + let deleteByTheme (themeId: ThemeId) = log.LogTrace "ThemeAsset.deleteByTheme" Custom.nonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @themeId" - [ "@themeId", Sql.string (ThemeId.toString themeId) ] + [ "@themeId", Sql.string (string themeId) ] /// Find a theme asset by its ID let findById assetId = @@ -80,16 +80,16 @@ type PostgresThemeAssetData (log : ILogger) = [ "@themeId", Sql.string themeId; "@path", Sql.string path ] (Map.toThemeAsset true) /// Get theme assets for the given theme (excludes data) - let findByTheme themeId = + let findByTheme (themeId: ThemeId) = log.LogTrace "ThemeAsset.findByTheme" Custom.list $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @themeId" - [ "@themeId", Sql.string (ThemeId.toString themeId) ] (Map.toThemeAsset false) + [ "@themeId", Sql.string (string themeId) ] (Map.toThemeAsset false) /// Get theme assets for the given theme - let findByThemeWithData themeId = + let findByThemeWithData (themeId: ThemeId) = log.LogTrace "ThemeAsset.findByThemeWithData" Custom.list $"SELECT * FROM {Table.ThemeAsset} WHERE theme_id = @themeId" - [ "@themeId", Sql.string (ThemeId.toString themeId) ] (Map.toThemeAsset true) + [ "@themeId", Sql.string (string themeId) ] (Map.toThemeAsset true) /// Save a theme asset let save (asset : ThemeAsset) = diff --git a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs index 136da11..e97b212 100644 --- a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs @@ -21,8 +21,8 @@ type PostgresUploadData (log : ILogger) = let upParams (upload : Upload) = [ webLogIdParam upload.WebLogId typedParam "updatedOn" upload.UpdatedOn - "@id", Sql.string (UploadId.toString upload.Id) - "@path", Sql.string upload.Path.Value + "@id", Sql.string (string upload.Id) + "@path", Sql.string (string upload.Path) "@data", Sql.bytea upload.Data ] @@ -34,14 +34,14 @@ type PostgresUploadData (log : ILogger) = /// Delete an uploaded file by its ID let delete uploadId webLogId = backgroundTask { log.LogTrace "Upload.delete" - let idParam = [ "@id", Sql.string (UploadId.toString uploadId) ] + let idParam = [ "@id", Sql.string (string 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 (Query.Delete.byId Table.Upload) idParam return Ok path.Value - else return Error $"""Upload ID {UploadId.toString uploadId} not found""" + else return Error $"""Upload ID {uploadId} not found""" } /// Find an uploaded file by its path for the given web log diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index f583cc2..0efc85d 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -41,29 +41,30 @@ type PostgresWebLogData (log : ILogger) = fromData /// Find a web log by its ID - let findById webLogId = + let findById (webLogId: WebLogId) = log.LogTrace "WebLog.findById" - Find.byId Table.WebLog (WebLogId.toString webLogId) + Find.byId Table.WebLog (string webLogId) - let updateRedirectRules (webLog : WebLog) = backgroundTask { + let updateRedirectRules (webLog: WebLog) = backgroundTask { log.LogTrace "WebLog.updateRedirectRules" match! findById webLog.Id with | Some _ -> - do! Update.partialById Table.WebLog (WebLogId.toString webLog.Id) {| RedirectRules = webLog.RedirectRules |} + do! Update.partialById Table.WebLog (string webLog.Id) {| RedirectRules = webLog.RedirectRules |} | None -> () } + /// Update RSS options for a web log - let updateRssOptions (webLog : WebLog) = backgroundTask { + let updateRssOptions (webLog: WebLog) = backgroundTask { log.LogTrace "WebLog.updateRssOptions" match! findById webLog.Id with - | Some _ -> do! Update.partialById Table.WebLog (WebLogId.toString webLog.Id) {| Rss = webLog.Rss |} + | Some _ -> do! Update.partialById Table.WebLog (string webLog.Id) {| Rss = webLog.Rss |} | None -> () } /// Update settings for a web log - let updateSettings (webLog : WebLog) = + let updateSettings (webLog: WebLog) = log.LogTrace "WebLog.updateSettings" - Update.full Table.WebLog (WebLogId.toString webLog.Id) webLog + Update.full Table.WebLog (string webLog.Id) webLog interface IWebLogData with member _.Add webLog = add webLog diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs index 32b912e..dba0985 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -12,7 +12,7 @@ type PostgresWebLogUserData (log : ILogger) = /// Find a user by their ID for the given web log let findById userId webLogId = log.LogTrace "WebLogUser.findById" - Document.findByIdAndWebLog Table.WebLogUser userId WebLogUserId.toString webLogId + Document.findByIdAndWebLog Table.WebLogUser userId string webLogId /// Delete a user if they have no posts or pages let delete userId webLogId = backgroundTask { @@ -29,7 +29,7 @@ type PostgresWebLogUserData (log : ILogger) = if isAuthor then return Error "User has pages or posts; cannot delete" else - do! Delete.byId Table.WebLogUser (WebLogUserId.toString userId) + do! Delete.byId Table.WebLogUser (string userId) return Ok true | None -> return Error "User does not exist" } @@ -49,41 +49,38 @@ type PostgresWebLogUserData (log : ILogger) = [ webLogContains webLogId ] fromData /// Find the names of users by their IDs for the given web log - let findNames webLogId userIds = backgroundTask { + let findNames webLogId (userIds: WebLogUserId list) = backgroundTask { log.LogTrace "WebLogUser.findNames" - let idSql, idParams = inClause "AND id" "id" WebLogUserId.toString userIds + let idSql, idParams = inClause "AND id" "id" string userIds let! users = Custom.list $"{selectWithCriteria Table.WebLogUser} {idSql}" (webLogContains webLogId :: idParams) fromData - 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 = WebLogUser.displayName u }) } /// Restore users from a backup - let restore (users : WebLogUser list) = backgroundTask { + 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 -> Query.docParameters (WebLogUserId.toString user.Id) user) + users |> List.map (fun user -> Query.docParameters (string user.Id) user) ] () } /// Set a user's last seen date/time to now - let setLastSeen userId webLogId = backgroundTask { + let setLastSeen (userId: WebLogUserId) webLogId = backgroundTask { log.LogTrace "WebLogUser.setLastSeen" - match! Document.existsByWebLog Table.WebLogUser userId WebLogUserId.toString webLogId with - | true -> - do! Update.partialById Table.WebLogUser (WebLogUserId.toString userId) {| LastSeenOn = Some (Noda.now ()) |} + match! Document.existsByWebLog Table.WebLogUser userId string webLogId with + | true -> do! Update.partialById Table.WebLogUser (string userId) {| LastSeenOn = Some (Noda.now ()) |} | false -> () } /// Save a user - let save (user : WebLogUser) = + let save (user: WebLogUser) = log.LogTrace "WebLogUser.save" save Table.WebLogUser user diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index e653b1f..acda3a6 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -96,12 +96,12 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger 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].Without [| nameof ThemeTemplate.empty.Text |] |} + {| Templates = row[nameof Theme.empty.Templates].Without [| nameof ThemeTemplate.Empty.Text |] |} /// Ensure field indexes exist, as well as special indexes for selected tables let ensureIndexes table fields = backgroundTask { @@ -917,8 +917,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger 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 = @@ -1133,9 +1133,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger List.map (fun u -> { Name = WebLogUserId.toString u.Id; Value = WebLogUser.displayName u }) + return users |> List.map (fun u -> { Name = string u.Id; Value = WebLogUser.displayName u }) } member _.Restore users = backgroundTask { diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index cdd31a2..b37c7bc 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -222,7 +222,7 @@ module Map = /// Create a custom feed from the current row in the given data reader let toCustomFeed ser rdr : CustomFeed = { Id = getString "id" rdr |> CustomFeedId - Source = getString "source" rdr |> CustomFeedSource.parse + Source = getString "source" rdr |> CustomFeedSource.Parse Path = getString "path" rdr |> Permalink Podcast = tryString "podcast" rdr |> Option.map (Utils.deserialize ser) } @@ -339,7 +339,7 @@ module Map = UrlBase = getString "url_base" rdr TimeZone = getString "time_zone" rdr AutoHtmx = getBoolean "auto_htmx" rdr - Uploads = getString "uploads" rdr |> UploadDestination.parse + Uploads = getString "uploads" rdr |> UploadDestination.Parse Rss = { IsFeedEnabled = getBoolean "is_feed_enabled" rdr FeedName = getString "feed_name" rdr @@ -368,5 +368,5 @@ module Map = } /// Add a web log ID parameter -let addWebLogId (cmd : SqliteCommand) webLogId = - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore +let addWebLogId (cmd: SqliteCommand) (webLogId: WebLogId) = + cmd.Parameters.AddWithValue ("@webLogId", string webLogId) |> ignore diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 3caae20..d3d96b2 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -5,17 +5,17 @@ open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data -/// SQLite myWebLog category data implementation -type SQLiteCategoryData (conn : SqliteConnection) = +/// SQLite myWebLog category data implementation +type SQLiteCategoryData(conn: SqliteConnection) = /// Add parameters for category INSERT or UPDATE statements - let addCategoryParameters (cmd : SqliteCommand) (cat : Category) = - [ cmd.Parameters.AddWithValue ("@id", cat.Id.Value) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString cat.WebLogId) + let addCategoryParameters (cmd: SqliteCommand) (cat: Category) = + [ cmd.Parameters.AddWithValue ("@id", string cat.Id) + cmd.Parameters.AddWithValue ("@webLogId", string 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 _.Value)) + cmd.Parameters.AddWithValue ("@parentId", maybe (cat.ParentId |> Option.map string)) ] |> ignore /// Add a category @@ -102,18 +102,18 @@ type SQLiteCategoryData (conn : SqliteConnection) = } /// Find a category by its ID for the given web log let findById (catId: CategoryId) webLogId = backgroundTask { - use cmd = conn.CreateCommand () + use cmd = conn.CreateCommand() cmd.CommandText <- "SELECT * FROM category WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", catId.Value) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return Helpers.verifyWebLog webLogId (fun c -> c.WebLogId) Map.toCategory rdr + cmd.Parameters.AddWithValue ("@id", string catId) |> ignore + use! rdr = cmd.ExecuteReaderAsync() + return verifyWebLog webLogId (_.WebLogId) Map.toCategory rdr } /// Find all categories for the given web log - let findByWebLog webLogId = backgroundTask { + let findByWebLog (webLogId: WebLogId) = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT * FROM category WHERE web_log_id = @webLogId" - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore + cmd.Parameters.AddWithValue ("@webLogId", string webLogId) |> ignore use! rdr = cmd.ExecuteReaderAsync () return toList Map.toCategory rdr } @@ -125,11 +125,11 @@ type SQLiteCategoryData (conn : SqliteConnection) = use cmd = conn.CreateCommand () // Reassign any children to the category's parent category cmd.CommandText <- "SELECT COUNT(id) FROM category WHERE parent_id = @parentId" - cmd.Parameters.AddWithValue ("@parentId", catId.Value) |> ignore + cmd.Parameters.AddWithValue ("@parentId", string catId) |> ignore let! children = count cmd if children > 0 then cmd.CommandText <- "UPDATE category SET parent_id = @newParentId WHERE parent_id = @parentId" - cmd.Parameters.AddWithValue ("@newParentId", maybe (cat.ParentId |> Option.map _.Value)) + cmd.Parameters.AddWithValue ("@newParentId", maybe (cat.ParentId |> Option.map string)) |> ignore do! write cmd // Delete the category off all posts where it is assigned, and the category itself @@ -139,7 +139,7 @@ type SQLiteCategoryData (conn : SqliteConnection) = AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId); DELETE FROM category WHERE id = @id" cmd.Parameters.Clear () - let _ = cmd.Parameters.AddWithValue ("@id", catId.Value) + let _ = cmd.Parameters.AddWithValue ("@id", string catId) addWebLogId cmd webLogId do! write cmd return if children = 0 then CategoryDeleted else ReassignedChildCategories diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index c3ae850..c8ebd49 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -13,11 +13,11 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = /// Add parameters for page INSERT or UPDATE statements let addPageParameters (cmd: SqliteCommand) (page: Page) = - [ cmd.Parameters.AddWithValue ("@id", page.Id.Value) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString page.WebLogId) - cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString page.AuthorId) + [ cmd.Parameters.AddWithValue ("@id", string page.Id) + cmd.Parameters.AddWithValue ("@webLogId", string page.WebLogId) + cmd.Parameters.AddWithValue ("@authorId", string page.AuthorId) cmd.Parameters.AddWithValue ("@title", page.Title) - cmd.Parameters.AddWithValue ("@permalink", page.Permalink.Value) + cmd.Parameters.AddWithValue ("@permalink", string page.Permalink) cmd.Parameters.AddWithValue ("@publishedOn", instantParam page.PublishedOn) cmd.Parameters.AddWithValue ("@updatedOn", instantParam page.UpdatedOn) cmd.Parameters.AddWithValue ("@isInPageList", page.IsInPageList) @@ -30,7 +30,7 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = /// Append revisions and permalinks to a page let appendPageRevisionsAndPermalinks (page : Page) = backgroundTask { use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@pageId", page.Id.Value) |> ignore + cmd.Parameters.AddWithValue ("@pageId", string page.Id) |> ignore cmd.CommandText <- "SELECT permalink FROM page_permalink WHERE page_id = @pageId" use! rdr = cmd.ExecuteReaderAsync () @@ -57,11 +57,11 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@pageId", pageId.Value) + [ cmd.Parameters.AddWithValue ("@pageId", string pageId) cmd.Parameters.Add ("@link", SqliteType.Text) ] |> ignore let runCmd (link: Permalink) = backgroundTask { - cmd.Parameters["@link"].Value <- link.Value + cmd.Parameters["@link"].Value <- string link do! write cmd } cmd.CommandText <- "DELETE FROM page_permalink WHERE page_id = @pageId AND permalink = @link" @@ -85,10 +85,10 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = use cmd = conn.CreateCommand () let runCmd withText rev = backgroundTask { cmd.Parameters.Clear () - [ cmd.Parameters.AddWithValue ("@pageId", pageId.Value) + [ cmd.Parameters.AddWithValue ("@pageId", string pageId) cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) ] |> ignore - if withText then cmd.Parameters.AddWithValue ("@text", rev.Text.Value) |> ignore + if withText then cmd.Parameters.AddWithValue ("@text", string rev.Text) |> ignore do! write cmd } cmd.CommandText <- "DELETE FROM page_revision WHERE page_id = @pageId AND as_of = @asOf" @@ -157,7 +157,7 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = let findById (pageId: PageId) webLogId = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT * FROM page WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", pageId.Value) |> ignore + cmd.Parameters.AddWithValue ("@id", string pageId) |> ignore use! rdr = cmd.ExecuteReaderAsync () return verifyWebLog webLogId (_.WebLogId) (Map.toPage ser) rdr } @@ -175,7 +175,7 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = match! findById pageId webLogId with | Some _ -> use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@id", pageId.Value) |> ignore + cmd.Parameters.AddWithValue ("@id", string pageId) |> ignore cmd.CommandText <- "DELETE FROM page_revision WHERE page_id = @id; DELETE FROM page_permalink WHERE page_id = @id; @@ -190,15 +190,15 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = 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.Value) |> ignore + cmd.Parameters.AddWithValue ("@link", string permalink) |> ignore use! rdr = cmd.ExecuteReaderAsync () return if rdr.Read () then Some (toPage rdr) else None } /// Find the current permalink within a set of potential prior permalinks for the given web log - let findCurrentPermalink permalinks webLogId = backgroundTask { + let findCurrentPermalink (permalinks: Permalink list) webLogId = backgroundTask { use cmd = conn.CreateCommand () - let linkSql, linkParams = inClause "AND pp.permalink" "link" (fun (it: Permalink) -> it.Value) permalinks + let linkSql, linkParams = inClause "AND pp.permalink" "link" string permalinks cmd.CommandText <- $" SELECT p.permalink FROM page p diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index c12ecab..97c02b4 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -14,12 +14,12 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = /// Add parameters for post INSERT or UPDATE statements let addPostParameters (cmd: SqliteCommand) (post: Post) = - [ cmd.Parameters.AddWithValue ("@id", post.Id.Value) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString post.WebLogId) - cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString post.AuthorId) - cmd.Parameters.AddWithValue ("@status", post.Status.Value) + [ cmd.Parameters.AddWithValue ("@id", string post.Id) + cmd.Parameters.AddWithValue ("@webLogId", string post.WebLogId) + cmd.Parameters.AddWithValue ("@authorId", string post.AuthorId) + cmd.Parameters.AddWithValue ("@status", string post.Status) cmd.Parameters.AddWithValue ("@title", post.Title) - cmd.Parameters.AddWithValue ("@permalink", post.Permalink.Value) + cmd.Parameters.AddWithValue ("@permalink", string post.Permalink) cmd.Parameters.AddWithValue ("@publishedOn", maybeInstant post.PublishedOn) cmd.Parameters.AddWithValue ("@updatedOn", instantParam post.UpdatedOn) cmd.Parameters.AddWithValue ("@template", maybe post.Template) @@ -34,7 +34,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = /// Append category IDs and tags to a post let appendPostCategoryAndTag (post: Post) = backgroundTask { use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@id", post.Id.Value) |> ignore + cmd.Parameters.AddWithValue ("@id", string post.Id) |> ignore cmd.CommandText <- "SELECT category_id AS id FROM post_category WHERE post_id = @id" use! rdr = cmd.ExecuteReaderAsync () @@ -49,7 +49,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = /// Append revisions and permalinks to a post let appendPostRevisionsAndPermalinks (post: Post) = backgroundTask { use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@postId", post.Id.Value) |> ignore + cmd.Parameters.AddWithValue ("@postId", string post.Id) |> ignore cmd.CommandText <- "SELECT permalink FROM post_permalink WHERE post_id = @postId" use! rdr = cmd.ExecuteReaderAsync () @@ -72,7 +72,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = let findPostById (postId: PostId) webLogId = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- $"{selectPost} WHERE p.id = @id" - cmd.Parameters.AddWithValue ("@id", postId.Value) |> ignore + cmd.Parameters.AddWithValue ("@id", string postId) |> ignore use! rdr = cmd.ExecuteReaderAsync () return verifyWebLog webLogId (_.WebLogId) toPost rdr } @@ -83,16 +83,16 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = /// Update a post's assigned categories let updatePostCategories (postId: PostId) oldCats newCats = backgroundTask { - let toDelete, toAdd = Utils.diffLists oldCats newCats _.Value + let toDelete, toAdd = Utils.diffLists oldCats newCats string if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", postId.Value) + [ cmd.Parameters.AddWithValue ("@postId", string postId) cmd.Parameters.Add ("@categoryId", SqliteType.Text) ] |> ignore let runCmd (catId: CategoryId) = backgroundTask { - cmd.Parameters["@categoryId"].Value <- catId.Value + cmd.Parameters["@categoryId"].Value <- string catId do! write cmd } cmd.CommandText <- "DELETE FROM post_category WHERE post_id = @postId AND category_id = @categoryId" @@ -114,7 +114,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", postId.Value) + [ cmd.Parameters.AddWithValue ("@postId", string postId) cmd.Parameters.Add ("@tag", SqliteType.Text) ] |> ignore let runCmd (tag: string) = backgroundTask { @@ -140,11 +140,11 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", postId.Value) + [ cmd.Parameters.AddWithValue ("@postId", string postId) cmd.Parameters.Add ("@link", SqliteType.Text) ] |> ignore let runCmd (link: Permalink) = backgroundTask { - cmd.Parameters["@link"].Value <- link.Value + cmd.Parameters["@link"].Value <- string link do! write cmd } cmd.CommandText <- "DELETE FROM post_permalink WHERE post_id = @postId AND permalink = @link" @@ -168,10 +168,10 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = use cmd = conn.CreateCommand () let runCmd withText rev = backgroundTask { cmd.Parameters.Clear () - [ cmd.Parameters.AddWithValue ("@postId", postId.Value) + [ cmd.Parameters.AddWithValue ("@postId", string postId) cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) ] |> ignore - if withText then cmd.Parameters.AddWithValue ("@text", rev.Text.Value) |> ignore + if withText then cmd.Parameters.AddWithValue ("@text", string rev.Text) |> ignore do! write cmd } cmd.CommandText <- "DELETE FROM post_revision WHERE post_id = @postId AND as_of = @asOf" @@ -212,7 +212,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = 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", status.Value) |> ignore + cmd.Parameters.AddWithValue ("@status", string status) |> ignore return! count cmd } @@ -230,7 +230,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = 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.Value) |> ignore + cmd.Parameters.AddWithValue ("@link", string permalink) |> ignore use! rdr = cmd.ExecuteReaderAsync () if rdr.Read () then let! post = appendPostCategoryAndTag (toPost rdr) @@ -253,7 +253,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = match! findFullById postId webLogId with | Some _ -> use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@id", postId.Value) |> ignore + cmd.Parameters.AddWithValue ("@id", string postId) |> ignore cmd.CommandText <- "DELETE FROM post_revision WHERE post_id = @id; DELETE FROM post_permalink WHERE post_id = @id; @@ -267,9 +267,9 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = } /// Find the current permalink from a list of potential prior permalinks for the given web log - let findCurrentPermalink permalinks webLogId = backgroundTask { + let findCurrentPermalink (permalinks: Permalink list) webLogId = backgroundTask { use cmd = conn.CreateCommand () - let linkSql, linkParams = inClause "AND pp.permalink" "link" (fun (it: Permalink) -> it.Value) permalinks + let linkSql, linkParams = inClause "AND pp.permalink" "link" string permalinks cmd.CommandText <- $" SELECT p.permalink FROM post p @@ -299,9 +299,9 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = } /// Get a page of categorized posts for the given web log (excludes revisions and prior permalinks) - let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = backgroundTask { + let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = backgroundTask { use cmd = conn.CreateCommand () - let catSql, catParams = inClause "AND pc.category_id" "catId" (fun (it: CategoryId) -> it.Value) categoryIds + let catSql, catParams = inClause "AND pc.category_id" "catId" string categoryIds cmd.CommandText <- $" {selectPost} INNER JOIN post_category pc ON pc.post_id = p.id @@ -311,7 +311,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = ORDER BY published_on DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@status", Published.Value) |> ignore + cmd.Parameters.AddWithValue ("@status", string Published) |> ignore cmd.Parameters.AddRange catParams use! rdr = cmd.ExecuteReaderAsync () let! posts = @@ -348,7 +348,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = ORDER BY p.published_on DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@status", Published.Value) |> ignore + cmd.Parameters.AddWithValue ("@status", string Published) |> ignore use! rdr = cmd.ExecuteReaderAsync () let! posts = toList toPost rdr @@ -369,7 +369,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = ORDER BY p.published_on DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@status", Published.Value) + [ cmd.Parameters.AddWithValue ("@status", string Published) cmd.Parameters.AddWithValue ("@tag", tag) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () @@ -391,7 +391,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = ORDER BY p.published_on DESC LIMIT 1" addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@status", Published.Value) + [ cmd.Parameters.AddWithValue ("@status", string Published) cmd.Parameters.AddWithValue ("@publishedOn", instantParam publishedOn) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index 00de07b..d17d203 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -8,12 +8,12 @@ open MyWebLog.Data type SQLiteTagMapData (conn : SqliteConnection) = /// Find a tag mapping by its ID for the given web log - let findById tagMapId webLogId = backgroundTask { - use cmd = conn.CreateCommand () + let findById (tagMapId: 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 webLogId (fun tm -> tm.WebLogId) Map.toTagMap rdr + cmd.Parameters.AddWithValue ("@id", string tagMapId) |> ignore + use! rdr = cmd.ExecuteReaderAsync() + return verifyWebLog webLogId (_.WebLogId) Map.toTagMap rdr } /// Delete a tag mapping for the given web log @@ -22,7 +22,7 @@ type SQLiteTagMapData (conn : SqliteConnection) = | Some _ -> use cmd = conn.CreateCommand () cmd.CommandText <- "DELETE FROM tag_map WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMapId) |> ignore + cmd.Parameters.AddWithValue ("@id", string tagMapId) |> ignore do! write cmd return true | None -> return false @@ -81,7 +81,7 @@ type SQLiteTagMapData (conn : SqliteConnection) = @id, @webLogId, @tag, @urlValue )" addWebLogId cmd tagMap.WebLogId - [ cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMap.Id) + [ cmd.Parameters.AddWithValue ("@id", string tagMap.Id) cmd.Parameters.AddWithValue ("@tag", tagMap.Tag) cmd.Parameters.AddWithValue ("@urlValue", tagMap.UrlValue) ] |> ignore diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index dd3d81b..ff5403b 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -27,19 +27,19 @@ type SQLiteThemeData (conn : SqliteConnection) = } /// Does a given theme exist? - let exists themeId = backgroundTask { + let exists (themeId: ThemeId) = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT COUNT(id) FROM theme WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore + cmd.Parameters.AddWithValue ("@id", string themeId) |> ignore let! count = count cmd return count > 0 } /// Find a theme by its ID - let findById themeId = backgroundTask { + let findById (themeId: ThemeId) = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT * FROM theme WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore + cmd.Parameters.AddWithValue ("@id", string themeId) |> ignore use! rdr = cmd.ExecuteReaderAsync () if rdr.Read () then let theme = Map.toTheme rdr @@ -71,29 +71,28 @@ type SQLiteThemeData (conn : SqliteConnection) = "DELETE FROM theme_asset WHERE theme_id = @id; DELETE FROM theme_template WHERE theme_id = @id; DELETE FROM theme WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore + cmd.Parameters.AddWithValue ("@id", string themeId) |> ignore do! write cmd return true | None -> return false } /// Save a theme - let save (theme : Theme) = backgroundTask { - use cmd = conn.CreateCommand () + 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 ("@id", string theme.Id) cmd.Parameters.AddWithValue ("@name", theme.Name) cmd.Parameters.AddWithValue ("@version", theme.Version) ] |> ignore do! write cmd let toDelete, toAdd = - Utils.diffLists (oldTheme |> Option.map (fun t -> t.Templates) |> Option.defaultValue []) - theme.Templates (fun t -> t.Name) + Utils.diffLists (oldTheme |> Option.map _.Templates |> Option.defaultValue []) theme.Templates _.Name let toUpdate = theme.Templates |> List.filter (fun t -> @@ -102,7 +101,7 @@ type SQLiteThemeData (conn : SqliteConnection) = 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.AddWithValue ("@themeId", string theme.Id) cmd.Parameters.Add ("@name", SqliteType.Text) cmd.Parameters.Add ("@template", SqliteType.Text) ] |> ignore @@ -157,10 +156,10 @@ type SQLiteThemeAssetData (conn : SqliteConnection) = } /// Delete all assets for the given theme - let deleteByTheme themeId = backgroundTask { + let deleteByTheme (themeId: ThemeId) = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "DELETE FROM theme_asset WHERE theme_id = @themeId" - cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString themeId) |> ignore + cmd.Parameters.AddWithValue ("@themeId", string themeId) |> ignore do! write cmd } @@ -177,19 +176,19 @@ type SQLiteThemeAssetData (conn : SqliteConnection) = } /// Get theme assets for the given theme (excludes data) - let findByTheme themeId = backgroundTask { + let findByTheme (themeId: 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 + cmd.Parameters.AddWithValue ("@themeId", string themeId) |> ignore use! rdr = cmd.ExecuteReaderAsync () return toList (Map.toThemeAsset false) rdr } /// Get theme assets for the given theme - let findByThemeWithData themeId = backgroundTask { + let findByThemeWithData (themeId: 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 + cmd.Parameters.AddWithValue ("@themeId", string themeId) |> ignore use! rdr = cmd.ExecuteReaderAsync () return toList (Map.toThemeAsset true) rdr } diff --git a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs index 3614b79..cf915ae 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs @@ -5,14 +5,14 @@ open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data -/// SQLite myWebLog web log data implementation -type SQLiteUploadData (conn : SqliteConnection) = +/// 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", upload.Path.Value) + let addUploadParameters (cmd: SqliteCommand) (upload: Upload) = + [ cmd.Parameters.AddWithValue ("@id", string upload.Id) + cmd.Parameters.AddWithValue ("@webLogId", string upload.WebLogId) + cmd.Parameters.AddWithValue ("@path", string upload.Path) cmd.Parameters.AddWithValue ("@updatedOn", instantParam upload.UpdatedOn) cmd.Parameters.AddWithValue ("@dataLength", upload.Data.Length) ] |> ignore @@ -46,14 +46,14 @@ type SQLiteUploadData (conn : SqliteConnection) = WHERE id = @id AND web_log_id = @webLogId" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@id", UploadId.toString uploadId) |> ignore + cmd.Parameters.AddWithValue ("@id", string 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 upload.Path.Value + return Ok (string upload.Path) else return Error $"""Upload ID {cmd.Parameters["@id"]} not found""" } diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index 11a347c..ea2b4ea 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -9,8 +9,8 @@ open Newtonsoft.Json // 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, ser : JsonSerializer) = +/// SQLite myWebLog web log data implementation +type SQLiteWebLogData(conn: SqliteConnection, ser: JsonSerializer) = // SUPPORT FUNCTIONS @@ -25,28 +25,28 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = ] |> ignore /// Add parameters for web log INSERT or UPDATE statements - let addWebLogParameters (cmd : SqliteCommand) (webLog : WebLog) = - [ cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) + let addWebLogParameters (cmd: SqliteCommand) (webLog: WebLog) = + [ cmd.Parameters.AddWithValue ("@id", string 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 ("@themeId", string 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) + cmd.Parameters.AddWithValue ("@uploads", string webLog.Uploads) cmd.Parameters.AddWithValue ("@redirectRules", Utils.serialize ser webLog.RedirectRules) ] |> 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", feed.Path.Value) + let addCustomFeedParameters (cmd: SqliteCommand) (webLogId: WebLogId) (feed: CustomFeed) = + [ cmd.Parameters.AddWithValue ("@id", string feed.Id) + cmd.Parameters.AddWithValue ("@webLogId", string webLogId) + cmd.Parameters.AddWithValue ("@source", string feed.Source) + cmd.Parameters.AddWithValue ("@path", string feed.Path) cmd.Parameters.AddWithValue ("@podcast", maybe (if Option.isSome feed.Podcast then Some (Utils.serialize ser feed.Podcast) else None)) @@ -74,7 +74,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = /// Update the custom feeds for a web log let updateCustomFeeds (webLog : WebLog) = backgroundTask { let! feeds = getCustomFeeds webLog - let toDelete, toAdd = Utils.diffLists feeds webLog.Rss.CustomFeeds (fun it -> $"{CustomFeedId.toString it.Id}") + let toDelete, toAdd = Utils.diffLists feeds webLog.Rss.CustomFeeds string let toId (feed : CustomFeed) = feed.Id let toUpdate = webLog.Rss.CustomFeeds @@ -85,7 +85,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = toDelete |> List.map (fun it -> backgroundTask { cmd.CommandText <- "DELETE FROM web_log_feed WHERE id = @id" - cmd.Parameters["@id"].Value <- CustomFeedId.toString it.Id + cmd.Parameters["@id"].Value <- string it.Id do! write cmd }) |> Task.WhenAll @@ -211,7 +211,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = use cmd = conn.CreateCommand () cmd.CommandText <- "UPDATE web_log SET redirect_rules = @redirectRules WHERE id = @id" cmd.Parameters.AddWithValue ("@redirectRules", Utils.serialize ser webLog.RedirectRules) |> ignore - cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore + cmd.Parameters.AddWithValue ("@id", string webLog.Id) |> ignore do! write cmd } @@ -228,7 +228,7 @@ type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = copyright = @copyright WHERE id = @id" addWebLogRssParameters cmd webLog - cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore + cmd.Parameters.AddWithValue ("@id", string webLog.Id) |> ignore do! write cmd do! updateCustomFeeds webLog } diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index f99bf05..20a6056 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -4,22 +4,22 @@ open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data -/// SQLite myWebLog user data implementation -type SQLiteWebLogUserData (conn : SqliteConnection) = +/// 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) + let addWebLogUserParameters (cmd: SqliteCommand) (user: WebLogUser) = + [ cmd.Parameters.AddWithValue ("@id", string user.Id) + cmd.Parameters.AddWithValue ("@webLogId", string 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 ("@url", maybe user.Url) - cmd.Parameters.AddWithValue ("@accessLevel", user.AccessLevel.Value) + cmd.Parameters.AddWithValue ("@accessLevel", string user.AccessLevel) cmd.Parameters.AddWithValue ("@createdOn", instantParam user.CreatedOn) cmd.Parameters.AddWithValue ("@lastSeenOn", maybeInstant user.LastSeenOn) ] |> ignore @@ -42,12 +42,12 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = } /// Find a user by their ID for the given web log - let findById userId webLogId = backgroundTask { + let findById (userId: WebLogUserId) webLogId = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore + cmd.Parameters.AddWithValue ("@id", string userId) |> ignore use! rdr = cmd.ExecuteReaderAsync () - return Helpers.verifyWebLog webLogId (fun u -> u.WebLogId) Map.toWebLogUser rdr + return verifyWebLog webLogId (_.WebLogId) Map.toWebLogUser rdr } /// Delete a user if they have no posts or pages @@ -56,7 +56,7 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = | Some _ -> use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT COUNT(id) FROM page WHERE author_id = @userId" - cmd.Parameters.AddWithValue ("@userId", WebLogUserId.toString userId) |> ignore + cmd.Parameters.AddWithValue ("@userId", string userId) |> ignore let! pageCount = count cmd cmd.CommandText <- "SELECT COUNT(id) FROM post WHERE author_id = @userId" let! postCount = count cmd @@ -89,16 +89,15 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = } /// Find the names of users by their IDs for the given web log - let findNames webLogId userIds = backgroundTask { + let findNames webLogId (userIds: WebLogUserId list) = backgroundTask { use cmd = conn.CreateCommand () - let nameSql, nameParams = inClause "AND id" "id" WebLogUserId.toString userIds + let nameSql, nameParams = inClause "AND id" "id" string userIds cmd.CommandText <- $"SELECT * FROM web_log_user WHERE web_log_id = @webLogId {nameSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange nameParams use! rdr = cmd.ExecuteReaderAsync () return - toList Map.toWebLogUser rdr - |> List.map (fun u -> { Name = WebLogUserId.toString u.Id; Value = WebLogUser.displayName u }) + toList Map.toWebLogUser rdr |> List.map (fun u -> { Name = string u.Id; Value = WebLogUser.displayName u }) } /// Restore users from a backup @@ -108,7 +107,7 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = } /// Set a user's last seen date/time to now - let setLastSeen userId webLogId = backgroundTask { + let setLastSeen (userId: WebLogUserId) webLogId = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "UPDATE web_log_user @@ -116,7 +115,7 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = WHERE id = @id AND web_log_id = @webLogId" addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) + [ cmd.Parameters.AddWithValue ("@id", string userId) cmd.Parameters.AddWithValue ("@lastSeenOn", instantParam (Noda.now ())) ] |> ignore let! _ = cmd.ExecuteNonQueryAsync () diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index c25d9c2..e30aafd 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -203,7 +203,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS |> 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", CustomFeedId.toString feedId) ] |> ignore + cmd.Parameters.AddWithValue ("@id", string feedId) ] |> ignore let _ = cmd.ExecuteNonQuery () cmd.Parameters.Clear ()) cmd.CommandText <- "SELECT * FROM post_episode" @@ -241,7 +241,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS |> 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", postId.Value) ] |> ignore + cmd.Parameters.AddWithValue ("@id", string postId) ] |> ignore let _ = cmd.ExecuteNonQuery () cmd.Parameters.Clear ()) diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index 285a5f2..2af59a7 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -12,7 +12,7 @@ let currentDbVersion = "v2.1" 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 = cat.Id.Value + { Id = string cat.Id Slug = fullSlug Name = cat.Name Description = cat.Description @@ -29,16 +29,16 @@ let diffLists<'T, 'U when 'U: equality> oldItems newItems (f: 'T -> 'U) = List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems /// Find meta items added and removed -let diffMetaItems (oldItems : MetaItem list) newItems = +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 (fun (it: Permalink) -> it.Value) +let diffPermalinks (oldLinks: Permalink list) newLinks = + diffLists oldLinks newLinks string /// Find the revisions added and removed -let diffRevisions oldRevs newRevs = - diffLists oldRevs newRevs (fun (rev: Revision) -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text.Value}") +let diffRevisions (oldRevs: Revision list) newRevs = + diffLists oldRevs newRevs (fun rev -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text}") open MyWebLog.Converters open Newtonsoft.Json diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index ad0c0d1..01c6a39 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -32,7 +32,7 @@ module Category = /// An empty category let empty = { Id = CategoryId.Empty - WebLogId = WebLogId.empty + WebLogId = WebLogId.Empty Name = "" Slug = "" Description = None @@ -137,8 +137,8 @@ module Page = /// An empty page let empty = { Id = PageId.Empty - WebLogId = WebLogId.empty - AuthorId = WebLogUserId.empty + WebLogId = WebLogId.Empty + AuthorId = WebLogUserId.Empty Title = "" Permalink = Permalink.Empty PublishedOn = Noda.epoch @@ -210,8 +210,8 @@ module Post = /// An empty post let empty = { Id = PostId.Empty - WebLogId = WebLogId.empty - AuthorId = WebLogUserId.empty + WebLogId = WebLogId.Empty + AuthorId = WebLogUserId.Empty Status = Draft Title = "" Permalink = Permalink.Empty @@ -248,8 +248,8 @@ module TagMap = /// An empty tag mapping let empty = { - Id = TagMapId.empty - WebLogId = WebLogId.empty + Id = TagMapId.Empty + WebLogId = WebLogId.Empty Tag = "" UrlValue = "" } @@ -328,8 +328,8 @@ module Upload = /// An empty upload let empty = { - Id = UploadId.empty - WebLogId = WebLogId.empty + Id = UploadId.Empty + WebLogId = WebLogId.Empty Path = Permalink.Empty UpdatedOn = Noda.epoch Data = [||] @@ -384,7 +384,7 @@ module WebLog = /// An empty web log let empty = { - Id = WebLogId.empty + Id = WebLogId.Empty Name = "" Slug = "" Subtitle = None @@ -393,7 +393,7 @@ module WebLog = ThemeId = ThemeId "default" UrlBase = "" TimeZone = "" - Rss = RssOptions.empty + Rss = RssOptions.Empty AutoHtmx = false Uploads = Database RedirectRules = [] @@ -407,12 +407,12 @@ module WebLog = /// Generate an absolute URL for the given link let absoluteUrl webLog (permalink: Permalink) = - $"{webLog.UrlBase}/{permalink.Value}" + $"{webLog.UrlBase}/{permalink}" /// Generate a relative URL for the given link let relativeUrl webLog (permalink: Permalink) = let _, leadPath = hostAndPath webLog - $"{leadPath}/{permalink.Value}" + $"{leadPath}/{permalink}" /// Convert an Instant (UTC reference) to the web log's local date/time let localTime webLog (date: Instant) = @@ -463,8 +463,8 @@ module WebLogUser = /// An empty web log user let empty = { - Id = WebLogUserId.empty - WebLogId = WebLogId.empty + Id = WebLogUserId.Empty + WebLogId = WebLogId.Empty Email = "" FirstName = "" LastName = "" diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index ed25389..ee3c01c 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -54,16 +54,16 @@ type AccessLevel = | Administrator /// Parse an access level from its string representation - static member Parse = - function + static member Parse level = + match level with | "Author" -> Author | "Editor" -> Editor | "WebLogAdmin" -> WebLogAdmin | "Administrator" -> Administrator - | it -> invalidArg "level" $"{it} is not a valid access level" + | _ -> invalidArg (nameof level) $"{level} is not a valid access level" /// The string representation of this access level - member this.Value = + override this.ToString() = match this with | Author -> "Author" | Editor -> "Editor" @@ -96,7 +96,7 @@ type CategoryId = newId >> CategoryId /// The string representation of this category ID - member this.Value = + override this.ToString() = match this with CategoryId it -> it @@ -113,7 +113,7 @@ type CommentId = newId >> CommentId /// The string representation of this comment ID - member this.Value = + override this.ToString() = match this with CommentId it -> it @@ -128,15 +128,15 @@ type CommentStatus = | Spam /// Parse a string into a comment status - static member Parse = - function + static member Parse status = + match status with | "Approved" -> Approved | "Pending" -> Pending | "Spam" -> Spam - | it -> invalidArg "status" $"{it} is not a valid comment status" + | _ -> invalidArg (nameof status) $"{status} is not a valid comment status" /// Convert a comment status to a string - member this.Value = + override this.ToString() = match this with Approved -> "Approved" | Pending -> "Pending" | Spam -> "Spam" @@ -148,15 +148,15 @@ type ExplicitRating = | Clean /// Parse a string into an explicit rating - static member Parse = - function + static member Parse rating = + match rating with | "yes" -> Yes | "no" -> No | "clean" -> Clean - | it -> invalidArg "rating" $"{it} is not a valid explicit rating" + | _ -> invalidArg (nameof rating) $"{rating} is not a valid explicit rating" /// The string value of this rating - member this.Value = + override this.ToString() = match this with Yes -> "yes" | No -> "no" | Clean -> "clean" @@ -289,11 +289,11 @@ type MarkupText = | Html of string /// Parse a string into a MarkupText instance - static member Parse(it: string) = - match it with - | text when text.StartsWith "Markdown: " -> Markdown text[10..] - | text when text.StartsWith "HTML: " -> Html text[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 = @@ -304,7 +304,8 @@ type MarkupText = match this with Markdown text -> text | Html text -> text /// The string representation of the markup text - member this.Value = $"{this.SourceType}: {this.Text}" + override this.ToString() = + $"{this.SourceType}: {this.Text}" /// The HTML representation of the markup text member this.AsHtml() = @@ -315,10 +316,10 @@ type MarkupText = [] type MetaItem = { /// The name of the metadata value - Name : string + Name: string /// The metadata value - Value : string + Value: string } with /// An empty metadata item @@ -330,10 +331,10 @@ type MetaItem = { [] type Revision = { /// When this revision was saved - AsOf : Instant + AsOf: Instant /// The text of the revision - Text : MarkupText + Text: MarkupText } with /// An empty revision @@ -350,7 +351,7 @@ type Permalink = static member Empty = Permalink "" /// The string value of this permalink - member this.Value = + override this.ToString() = match this with Permalink it -> it @@ -367,7 +368,7 @@ type PageId = newId >> PageId /// The string value of this page ID - member this.Value = + override this.ToString() = match this with PageId it -> it @@ -383,8 +384,8 @@ type PodcastMedium = | Blog /// Parse a string into a podcast medium - static member Parse = - function + static member Parse medium = + match medium with | "podcast" -> Podcast | "music" -> Music | "video" -> Video @@ -392,10 +393,10 @@ type PodcastMedium = | "audiobook" -> Audiobook | "newsletter" -> Newsletter | "blog" -> Blog - | it -> invalidArg "medium" $"{it} is not a valid podcast medium" + | _ -> invalidArg (nameof medium) $"{medium} is not a valid podcast medium" /// The string value of this podcast medium - member this.Value = + override this.ToString() = match this with | Podcast -> "podcast" | Music -> "music" @@ -415,14 +416,14 @@ type PostStatus = | Published /// Parse a string into a post status - static member Parse = - function + static member Parse status = + match status with | "Draft" -> Draft | "Published" -> Published - | it -> invalidArg "status" $"{it} is not a valid post status" + | _ -> invalidArg (nameof status) $"{status} is not a valid post status" /// The string representation of this post status - member this.Value = + override this.ToString() = match this with Draft -> "Draft" | Published -> "Published" @@ -439,7 +440,7 @@ type PostId = newId >> PostId /// Convert a post ID to a string - member this.Value = + override this.ToString() = match this with PostId it -> it @@ -465,19 +466,20 @@ type RedirectRule = { /// An identifier for a custom feed -type CustomFeedId = CustomFeedId of string +[] +type CustomFeedId = + | CustomFeedId of string -/// Functions to support custom feed IDs -module CustomFeedId = - /// 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 = newId >> CustomFeedId + 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 @@ -486,99 +488,94 @@ type CustomFeedSource = | Category of CategoryId /// 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 - Title : string + Title: string /// A subtitle for the podcast - Subtitle : string option + Subtitle: string option /// The number of items in the podcast feed - ItemsInFeed : int + ItemsInFeed: int /// A summary of the podcast (iTunes field) - Summary : string + Summary: string /// The display name of the podcast author (iTunes field) - DisplayedAuthor : string + DisplayedAuthor: string /// The e-mail address of the user who registered the podcast at iTunes - Email : string + Email: string /// The link to the image for the podcast - ImageUrl : Permalink + ImageUrl: Permalink /// The category from Apple Podcasts (iTunes) under which this podcast is categorized - AppleCategory : string + AppleCategory: string /// A further refinement of the categorization of this podcast (Apple Podcasts/iTunes field / values) - AppleSubcategory : string option + AppleSubcategory: string option /// The explictness rating (iTunes field) - Explicit : ExplicitRating + Explicit: ExplicitRating /// The default media type for files in this podcast - DefaultMediaType : string option + DefaultMediaType: string option /// The base URL for relative URL media files for this podcast (optional; defaults to web log base) - MediaBaseUrl : string option + MediaBaseUrl: string option /// A GUID for this podcast - PodcastGuid : Guid option + PodcastGuid: Guid option /// A URL at which information on supporting the podcast may be found (supports permalinks) - FundingUrl : string option + FundingUrl: string option /// The text to be displayed in the funding item within the feed - FundingText : string option + FundingText: string option /// The medium (what the podcast IS, not what it is ABOUT) - Medium : PodcastMedium option + Medium: PodcastMedium option } /// A custom feed +[] type CustomFeed = { /// The ID of the custom feed - Id : CustomFeedId + Id: CustomFeedId /// The source for the custom feed - Source : CustomFeedSource + Source: CustomFeedSource /// The path for the custom feed - Path : Permalink + Path: Permalink /// Podcast options, if the feed defines a podcast - Podcast : PodcastOptions option -} - -/// Functions to support custom feeds -module CustomFeed = + Podcast: PodcastOptions option +} with /// An empty custom feed - let empty = { - Id = CustomFeedId "" - Source = Category (CategoryId "") - Path = Permalink "" + static member Empty = { + Id = CustomFeedId.Empty + Source = Category CategoryId.Empty + Path = Permalink.Empty Podcast = None } @@ -587,32 +584,29 @@ module CustomFeed = [] type RssOptions = { /// Whether the site feed of posts is enabled - IsFeedEnabled : bool + IsFeedEnabled: bool /// The name of the file generated for the site feed - FeedName : string + FeedName: string /// Override the "posts per page" setting for the site feed - ItemsInFeed : int option + ItemsInFeed: int option /// Whether feeds are enabled for all categories - IsCategoryEnabled : bool + IsCategoryEnabled: bool /// Whether feeds are enabled for all tags - IsTagEnabled : bool + IsTagEnabled: bool /// A copyright string to be placed in all feeds - Copyright : string option + Copyright: string option /// 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 @@ -624,126 +618,126 @@ module RssOptions = /// An identifier for a tag mapping -type TagMapId = TagMapId of string +[] +type TagMapId = + | TagMapId of string -/// Functions to support tag mapping IDs -module TagMapId = - /// 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 = newId >> TagMapId + 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 - -/// Functions to support theme IDs -module ThemeId = - let toString = function ThemeId ti -> ti +[] +type ThemeId = + | ThemeId of string + + /// 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 +[] +type ThemeAssetId = + | ThemeAssetId of ThemeId * string -/// Functions to support theme asset IDs -module ThemeAssetId = + /// Convert a string into a theme asset ID + static member Parse(it : string) = + let themeIdx = it.IndexOf "/" + ThemeAssetId(ThemeId it[..(themeIdx - 1)], it[(themeIdx + 1)..]) /// Convert a theme asset ID into a path string - let toString = function ThemeAssetId (ThemeId theme, asset) -> $"{theme}/{asset}" - - /// Convert a string into a theme asset ID - let ofString (it : string) = - let themeIdx = it.IndexOf "/" - ThemeAssetId (ThemeId it[..(themeIdx - 1)], it[(themeIdx + 1)..]) + override this.ToString() = + match this with ThemeAssetId (ThemeId theme, asset) -> $"{theme}/{asset}" /// A template for a theme +[] type ThemeTemplate = { /// The name of the template - Name : string + Name: string /// The text of the template - Text : string -} - -/// Functions to support theme templates -module ThemeTemplate = + Text: string +} with /// An empty theme template - let empty = + static member Empty = { Name = ""; Text = "" } /// Where uploads should be placed +[] 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 -> invalidArg "destination" $"{it} is not a valid upload destination" + | "Disk" -> Disk + | _ -> 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 +[] +type UploadId = + | UploadId of string -/// Functions to support upload IDs -module UploadId = - /// 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 = newId >> UploadId + 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 +[] +type WebLogId = + | WebLogId of string -/// Functions to support web log IDs -module WebLogId = - /// 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 = newId >> WebLogId - + 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 = +[] +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 = newId >> WebLogUserId - - + static member Create = + newId >> WebLogUserId + + /// The string representation of a web log user ID + override this.ToString() = + match this with WebLogUserId it -> it diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 2f9a176..2005de8 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -73,30 +73,30 @@ type DisplayCategory = { /// A display version of a custom feed definition type DisplayCustomFeed = { /// The ID of the custom feed - Id : string + Id: string /// The source of the custom feed - Source : string + Source: string /// The relative path at which the custom feed is served - Path : string + Path: string /// Whether this custom feed is for a podcast - IsPodcast : bool + IsPodcast: bool } /// Support functions for custom feed displays module DisplayCustomFeed = /// Create a display version from a custom feed - let fromFeed (cats: DisplayCategory[]) (feed: CustomFeed) : DisplayCustomFeed = + let fromFeed (cats: DisplayCategory array) (feed: CustomFeed) : DisplayCustomFeed = let source = match feed.Source with | Category (CategoryId catId) -> $"Category: {(cats |> Array.find (fun cat -> cat.Id = catId)).Name}" | Tag tag -> $"Tag: {tag}" - { Id = CustomFeedId.toString feed.Id + { Id = string feed.Id Source = source - Path = feed.Path.Value + Path = string feed.Path IsPodcast = Option.isSome feed.Podcast } @@ -137,14 +137,14 @@ type DisplayPage = /// Create a minimal display page (no text or metadata) from a database page static member FromPageMinimal webLog (page: Page) = { - Id = page.Id.Value - AuthorId = WebLogUserId.toString page.AuthorId + Id = string page.Id + AuthorId = string page.AuthorId Title = page.Title - Permalink = page.Permalink.Value + Permalink = string page.Permalink PublishedOn = WebLog.localTime webLog page.PublishedOn UpdatedOn = WebLog.localTime webLog page.UpdatedOn IsInPageList = page.IsInPageList - IsDefault = page.Id.Value = webLog.DefaultPage + IsDefault = string page.Id = webLog.DefaultPage Text = "" Metadata = [] } @@ -152,14 +152,14 @@ type DisplayPage = /// Create a display page from a database page static member FromPage webLog (page : Page) = let _, extra = WebLog.hostAndPath webLog - { Id = page.Id.Value - AuthorId = WebLogUserId.toString page.AuthorId + { Id = string page.Id + AuthorId = string page.AuthorId Title = page.Title - Permalink = page.Permalink.Value + Permalink = string page.Permalink PublishedOn = WebLog.localTime webLog page.PublishedOn UpdatedOn = WebLog.localTime webLog page.UpdatedOn IsInPageList = page.IsInPageList - IsDefault = page.Id.Value = webLog.DefaultPage + IsDefault = string page.Id = webLog.DefaultPage Text = addBaseToRelativeUrls extra page.Text Metadata = page.Metadata } @@ -195,35 +195,35 @@ open System.IO [] type DisplayTheme = { /// The ID / path slug of the theme - Id : string + Id: string /// The name of the theme - Name : string + Name: string /// The version of the theme - Version : string + Version: string /// How many templates are contained in the theme - TemplateCount : int + TemplateCount: int /// Whether the theme is in use by any web logs - IsInUse : bool + IsInUse: bool /// Whether the theme .zip file exists on the filesystem - IsOnDisk : bool + IsOnDisk: bool } /// Functions to support displaying themes module DisplayTheme = /// Create a display theme from a theme - let fromTheme inUseFunc (theme : Theme) = - { Id = ThemeId.toString theme.Id + let fromTheme inUseFunc (theme: Theme) = + { Id = string theme.Id Name = theme.Name Version = theme.Version TemplateCount = List.length theme.Templates IsInUse = inUseFunc theme.Id - IsOnDisk = File.Exists $"{ThemeId.toString theme.Id}-theme.zip" + IsOnDisk = File.Exists $"{theme.Id}-theme.zip" } @@ -231,33 +231,33 @@ module DisplayTheme = [] type DisplayUpload = { /// The ID of the uploaded file - Id : string + Id: string /// The name of the uploaded file - Name : string + Name: string /// The path at which the file is served - Path : string + Path: string /// The date/time the file was updated - UpdatedOn : DateTime option + UpdatedOn: DateTime option /// The source for this file (created from UploadDestination DU) - Source : string + Source: string } /// Functions to support displaying uploads module DisplayUpload = /// Create a display uploaded file - let fromUpload webLog source (upload : Upload) = - let path = upload.Path.Value + let fromUpload webLog (source: UploadDestination) (upload: Upload) = + let path = string upload.Path let name = Path.GetFileName path - { Id = UploadId.toString upload.Id + { Id = string upload.Id Name = name - Path = path.Replace (name, "") + Path = path.Replace(name, "") UpdatedOn = Some (WebLog.localTime webLog upload.UpdatedOn) - Source = UploadDestination.toString source + Source = string source } @@ -265,45 +265,45 @@ module DisplayUpload = [] type DisplayUser = { /// The ID of the user - Id : string + Id: string /// The user name (e-mail address) - Email : string + Email: string /// The user's first name - FirstName : string + FirstName: string /// The user's last name - LastName : string + LastName: string /// The user's preferred name - PreferredName : string + PreferredName: string /// The URL of the user's personal site - Url : string + Url: string /// The user's access level - AccessLevel : string + AccessLevel: string /// When the user was created - CreatedOn : DateTime + CreatedOn: DateTime /// When the user last logged on - LastSeenOn : Nullable + LastSeenOn: Nullable } /// Functions to support displaying a user's information module DisplayUser = /// Construct a displayed user from a web log user - let fromUser webLog (user : WebLogUser) = - { Id = WebLogUserId.toString user.Id + let fromUser webLog (user: WebLogUser) = + { Id = string user.Id Email = user.Email FirstName = user.FirstName LastName = user.LastName PreferredName = user.PreferredName Url = defaultArg user.Url "" - AccessLevel = user.AccessLevel.Value + AccessLevel = string user.AccessLevel CreatedOn = WebLog.localTime webLog user.CreatedOn LastSeenOn = user.LastSeenOn |> Option.map (WebLog.localTime webLog) |> Option.toNullable } @@ -311,30 +311,30 @@ module DisplayUser = /// View model for editing categories [] -type EditCategoryModel = - { /// The ID of the category being edited - CategoryId : string - - /// The name of the category - Name : string - - /// The category's URL slug - Slug : string - - /// A description of the category (optional) - Description : string - - /// The ID of the category for which this is a subcategory (optional) - ParentId : string - } +type EditCategoryModel = { + /// The ID of the category being edited + CategoryId: string + + /// The name of the category + Name: string + + /// The category's URL slug + Slug: string + + /// A description of the category (optional) + Description: string + + /// The ID of the category for which this is a subcategory (optional) + ParentId: string +} with /// Create an edit model from an existing category - static member fromCategory (cat : Category) = - { CategoryId = cat.Id.Value + static member fromCategory (cat: Category) = + { CategoryId = string cat.Id Name = cat.Name Slug = cat.Slug Description = defaultArg cat.Description "" - ParentId = cat.ParentId |> Option.map _.Value |> Option.defaultValue "" + ParentId = cat.ParentId |> Option.map string |> Option.defaultValue "" } /// Is this a new category? @@ -437,10 +437,10 @@ type EditCustomFeedModel = static member fromFeed (feed: CustomFeed) = let rss = { EditCustomFeedModel.empty with - Id = CustomFeedId.toString feed.Id + Id = string feed.Id SourceType = match feed.Source with Category _ -> "category" | Tag _ -> "tag" SourceValue = match feed.Source with Category (CategoryId catId) -> catId | Tag tag -> tag - Path = feed.Path.Value + Path = string feed.Path } match feed.Podcast with | Some p -> @@ -452,16 +452,16 @@ type EditCustomFeedModel = Summary = p.Summary DisplayedAuthor = p.DisplayedAuthor Email = p.Email - ImageUrl = p.ImageUrl.Value + ImageUrl = string p.ImageUrl AppleCategory = p.AppleCategory AppleSubcategory = defaultArg p.AppleSubcategory "" - Explicit = p.Explicit.Value + Explicit = string p.Explicit DefaultMediaType = defaultArg p.DefaultMediaType "" MediaBaseUrl = defaultArg p.MediaBaseUrl "" FundingUrl = defaultArg p.FundingUrl "" FundingText = defaultArg p.FundingText "" PodcastGuid = p.PodcastGuid |> Option.map _.ToString().ToLowerInvariant() |> Option.defaultValue "" - Medium = p.Medium |> Option.map _.Value |> Option.defaultValue "" + Medium = p.Medium |> Option.map string |> Option.defaultValue "" } | None -> rss @@ -562,9 +562,9 @@ type EditPageModel = { | Some rev -> rev | None -> Revision.Empty let page = if page.Metadata |> List.isEmpty then { page with Metadata = [ MetaItem.Empty ] } else page - { PageId = page.Id.Value + { PageId = string page.Id Title = page.Title - Permalink = page.Permalink.Value + Permalink = string page.Permalink Template = defaultArg page.Template "" IsShownInPageList = page.IsInPageList Source = latest.Text.SourceType @@ -580,7 +580,7 @@ type EditPageModel = { member this.UpdatePage (page: Page) now = let revision = { AsOf = now; Text = MarkupText.Parse $"{this.Source}: {this.Text}" } // Detect a permalink change, and add the prior one to the prior list - match page.Permalink.Value with + match string page.Permalink with | "" -> page | link when link = this.Permalink -> page | _ -> { page with PriorPermalinks = page.Permalink :: page.PriorPermalinks } @@ -715,15 +715,15 @@ type EditPostModel = { | None -> Revision.Empty let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.Empty ] } else post let episode = defaultArg post.Episode Episode.Empty - { PostId = post.Id.Value + { PostId = string post.Id Title = post.Title - Permalink = post.Permalink.Value + Permalink = string post.Permalink Source = latest.Text.SourceType Text = latest.Text.Text Tags = String.Join (", ", post.Tags) Template = defaultArg post.Template "" - CategoryIds = post.CategoryIds |> List.map _.Value |> Array.ofList - Status = post.Status.Value + CategoryIds = post.CategoryIds |> List.map string |> Array.ofList + Status = string post.Status DoPublish = false MetaNames = post.Metadata |> List.map _.Name |> Array.ofList MetaValues = post.Metadata |> List.map _.Value |> Array.ofList @@ -737,7 +737,7 @@ type EditPostModel = { MediaType = defaultArg episode.MediaType "" ImageUrl = defaultArg episode.ImageUrl "" Subtitle = defaultArg episode.Subtitle "" - Explicit = defaultArg (episode.Explicit |> Option.map _.Value) "" + Explicit = defaultArg (episode.Explicit |> Option.map string) "" ChapterFile = defaultArg episode.ChapterFile "" ChapterType = defaultArg episode.ChapterType "" TranscriptUrl = defaultArg episode.TranscriptUrl "" @@ -757,7 +757,7 @@ type EditPostModel = { member this.UpdatePost (post: Post) now = let revision = { AsOf = now; Text = MarkupText.Parse $"{this.Source}: {this.Text}" } // Detect a permalink change, and add the prior one to the prior list - match post.Permalink.Value with + match string post.Permalink with | "" -> post | link when link = this.Permalink -> post | _ -> { post with PriorPermalinks = post.Permalink :: post.PriorPermalinks } @@ -916,7 +916,7 @@ type EditTagMapModel = /// Create an edit model from the tag mapping static member fromMapping (tagMap : TagMap) : EditTagMapModel = - { Id = TagMapId.toString tagMap.Id + { Id = string tagMap.Id Tag = tagMap.Tag UrlValue = tagMap.UrlValue } @@ -924,39 +924,39 @@ type EditTagMapModel = /// View model to display a user's information [] -type EditUserModel = - { /// The ID of the user - Id : string +type EditUserModel = { + /// The ID of the user + Id: string - /// The user's access level - AccessLevel : string - - /// The user name (e-mail address) - Email : string + /// The user's access level + AccessLevel: string + + /// The user name (e-mail address) + Email: string - /// The URL of the user's personal site - Url : string + /// The URL of the user's personal site + Url: string - /// The user's first name - FirstName : string + /// The user's first name + FirstName: string - /// The user's last name - LastName : string + /// The user's last name + LastName: string - /// The user's preferred name - PreferredName : string - - /// The user's password - Password : string - - /// Confirmation of the user's password - PasswordConfirm : string - } + /// The user's preferred name + PreferredName: string + + /// The user's password + Password: string + + /// Confirmation of the user's password + PasswordConfirm: string +} with /// Construct a displayed user from a web log user - static member fromUser (user : WebLogUser) = - { Id = WebLogUserId.toString user.Id - AccessLevel = user.AccessLevel.Value + static member fromUser (user: WebLogUser) = + { Id = string user.Id + AccessLevel = string user.AccessLevel Url = defaultArg user.Url "" Email = user.Email FirstName = user.FirstName @@ -1020,20 +1020,20 @@ type ManagePermalinksModel = { /// Create a permalink model from a page static member fromPage (pg: Page) = - { Id = pg.Id.Value + { Id = string pg.Id Entity = "page" CurrentTitle = pg.Title - CurrentPermalink = pg.Permalink.Value - Prior = pg.PriorPermalinks |> List.map _.Value |> Array.ofList + CurrentPermalink = string pg.Permalink + Prior = pg.PriorPermalinks |> List.map string |> Array.ofList } /// Create a permalink model from a post static member fromPost (post: Post) = - { Id = post.Id.Value + { Id = string post.Id Entity = "post" CurrentTitle = post.Title - CurrentPermalink = post.Permalink.Value - Prior = post.PriorPermalinks |> List.map _.Value |> Array.ofList + CurrentPermalink = string post.Permalink + Prior = post.PriorPermalinks |> List.map string |> Array.ofList } @@ -1055,7 +1055,7 @@ type ManageRevisionsModel = /// Create a revision model from a page static member fromPage webLog (pg: Page) = - { Id = pg.Id.Value + { Id = string pg.Id Entity = "page" CurrentTitle = pg.Title Revisions = pg.Revisions |> List.map (DisplayRevision.fromRevision webLog) |> Array.ofList @@ -1063,7 +1063,7 @@ type ManageRevisionsModel = /// Create a revision model from a post static member fromPost webLog (post: Post) = - { Id = post.Id.Value + { Id = string post.Id Entity = "post" CurrentTitle = post.Title Revisions = post.Revisions |> List.map (DisplayRevision.fromRevision webLog) |> Array.ofList @@ -1114,15 +1114,15 @@ type PostListItem = { static member fromPost (webLog: WebLog) (post: Post) = let _, extra = WebLog.hostAndPath webLog let inTZ = WebLog.localTime webLog - { Id = post.Id.Value - AuthorId = WebLogUserId.toString post.AuthorId - Status = post.Status.Value + { Id = string post.Id + AuthorId = string post.AuthorId + Status = string post.Status Title = post.Title - Permalink = post.Permalink.Value + Permalink = string post.Permalink PublishedOn = post.PublishedOn |> Option.map inTZ |> Option.toNullable UpdatedOn = inTZ post.UpdatedOn Text = addBaseToRelativeUrls extra post.Text - CategoryIds = post.CategoryIds |> List.map _.Value + CategoryIds = post.CategoryIds |> List.map string Tags = post.Tags Episode = post.Episode Metadata = post.Metadata @@ -1156,46 +1156,46 @@ type PostDisplay = /// View model for editing web log settings [] -type SettingsModel = - { /// The name of the web log - Name : string +type SettingsModel = { + /// The name of the web log + Name: string - /// The slug of the web log - Slug : string - - /// The subtitle of the web log - Subtitle : string + /// The slug of the web log + Slug: string + + /// The subtitle of the web log + Subtitle: string - /// The default page - DefaultPage : string + /// The default page + DefaultPage: string - /// How many posts should appear on index pages - PostsPerPage : int + /// How many posts should appear on index pages + PostsPerPage: int - /// The time zone in which dates/times should be displayed - TimeZone : string - - /// The theme to use to display the web log - ThemeId : string - - /// Whether to automatically load htmx - AutoHtmx : bool - - /// The default location for uploads - Uploads : string - } + /// The time zone in which dates/times should be displayed + TimeZone: string + + /// The theme to use to display the web log + ThemeId: string + + /// Whether to automatically load htmx + AutoHtmx: bool + + /// The default location for uploads + Uploads: string +} with /// Create a settings model from a web log - static member fromWebLog (webLog : WebLog) = + static member fromWebLog (webLog: WebLog) = { Name = webLog.Name Slug = webLog.Slug Subtitle = defaultArg webLog.Subtitle "" DefaultPage = webLog.DefaultPage PostsPerPage = webLog.PostsPerPage TimeZone = webLog.TimeZone - ThemeId = ThemeId.toString webLog.ThemeId + ThemeId = string webLog.ThemeId AutoHtmx = webLog.AutoHtmx - Uploads = UploadDestination.toString webLog.Uploads + Uploads = string webLog.Uploads } /// Update a web log with settings from the form @@ -1209,7 +1209,7 @@ type SettingsModel = TimeZone = this.TimeZone ThemeId = ThemeId this.ThemeId AutoHtmx = this.AutoHtmx - Uploads = UploadDestination.parse this.Uploads + Uploads = UploadDestination.Parse this.Uploads } diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index 05bda8f..74b09d9 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -194,8 +194,8 @@ 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 : ThemeId) (templateName : string) (data : IData) = backgroundTask { - let templatePath = $"{ThemeId.toString themeId}/{templateName}" + let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask { + let templatePath = $"{themeId}/{templateName}" match _cache.ContainsKey templatePath with | true -> return Ok _cache[templatePath] | false -> @@ -215,7 +215,7 @@ module TemplateCache = if childNotFound = "" then child.Groups[1].Value else $"{childNotFound}; {child.Groups[1].Value}" "" - text <- text.Replace (child.Value, childText) + 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}" @@ -223,8 +223,8 @@ module TemplateCache = _cache[templatePath] <- Template.Parse (text, SyntaxCompatibility.DotLiquid22) return Ok _cache[templatePath] | None -> - return Error $"Theme ID {ThemeId.toString themeId} does not have a template named {templateName}" - | None -> return Result.Error $"Theme ID {ThemeId.toString themeId} does not exist" + 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 @@ -232,16 +232,16 @@ module TemplateCache = _cache.Keys |> Seq.sort |> Seq.toList /// Invalidate all template cache entries for the given theme ID - let invalidateTheme (themeId : ThemeId) = - let keyPrefix = ThemeId.toString themeId + let invalidateTheme (themeId: ThemeId) = + let keyPrefix = string themeId _cache.Keys - |> Seq.filter (fun key -> key.StartsWith keyPrefix) + |> 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 () + _cache.Clear() /// A cache of asset names by themes diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 45006b7..2718d43 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -95,9 +95,9 @@ 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}") +type ThemeAssetFilter() = + static member ThemeAsset(ctx: Context, asset: string) = + WebLog.relativeUrl ctx.WebLog (Permalink $"themes/{ctx.WebLog.ThemeId}/{asset}") /// Create various items in the page header based on the state of the page being generated diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 0e9af33..42bed16 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -37,7 +37,7 @@ module Dashboard = let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { match! TemplateCache.get adminTheme "theme-list-body" ctx.Data with | Ok bodyTemplate -> - let! themes = ctx.Data.Theme.All () + let! themes = ctx.Data.Theme.All() let cachedTemplates = TemplateCache.allNames () let! hash = hashForPage "myWebLog Administration" @@ -50,10 +50,10 @@ module Dashboard = themes |> Seq.ofList |> Seq.map (fun it -> [| - ThemeId.toString it.Id + string it.Id it.Name cachedTemplates - |> List.filter (fun n -> n.StartsWith (ThemeId.toString it.Id)) + |> List.filter _.StartsWith(string it.Id) |> List.length |> string |]) @@ -61,8 +61,8 @@ module Dashboard = |> addToHash "web_logs" ( WebLogCache.all () |> Seq.ofList - |> Seq.sortBy (fun it -> it.Name) - |> Seq.map (fun it -> [| WebLogId.toString it.Id; it.Name; it.UrlBase |]) + |> Seq.sortBy _.Name + |> Seq.map (fun it -> [| string it.Id; it.Name; it.UrlBase |]) |> Array.ofSeq) |> addViewContext ctx return! @@ -317,7 +317,7 @@ module TagMapping = addToHash "mappings" mappings hash |> addToHash "mapping_ids" ( mappings - |> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id })) + |> List.map (fun it -> { Name = it.Tag; Value = string it.Id })) } // GET /admin/settings/tag-mappings @@ -348,13 +348,13 @@ module TagMapping = // POST /admin/settings/tag-mapping/save let save : HttpHandler = fun next ctx -> task { let data = ctx.Data - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() 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! data.TagMap.Save { tm with Tag = model.Tag.ToLower(); UrlValue = model.UrlValue.ToLower() } do! addMessage ctx { UserMessage.success with Message = "Tag mapping saved successfully" } return! all next ctx | None -> return! Error.notFound next ctx @@ -395,17 +395,17 @@ module Theme = |> adminBareView "theme-upload" next ctx /// Update the name and version for a theme based on the version.txt file, if present - let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask { + let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask { let now () = DateTime.UtcNow.ToString "yyyyMMdd.HHmm" match zip.Entries |> Seq.filter (fun it -> it.FullName = "version.txt") |> Seq.tryHead with | Some versionItem -> - use versionFile = new StreamReader(versionItem.Open ()) - let! versionText = versionFile.ReadToEndAsync () + 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 () } + | None -> return { theme with Name = string theme.Id; Version = now () } } /// Update the theme with all templates from the ZIP archive @@ -476,16 +476,16 @@ module Theme = let data = ctx.Data let! exists = data.Theme.Exists themeId let isNew = not exists - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() if isNew || model.DoOverwrite then // Load the theme to the database - use stream = new MemoryStream () + use stream = new MemoryStream() do! themeFile.CopyToAsync stream let! _ = loadFromZip themeId stream data do! ThemeAssetCache.refreshTheme themeId data TemplateCache.invalidateTheme themeId // Save the .zip file - use file = new FileStream ($"{ThemeId.toString themeId}-theme.zip", FileMode.Create) + use file = new FileStream($"{themeId}-theme.zip", FileMode.Create) do! themeFile.CopyToAsync file do! addMessage ctx { UserMessage.success with @@ -556,18 +556,18 @@ module WebLog = KeyValuePair.Create("posts", "- First Page of Posts -") yield! allPages |> List.sortBy _.Title.ToLower() - |> List.map (fun p -> KeyValuePair.Create(p.Id.Value, p.Title)) + |> List.map (fun p -> KeyValuePair.Create(string 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})")) + KeyValuePair.Create(string it.Id, $"{it.Name} (v{it.Version})")) |> Array.ofSeq) |> addToHash "upload_values" [| - KeyValuePair.Create (UploadDestination.toString Database, "Database") - KeyValuePair.Create (UploadDestination.toString Disk, "Disk") + KeyValuePair.Create(string Database, "Database") + KeyValuePair.Create(string Disk, "Disk") |] |> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList) |> addToHash "rss_model" (EditRssModel.fromRssOptions ctx.WebLog.Rss) diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 1d8dcda..605b038 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -37,7 +37,7 @@ 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 it.Path.Value) 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 _.ItemsInFeed |> Option.defaultValue postCount) @@ -48,7 +48,7 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = /// Determine the function to retrieve posts for the given feed let private getFeedPosts ctx feedType = let childIds (catId: CategoryId) = - let cat = CategoryCache.get ctx |> Array.find (fun c -> c.Id = catId.Value) + let cat = CategoryCache.get ctx |> Array.find (fun c -> c.Id = string catId) getCategoryIds cat.Slug ctx let data = ctx.Data match feedType with @@ -86,51 +86,50 @@ 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) - (post : Post) = +let private toFeedItem webLog (authors: MetaItem list) (cats: DisplayCategory array) (tagMaps: TagMap list) + (post: Post) = let plainText = let endingP = post.Text.IndexOf "

" stripHtml <| if endingP >= 0 then post.Text[..(endingP - 1)] else post.Text - let item = SyndicationItem ( + let item = SyndicationItem( Id = WebLog.absoluteUrl webLog post.Permalink, Title = TextSyndicationContent.CreateHtmlContent post.Title, - PublishDate = post.PublishedOn.Value.ToDateTimeOffset (), - LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset (), + PublishDate = post.PublishedOn.Value.ToDateTimeOffset(), + LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset(), Content = TextSyndicationContent.CreatePlaintextContent plainText) item.AddPermalink (Uri item.Id) - let xmlDoc = XmlDocument () + let xmlDoc = XmlDocument() let encoded = let txt = post.Text .Replace("src=\"/", $"src=\"{webLog.UrlBase}/") - .Replace ("href=\"/", $"href=\"{webLog.UrlBase}/") - let it = xmlDoc.CreateElement ("content", "encoded", Namespace.content) - let _ = it.AppendChild (xmlDoc.CreateCDataSection txt) + .Replace("href=\"/", $"href=\"{webLog.UrlBase}/") + let it = xmlDoc.CreateElement("content", "encoded", Namespace.content) + let _ = it.AppendChild(xmlDoc.CreateCDataSection txt) 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 = catId.Value) - 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 webLog (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 webLog (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) = +let toAbsolute webLog (link: string) = if link.StartsWith "http" then link else WebLog.absoluteUrl webLog (Permalink link) /// Add episode information to a podcast feed item @@ -141,8 +140,8 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po | link when Option.isSome podcast.MediaBaseUrl -> $"{podcast.MediaBaseUrl.Value}{link}" | link -> WebLog.absoluteUrl webLog (Permalink link) let epMediaType = [ episode.MediaType; podcast.DefaultMediaType ] |> List.tryFind Option.isSome |> Option.flatten - let epImageUrl = defaultArg episode.ImageUrl podcast.ImageUrl.Value |> toAbsolute webLog - let epExplicit = (defaultArg episode.Explicit podcast.Explicit).Value + let epImageUrl = defaultArg episode.ImageUrl (string podcast.ImageUrl) |> toAbsolute webLog + let epExplicit = string (defaultArg episode.Explicit podcast.Explicit) let xmlDoc = XmlDocument() let enclosure = @@ -298,7 +297,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, podcast.Explicit.Value) + 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 -> @@ -309,7 +308,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, med.Value)) + 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 = @@ -368,7 +367,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} {self.Value}] \"{stripHtml post.Title}\" has no media" + warn "Feed" ctx $"[{webLog.Name} {self}] \"{stripHtml post.Title}\" has no media" item | _ -> item @@ -427,7 +426,7 @@ 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 -> @@ -436,13 +435,13 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next |> addToHash ViewContext.Model (EditCustomFeedModel.fromFeed f) |> addToHash "medium_values" [| KeyValuePair.Create("", "– Unspecified –") - KeyValuePair.Create(Podcast.Value, "Podcast") - KeyValuePair.Create(Music.Value, "Music") - KeyValuePair.Create(Video.Value, "Video") - KeyValuePair.Create(Film.Value, "Film") - KeyValuePair.Create(Audiobook.Value, "Audiobook") - KeyValuePair.Create(Newsletter.Value, "Newsletter") - KeyValuePair.Create(Blog.Value, "Blog") + KeyValuePair.Create(string Podcast, "Podcast") + KeyValuePair.Create(string Music, "Music") + KeyValuePair.Create(string Video, "Video") + KeyValuePair.Create(string Film, "Film") + KeyValuePair.Create(string Audiobook, "Audiobook") + KeyValuePair.Create(string Newsletter, "Newsletter") + KeyValuePair.Create(string Blog, "Blog") |] |> adminView "custom-feed-edit" next ctx | None -> Error.notFound next ctx @@ -455,8 +454,8 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> let! model = ctx.BindFormAsync () 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)) @@ -467,7 +466,7 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next 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 + return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx | None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index b1f4bd3..a2a9ded 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -352,8 +352,8 @@ let requireAccess level : HttpHandler = fun next ctx -> task { | Some userLevel -> do! addMessage ctx { UserMessage.warning with - Message = $"The page you tried to access requires {level.Value} privileges" - Detail = Some $"Your account only has {userLevel.Value} privileges" + Message = $"The page you tried to access requires {level} privileges" + Detail = Some $"Your account only has {userLevel} privileges" } return! Error.notAuthorized next ctx | None -> diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 1eece85..1c442f5 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -193,7 +193,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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/{page.Id.Value}/edit" next ctx + return! redirectToGet $"admin/page/{page.Id}/edit" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index d9e87cd..ee8b3db 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -58,7 +58,7 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I | _ -> Task.FromResult (None, None) let newerLink = match listType, pageNbr with - | SinglePost, _ -> newerPost |> Option.map _.Permalink.Value + | 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 +70,7 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I | AdminList, _ -> relUrl $"admin/posts/page/{pageNbr - 1}" let olderLink = match listType, List.length posts > perPage with - | SinglePost, _ -> olderPost |> Option.map _.Permalink.Value + | 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}" @@ -243,9 +243,9 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> addToHash "templates" templates |> addToHash "explicit_values" [| KeyValuePair.Create("", "– Default –") - KeyValuePair.Create(Yes.Value, "Yes") - KeyValuePair.Create(No.Value, "No") - KeyValuePair.Create(Clean.Value, "Clean") + KeyValuePair.Create(string Yes, "Yes") + KeyValuePair.Create(string No, "No") + KeyValuePair.Create(string Clean, "Clean") |] |> adminView "post-edit" next ctx | Some _ -> return! Error.notAuthorized next ctx @@ -410,7 +410,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> List.length = List.length priorCats) then do! CategoryCache.update ctx do! addMessage ctx { UserMessage.success with Message = "Post saved successfully" } - return! redirectToGet $"admin/post/{post.Id.Value}/edit" next ctx + return! redirectToGet $"admin/post/{post.Id}/edit" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index c128864..72582ad 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -88,13 +88,13 @@ module CatchAll = module Asset = // GET /theme/{theme}/{**path} - let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task { + 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.ToDateTimeUtc ()) path asset.Data next ctx + | None -> return! Upload.sendFile (asset.UpdatedOn.ToDateTimeUtc()) path asset.Data next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index c1c840d..f192f76 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -107,7 +107,7 @@ 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 + Source = string Disk }) |> List.ofSeq with @@ -131,7 +131,7 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> hashForPage "Upload a File" |> withAntiCsrf ctx - |> addToHash "destination" (UploadDestination.toString ctx.WebLog.Uploads) + |> addToHash "destination" (string ctx.WebLog.Uploads) |> adminView "upload-new" next ctx @@ -144,29 +144,29 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then let upload = Seq.head ctx.Request.Form.Files let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName), - Path.GetExtension(upload.FileName).ToLowerInvariant ()) + Path.GetExtension(upload.FileName).ToLowerInvariant()) let now = Noda.now () let localNow = WebLog.localTime ctx.WebLog now let year = localNow.ToString "yyyy" let month = localNow.ToString "MM" - let! form = ctx.BindFormAsync () + let! form = ctx.BindFormAsync() - match UploadDestination.parse form.Destination with + match UploadDestination.Parse form.Destination with | Database -> - use stream = new MemoryStream () + 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 = now - Data = stream.ToArray () + Data = stream.ToArray() } do! ctx.Data.Upload.Add file | Disk -> - let fullPath = Path.Combine (uploadDir, ctx.WebLog.Slug, year, month) + let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month) let _ = Directory.CreateDirectory fullPath - use stream = new FileStream (Path.Combine (fullPath, fileName), FileMode.Create) + use stream = new FileStream(Path.Combine(fullPath, fileName), FileMode.Create) do! upload.CopyToAsync stream do! addMessage ctx { UserMessage.success with Message = $"File uploaded to {form.Destination} successfully" } diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 389fe56..f9a039d 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -48,22 +48,22 @@ open Microsoft.AspNetCore.Authentication.Cookies // POST /user/log-on let doLogOn : HttpHandler = fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let data = ctx.Data let! tryUser = data.WebLogUser.FindByEmail model.EmailAddress 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.Name, $"{user.FirstName} {user.LastName}") - Claim (ClaimTypes.GivenName, user.PreferredName) - Claim (ClaimTypes.Role, user.AccessLevel.Value) + Claim(ClaimTypes.NameIdentifier, string user.Id) + Claim(ClaimTypes.Name, $"{user.FirstName} {user.LastName}") + Claim(ClaimTypes.GivenName, user.PreferredName) + Claim(ClaimTypes.Role, string user.AccessLevel) } - let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) + let identity = ClaimsIdentity(claims, CookieAuthenticationDefaults.AuthenticationScheme) - do! ctx.SignInAsync (identity.AuthenticationType, ClaimsPrincipal identity, - AuthenticationProperties (IssuedUtc = DateTimeOffset.UtcNow)) + do! ctx.SignInAsync(identity.AuthenticationType, ClaimsPrincipal identity, + AuthenticationProperties(IssuedUtc = DateTimeOffset.UtcNow)) do! data.WebLogUser.SetLastSeen user.Id user.WebLogId do! addMessage ctx { UserMessage.success with @@ -110,10 +110,10 @@ let private showEdit (model : EditUserModel) : HttpHandler = fun next ctx -> |> withAntiCsrf ctx |> addToHash ViewContext.Model model |> addToHash "access_levels" [| - KeyValuePair.Create(Author.Value, "Author") - KeyValuePair.Create(Editor.Value, "Editor") - KeyValuePair.Create(WebLogAdmin.Value, "Web Log Admin") - if ctx.HasAccessLevel Administrator then KeyValuePair.Create(Administrator.Value, "Administrator") + KeyValuePair.Create(string Author, "Author") + KeyValuePair.Create(string Editor, "Editor") + KeyValuePair.Create(string WebLogAdmin, "Web Log Admin") + if ctx.HasAccessLevel Administrator then KeyValuePair.Create(string Administrator, "Administrator") |] |> adminBareView "user-edit" next ctx @@ -159,7 +159,7 @@ let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandl hashForPage "Edit Your Information" |> withAntiCsrf ctx |> addToHash ViewContext.Model model - |> addToHash "access_level" (user.AccessLevel.Value) + |> addToHash "access_level" (string user.AccessLevel) |> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn) |> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn (Instant.FromUnixTimeSeconds 0))) @@ -208,7 +208,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let tryUser = if model.IsNew then { WebLogUser.empty with - Id = WebLogUserId.create () + Id = WebLogUserId.Create() WebLogId = ctx.WebLog.Id CreatedOn = Noda.now () } |> someTask diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 8d0f68f..685c9dc 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -21,8 +21,8 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { | false, _ -> raise <| TimeZoneNotFoundException $"Cannot find IANA timezone for {local}" // Create the web log - let webLogId = WebLogId.create () - let userId = WebLogUserId.create () + let webLogId = WebLogId.Create() + let userId = WebLogUserId.Create() let homePageId = PageId.Create() let slug = Handlers.Upload.makeSlug args[2] @@ -37,7 +37,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { Name = args[2] Slug = slug UrlBase = args[1] - DefaultPage = homePageId.Value + DefaultPage = string homePageId TimeZone = timeZone } @@ -110,8 +110,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 $"{old.Value} -> {current.Value}" - | None -> eprintfn $"Cannot find current post for {current.Value}" + printfn $"{old} -> {current}" + | None -> eprintfn $"Cannot find current post for {current}" printfn "Done!" | None -> eprintfn $"No web log found at {urlBase}" } @@ -144,7 +144,7 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task { let! theme = Handlers.Admin.Theme.loadFromZip themeId copy data let fac = sp.GetRequiredService () let log = fac.CreateLogger "MyWebLog.Themes" - log.LogInformation $"{theme.Name} v{theme.Version} ({ThemeId.toString theme.Id}) loaded" + log.LogInformation $"{theme.Name} v{theme.Version} ({theme.Id}) loaded" | Error message -> eprintfn $"{message}" else eprintfn "Usage: myWebLog load-theme [theme-zip-file-name]" @@ -333,13 +333,13 @@ module Backup = return { archive with WebLog = { archive.WebLog with 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 } @@ -481,7 +481,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 {other.Value}, 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}" } diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index a48fc2e..450b383 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -15,7 +15,7 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger) 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 -- 2.45.1 From c3d615d10a5555cc18e35a51a943abae617aa43d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Dec 2023 14:05:45 -0500 Subject: [PATCH 017/123] WIP on module/member conversion Data types complete --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 1 - .../Postgres/PostgresCategoryData.fs | 6 +- .../Postgres/PostgresPageData.fs | 10 +- .../Postgres/PostgresPostData.fs | 20 +- .../Postgres/PostgresTagMapData.fs | 2 +- .../Postgres/PostgresWebLogData.fs | 2 +- .../Postgres/PostgresWebLogUserData.fs | 4 +- src/MyWebLog.Data/PostgresData.fs | 22 +- src/MyWebLog.Data/RethinkDbData.fs | 254 ++++++++-------- src/MyWebLog.Data/SQLite/Helpers.fs | 6 +- .../SQLite/SQLiteWebLogUserData.fs | 3 +- src/MyWebLog.Domain/DataTypes.fs | 284 ++++++++---------- src/MyWebLog.Domain/MyWebLog.Domain.fsproj | 1 + src/MyWebLog.Domain/SupportTypes.fs | 10 +- src/MyWebLog.Domain/ViewModels.fs | 144 +++++---- src/MyWebLog/Caches.fs | 10 +- src/MyWebLog/DotLiquidBespoke.fs | 76 ++--- src/MyWebLog/Handlers/Admin.fs | 10 +- src/MyWebLog/Handlers/Feed.fs | 73 ++--- src/MyWebLog/Handlers/Helpers.fs | 2 +- src/MyWebLog/Handlers/Page.fs | 7 +- src/MyWebLog/Handlers/Post.fs | 13 +- src/MyWebLog/Handlers/Routes.fs | 18 +- src/MyWebLog/Handlers/Upload.fs | 2 +- src/MyWebLog/Handlers/User.fs | 16 +- src/MyWebLog/Maintenance.fs | 6 +- 26 files changed, 481 insertions(+), 521 deletions(-) diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 707825c..442d62f 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -10,7 +10,6 @@ - diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index b78be64..a740ea8 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -23,7 +23,7 @@ type PostgresCategoryData(log: ILogger) = let findAllForView webLogId = backgroundTask { log.LogTrace "Category.findAllForView" let! cats = - Custom.list $"{selectWithCriteria Table.Category} ORDER BY LOWER(data ->> '{nameof Category.empty.Name}')" + Custom.list $"{selectWithCriteria Table.Category} ORDER BY LOWER(data ->> '{nameof Category.Empty.Name}')" [ webLogContains webLogId ] fromData let ordered = Utils.orderByHierarchy cats None None [] let counts = @@ -36,7 +36,7 @@ type PostgresCategoryData(log: ILogger) = |> Seq.map _.Id |> Seq.append (Seq.singleton it.Id) |> List.ofSeq - |> arrayContains (nameof Post.empty.CategoryIds) id + |> arrayContains (nameof Post.Empty.CategoryIds) id let postCount = Custom.scalar $"""SELECT COUNT(DISTINCT id) AS {countName} @@ -97,7 +97,7 @@ type PostgresCategoryData(log: ILogger) = () // Delete the category off all posts where it is assigned let! posts = - Custom.list $"SELECT data FROM {Table.Post} WHERE data -> '{nameof Post.empty.CategoryIds}' @> @id" + Custom.list $"SELECT data FROM {Table.Post} WHERE data -> '{nameof Post.Empty.CategoryIds}' @> @id" [ "@id", Query.jsonbDocParam [| string catId |] ] fromData if not (List.isEmpty posts) then let! _ = diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 7bf8c80..766fd14 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -37,7 +37,7 @@ type PostgresPageData (log: ILogger) = /// Get all pages for a web log (without text or revisions) let all webLogId = log.LogTrace "Page.all" - Custom.list $"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.empty.Title}')" + Custom.list $"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" [ webLogContains webLogId ] fromData /// Count all pages for the given web log @@ -86,10 +86,10 @@ type PostgresPageData (log: ILogger) = log.LogTrace "Page.findCurrentPermalink" if List.isEmpty permalinks then return None else - let linkSql, linkParam = arrayContains (nameof Page.empty.PriorPermalinks) string permalinks + let linkSql, linkParam = arrayContains (nameof Page.Empty.PriorPermalinks) string permalinks return! Custom.single - $"""SELECT data ->> '{nameof Page.empty.Permalink}' AS permalink + $"""SELECT data ->> '{nameof Page.Empty.Permalink}' AS permalink FROM page WHERE {Query.whereDataContains "@criteria"} AND {linkSql}""" [ webLogContains webLogId; linkParam ] Map.toPermalink @@ -109,7 +109,7 @@ type PostgresPageData (log: ILogger) = /// 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}')" + Custom.list $"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with IsInPageList = true |} ] pageWithoutText @@ -118,7 +118,7 @@ type PostgresPageData (log: ILogger) = log.LogTrace "Page.findPageOfPages" Custom.list $"{selectWithCriteria Table.Page} - ORDER BY LOWER(data->>'{nameof Page.empty.Title}') + ORDER BY LOWER(data->>'{nameof Page.Empty.Title}') LIMIT @pageSize OFFSET @toSkip" [ webLogContains webLogId; "@pageSize", Sql.int 26; "@toSkip", Sql.int ((pageNbr - 1) * 25) ] fromData diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index 7984d35..3ccef17 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -80,10 +80,10 @@ type PostgresPostData(log: ILogger) = log.LogTrace "Post.findCurrentPermalink" if List.isEmpty permalinks then return None else - let linkSql, linkParam = arrayContains (nameof Post.empty.PriorPermalinks) string permalinks + let linkSql, linkParam = arrayContains (nameof Post.Empty.PriorPermalinks) string permalinks return! Custom.single - $"""SELECT data ->> '{nameof Post.empty.Permalink}' AS permalink + $"""SELECT data ->> '{nameof Post.Empty.Permalink}' AS permalink FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"} AND {linkSql}""" [ webLogContains webLogId; linkParam ] Map.toPermalink @@ -103,11 +103,11 @@ type PostgresPostData(log: ILogger) = /// Get a page of categorized posts for the given web log (excludes revisions) let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = log.LogTrace "Post.findPageOfCategorizedPosts" - let catSql, catParam = arrayContains (nameof Post.empty.CategoryIds) string categoryIds + let catSql, catParam = arrayContains (nameof Post.Empty.CategoryIds) string categoryIds Custom.list $"{selectWithCriteria Table.Post} AND {catSql} - ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC + ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} catParam @@ -118,8 +118,8 @@ type PostgresPostData(log: ILogger) = log.LogTrace "Post.findPageOfPosts" Custom.list $"{selectWithCriteria Table.Post} - ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC NULLS FIRST, - data ->> '{nameof Post.empty.UpdatedOn}' + 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 @@ -128,7 +128,7 @@ type PostgresPostData(log: ILogger) = log.LogTrace "Post.findPageOfPublishedPosts" Custom.list $"{selectWithCriteria Table.Post} - ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC + ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} ] fromData @@ -138,8 +138,8 @@ type PostgresPostData(log: ILogger) = log.LogTrace "Post.findPageOfTaggedPosts" Custom.list $"{selectWithCriteria Table.Post} - AND data['{nameof Post.empty.Tags}'] @> @tag - ORDER BY data ->> '{nameof Post.empty.PublishedOn}' DESC + AND data['{nameof Post.Empty.Tags}'] @> @tag + ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} "@tag", Query.jsonbDocParam [| tag |] @@ -152,7 +152,7 @@ type PostgresPostData(log: ILogger) = "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn)[..19]) ] - let pubField = nameof Post.empty.PublishedOn + let pubField = nameof Post.Empty.PublishedOn let! older = Custom.list $"{selectWithCriteria Table.Post} diff --git a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs index 100523a..c252f7b 100644 --- a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -40,7 +40,7 @@ type PostgresTagMapData (log : ILogger) = /// 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 + let tagSql, tagParam = arrayContains (nameof TagMap.Empty.Tag) id tags Custom.list $"{selectWithCriteria Table.TagMap} AND {tagSql}" [ webLogContains webLogId; tagParam ] fromData diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index 0efc85d..7015724 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -23,7 +23,7 @@ type PostgresWebLogData (log : ILogger) = log.LogTrace "WebLog.delete" Custom.nonQuery $"""DELETE FROM {Table.PostComment} - WHERE data ->> '{nameof Comment.empty.PostId}' IN + WHERE data ->> '{nameof Comment.Empty.PostId}' IN (SELECT id FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"}); {Query.Delete.byContains Table.Post}; {Query.Delete.byContains Table.Page}; diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs index dba0985..22090ce 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -45,7 +45,7 @@ type PostgresWebLogUserData (log : ILogger) = let findByWebLog webLogId = log.LogTrace "WebLogUser.findByWebLog" Custom.list - $"{selectWithCriteria Table.WebLogUser} ORDER BY LOWER(data->>'{nameof WebLogUser.empty.PreferredName}')" + $"{selectWithCriteria Table.WebLogUser} ORDER BY LOWER(data->>'{nameof WebLogUser.Empty.PreferredName}')" [ webLogContains webLogId ] fromData /// Find the names of users by their IDs for the given web log @@ -55,7 +55,7 @@ type PostgresWebLogUserData (log : ILogger) = let! users = Custom.list $"{selectWithCriteria Table.WebLogUser} {idSql}" (webLogContains webLogId :: idParams) fromData - return users |> List.map (fun u -> { Name = string u.Id; Value = WebLogUser.displayName u }) + return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) } /// Restore users from a backup diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 0b788b0..1c01195 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -58,10 +58,10 @@ type PostgresData (log : ILogger, ser : JsonSerializer) = // Page tables if needsTable Table.Page then Definition.createTable Table.Page - $"CREATE INDEX page_web_log_idx ON {Table.Page} ((data ->> '{nameof Page.empty.WebLogId}'))" - $"CREATE INDEX page_author_idx ON {Table.Page} ((data ->> '{nameof Page.empty.AuthorId}'))" + $"CREATE INDEX page_web_log_idx ON {Table.Page} ((data ->> '{nameof Page.Empty.WebLogId}'))" + $"CREATE INDEX page_author_idx ON {Table.Page} ((data ->> '{nameof Page.Empty.AuthorId}'))" $"CREATE INDEX page_permalink_idx ON {Table.Page} - ((data ->> '{nameof Page.empty.WebLogId}'), (data ->> '{nameof Page.empty.Permalink}'))" + ((data ->> '{nameof Page.Empty.WebLogId}'), (data ->> '{nameof Page.Empty.Permalink}'))" if needsTable Table.PageRevision then $"CREATE TABLE {Table.PageRevision} ( page_id TEXT NOT NULL REFERENCES {Table.Page} (id) ON DELETE CASCADE, @@ -72,15 +72,15 @@ type PostgresData (log : ILogger, ser : JsonSerializer) = // Post tables if needsTable Table.Post then Definition.createTable Table.Post - $"CREATE INDEX post_web_log_idx ON {Table.Post} ((data ->> '{nameof Post.empty.WebLogId}'))" - $"CREATE INDEX post_author_idx ON {Table.Post} ((data ->> '{nameof Post.empty.AuthorId}'))" + $"CREATE INDEX post_web_log_idx ON {Table.Post} ((data ->> '{nameof Post.Empty.WebLogId}'))" + $"CREATE INDEX post_author_idx ON {Table.Post} ((data ->> '{nameof Post.Empty.AuthorId}'))" $"CREATE INDEX post_status_idx ON {Table.Post} - ((data ->> '{nameof Post.empty.WebLogId}'), (data ->> '{nameof Post.empty.Status}'), - (data ->> '{nameof Post.empty.UpdatedOn}'))" + ((data ->> '{nameof Post.Empty.WebLogId}'), (data ->> '{nameof Post.Empty.Status}'), + (data ->> '{nameof Post.Empty.UpdatedOn}'))" $"CREATE INDEX post_permalink_idx ON {Table.Post} - ((data ->> '{nameof Post.empty.WebLogId}'), (data ->> '{nameof Post.empty.Permalink}'))" - $"CREATE INDEX post_category_idx ON {Table.Post} USING GIN ((data['{nameof Post.empty.CategoryIds}']))" - $"CREATE INDEX post_tag_idx ON {Table.Post} USING GIN ((data['{nameof Post.empty.Tags}']))" + ((data ->> '{nameof Post.Empty.WebLogId}'), (data ->> '{nameof Post.Empty.Permalink}'))" + $"CREATE INDEX post_category_idx ON {Table.Post} USING GIN ((data['{nameof Post.Empty.CategoryIds}']))" + $"CREATE INDEX post_tag_idx ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))" if needsTable Table.PostRevision then $"CREATE TABLE {Table.PostRevision} ( post_id TEXT NOT NULL REFERENCES {Table.Post} (id) ON DELETE CASCADE, @@ -90,7 +90,7 @@ type PostgresData (log : ILogger, ser : JsonSerializer) = if needsTable Table.PostComment then Definition.createTable Table.PostComment $"CREATE INDEX post_comment_post_idx ON {Table.PostComment} - ((data ->> '{nameof Comment.empty.PostId}'))" + ((data ->> '{nameof Comment.Empty.PostId}'))" // Tag map table if needsTable Table.TagMap then diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index acda3a6..068b2b1 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -97,11 +97,11 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger row[nameof ThemeAsset.empty.Id].Match keyPrefix :> obj + 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].Without [| nameof ThemeTemplate.Empty.Text |] |} + {| Templates = row[nameof Theme.Empty.Templates].Without [| nameof ThemeTemplate.Empty.Text |] |} /// Ensure field indexes exist, as well as special indexes for selected tables let ensureIndexes table fields = backgroundTask { @@ -112,27 +112,27 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger 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 (fun row -> row[priorIdx].Downcase() :> obj) [ Multi ] write; withRetryOnce; ignoreResult conn } // Post needs indexes by category and tag (used for counting and retrieving posts) if Table.Post = table then - for idx in [ 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 { @@ -147,7 +147,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger - [| 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 @@ -155,7 +155,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger - [| 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 @@ -165,7 +165,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger - [| 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 @@ -175,7 +175,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger - [| 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 } } @@ -226,7 +226,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj ] + update [ nameof WebLog.Empty.RedirectRules, [] :> obj ] write; withRetryOnce; ignoreResult conn } @@ -271,15 +271,15 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Category - getAll [ webLogId ] (nameof Category.empty.WebLogId) + getAll [ webLogId ] (nameof Category.Empty.WebLogId) count result; withRetryDefault conn } member _.CountTopLevel webLogId = rethink { 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 count result; withRetryDefault conn } @@ -287,8 +287,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 [] @@ -304,8 +304,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger List.ofSeq let! count = rethink { 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 @@ -335,7 +335,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Category - getAll [ webLogId ] (nameof Category.empty.WebLogId) + getAll [ webLogId ] (nameof Category.Empty.WebLogId) result; withRetryDefault conn } @@ -345,24 +345,24 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Category - filter (nameof Category.empty.ParentId) catId + 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 ] + 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 = r.Array(row[nameof Post.Empty.CategoryIds]).Remove catId |} :> obj) write; withRetryDefault; ignoreResult conn } // Delete the category itself @@ -408,26 +408,26 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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) + 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) result; withRetryDefault conn } member _.CountAll webLogId = rethink { withTable Table.Page - getAll [ webLogId ] (nameof Page.empty.WebLogId) + getAll [ webLogId ] (nameof Page.Empty.WebLogId) count result; withRetryDefault conn } member _.CountListed webLogId = rethink { 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 } @@ -436,7 +436,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } @@ -447,7 +447,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Page get pageId - without [ nameof Page.empty.PriorPermalinks; nameof Page.empty.Revisions ] + without [ nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] resultOption; withRetryOptionDefault } |> verifyWebLog webLogId (fun it -> it.WebLogId) <| conn @@ -455,8 +455,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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) + without [ nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] limit 1 result; withRetryDefault } @@ -466,9 +466,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } @@ -486,26 +486,26 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Page - getAll [ webLogId ] (nameof Page.empty.WebLogId) + getAll [ webLogId ] (nameof Page.Empty.WebLogId) resultCursor; withRetryCursorDefault; toList conn } member _.FindListed webLogId = rethink { 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 ] + without [ nameof Page.Empty.Text; nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] + orderBy (nameof Page.Empty.Title) result; withRetryDefault conn } member _.FindPageOfPages webLogId pageNbr = rethink { 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) + without [ nameof Page.Empty.Metadata + nameof Page.Empty.PriorPermalinks + nameof Page.Empty.Revisions ] + orderByFunc (fun row -> row[nameof Page.Empty.Title].Downcase()) skip ((pageNbr - 1) * 25) limit 25 result; withRetryDefault conn @@ -543,7 +543,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj ] + update [ nameof Page.Empty.PriorPermalinks, permalinks :> obj ] write; withRetryDefault; ignoreResult conn } return true @@ -562,8 +562,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } @@ -572,7 +572,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } @@ -583,7 +583,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Post get postId - without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ] + without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] resultOption; withRetryOptionDefault } |> verifyWebLog webLogId (fun p -> p.WebLogId) <| conn @@ -591,8 +591,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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) + without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] limit 1 result; withRetryDefault } @@ -610,9 +610,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } @@ -622,18 +622,18 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 { 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 ] + without [ nameof Post.Empty.PriorPermalinks; 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 @@ -641,10 +641,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Post - getAll [ webLogId ] (nameof Post.empty.WebLogId) - without [ nameof Post.empty.PriorPermalinks; nameof Post.empty.Revisions ] + getAll [ webLogId ] (nameof Post.Empty.WebLogId) + without [ nameof Post.Empty.PriorPermalinks; 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 @@ -652,10 +652,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 + without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + orderByDescending (nameof Post.Empty.PublishedOn) skip ((pageNbr - 1) * postsPerPage) limit (postsPerPage + 1) result; withRetryDefault conn @@ -663,11 +663,11 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 ] + without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + orderByDescending (nameof Post.Empty.PublishedOn) skip ((pageNbr - 1) * postsPerPage) limit (postsPerPage + 1) result; withRetryDefault conn @@ -677,10 +677,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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) + without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + orderByDescending (nameof Post.Empty.PublishedOn) limit 1 result; withRetryDefault } @@ -688,10 +688,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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) + without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + orderBy (nameof Post.Empty.PublishedOn) limit 1 result; withRetryDefault } @@ -720,15 +720,15 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Post get postId - without [ nameof Post.empty.Revisions; nameof Post.empty.PriorPermalinks ] + without [ nameof Post.Empty.Revisions; nameof Post.Empty.PriorPermalinks ] resultOption; withRetryOptionDefault } - |> verifyWebLog webLogId (fun p -> p.WebLogId)) conn with + |> verifyWebLog webLogId (_.WebLogId)) conn 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 @@ -743,7 +743,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } @@ -756,7 +756,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger verifyWebLog webLogId (fun tm -> tm.WebLogId) <| conn + |> verifyWebLog webLogId (_.WebLogId) <| conn member _.FindByUrlValue urlValue webLogId = rethink { @@ -769,9 +769,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.TagMap - between [| webLogId :> obj; r.Minval () |] [| webLogId :> obj; r.Maxval () |] + 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 } @@ -803,16 +803,16 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Theme - filter (fun row -> row[nameof Theme.empty.Id].Ne "admin" :> obj) + filter (fun row -> row[nameof Theme.Empty.Id].Ne "admin" :> obj) merge withoutTemplateText - orderBy (nameof Theme.empty.Id) + orderBy (nameof Theme.Empty.Id) result; withRetryDefault conn } member _.Exists themeId = backgroundTask { let! count = rethink { withTable Table.Theme - filter (nameof Theme.empty.Id) themeId + filter (nameof Theme.Empty.Id) themeId count result; withRetryDefault conn } @@ -859,7 +859,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.ThemeAsset - without [ nameof ThemeAsset.empty.Data ] + without [ nameof ThemeAsset.Empty.Data ] result; withRetryDefault conn } @@ -874,7 +874,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.ThemeAsset filter (matchAssetByThemeId themeId) - without [ nameof ThemeAsset.empty.Data ] + without [ nameof ThemeAsset.Empty.Data ] result; withRetryDefault conn } @@ -931,9 +931,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Upload - between [| webLogId :> obj; r.Minval () |] [| webLogId :> obj; r.Maxval () |] + between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |] [ Index Index.WebLogAndPath ] - without [ nameof Upload.empty.Data ] + without [ nameof Upload.Empty.Data ] resultCursor; withRetryCursorDefault; toList conn } @@ -973,22 +973,22 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } // Tag mappings do not have a straightforward webLogId index do! rethink { withTable Table.TagMap - between [| webLogId :> obj; r.Minval () |] [| webLogId :> obj; r.Maxval () |] + between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |] [ Index Index.WebLogAndTag ] delete write; withRetryOnce; ignoreResult conn @@ -996,7 +996,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj; r.Minval () |] [| webLogId :> obj; r.Maxval () |] + between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |] [ Index Index.WebLogAndPath ] delete write; withRetryOnce; ignoreResult conn @@ -1004,7 +1004,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.WebLog - getAll [ url ] (nameof WebLog.empty.UrlBase) + getAll [ url ] (nameof WebLog.Empty.UrlBase) limit 1 result; withRetryDefault } @@ -1034,14 +1034,14 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj ] + 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 } @@ -1085,15 +1085,15 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger let! pageCount = rethink { 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 { 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 } @@ -1121,8 +1121,8 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 } @@ -1130,10 +1130,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { 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 = string u.Id; Value = WebLogUser.displayName u }) + return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) } member _.Restore users = backgroundTask { @@ -1151,7 +1151,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj ] + update [ nameof WebLogUser.Empty.LastSeenOn, Noda.now () :> obj ] write; withRetryOnce; ignoreResult conn } | None -> () @@ -1196,19 +1196,19 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.DbVersion limit 1 result; withRetryOnce conn } - do! migrate (List.tryHead version |> Option.map (fun x -> x.Id)) + do! migrate (List.tryHead version |> Option.map _.Id) } diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index b37c7bc..d7031fb 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -232,7 +232,7 @@ module Map = /// Create a page from the current row in the given data reader let toPage ser rdr : Page = - { Page.empty with + { Page.Empty with Id = getString "id" rdr |> PageId WebLogId = getString "web_log_id" rdr |> WebLogId AuthorId = getString "author_id" rdr |> WebLogUserId @@ -250,7 +250,7 @@ module Map = /// Create a post from the current row in the given data reader let toPost ser rdr : Post = - { Post.empty with + { Post.Empty with Id = getString "id" rdr |> PostId WebLogId = getString "web_log_id" rdr |> WebLogId AuthorId = getString "author_id" rdr |> WebLogUserId @@ -283,7 +283,7 @@ module Map = /// Create a theme from the current row in the given data reader (excludes templates) let toTheme rdr : Theme = - { Theme.empty with + { Theme.Empty with Id = getString "id" rdr |> ThemeId Name = getString "name" rdr Version = getString "version" rdr diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 20a6056..7c0f242 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -96,8 +96,7 @@ type SQLiteWebLogUserData(conn: SqliteConnection) = addWebLogId cmd webLogId cmd.Parameters.AddRange nameParams use! rdr = cmd.ExecuteReaderAsync () - return - toList Map.toWebLogUser rdr |> List.map (fun u -> { Name = string u.Id; Value = WebLogUser.displayName u }) + return toList Map.toWebLogUser rdr |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) } /// Restore users from a backup diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index 01c6a39..413702a 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -8,29 +8,26 @@ open NodaTime [] type Category = { /// The ID of the category - Id : CategoryId + Id: CategoryId /// The ID of the web log to which the category belongs - WebLogId : WebLogId + WebLogId: WebLogId /// The displayed name - Name : string + Name: string /// The slug (used in category URLs) - Slug : string + Slug: string /// A longer description of the category - Description : string option + Description: string option /// The parent ID of this category (if a subcategory) - ParentId : CategoryId option -} - -/// Functions to support categories -module Category = + ParentId: CategoryId option +} with /// An empty category - let empty = { + static member Empty = { Id = CategoryId.Empty WebLogId = WebLogId.Empty Name = "" @@ -44,38 +41,35 @@ module Category = [] type Comment = { /// The ID of the comment - Id : CommentId + Id: CommentId /// The ID of the post to which this comment applies - PostId : PostId + PostId: PostId /// The ID of the comment to which this comment is a reply - InReplyToId : CommentId option + InReplyToId: CommentId option /// The name of the commentor - Name : string + Name: string /// The e-mail address of the commentor - Email : string + Email: string /// The URL of the commentor's personal website - Url : string option + Url: string option /// The status of the comment - Status : CommentStatus + Status: CommentStatus /// When the comment was posted - PostedOn : Instant + PostedOn: Instant /// The text of the comment - Text : string -} - -/// Functions to support comments -module Comment = + Text: string +} with /// An empty comment - let empty = { + static member Empty = { Id = CommentId.Empty PostId = PostId.Empty InReplyToId = None @@ -92,50 +86,47 @@ module Comment = [] type Page = { /// The ID of this page - Id : PageId + Id: PageId /// The ID of the web log to which this page belongs - WebLogId : WebLogId + WebLogId: WebLogId /// The ID of the author of this page - AuthorId : WebLogUserId + AuthorId: WebLogUserId /// The title of the page - Title : string + Title: string /// The link at which this page is displayed - Permalink : Permalink + Permalink: Permalink /// When this page was published - PublishedOn : Instant + PublishedOn: Instant /// When this page was last updated - UpdatedOn : Instant + UpdatedOn: Instant /// Whether this page shows as part of the web log's navigation - IsInPageList : bool + IsInPageList: bool /// The template to use when rendering this page - Template : string option + Template: string option /// The current text of the page - Text : string + Text: string /// Metadata for this page - Metadata : MetaItem list + Metadata: MetaItem list /// Permalinks at which this page may have been previously served (useful for migrated content) - PriorPermalinks : Permalink list + PriorPermalinks: Permalink list /// Revisions of this page - Revisions : Revision list -} - -/// Functions to support pages -module Page = + Revisions: Revision list +} with /// An empty page - let empty = { + static member Empty = { Id = PageId.Empty WebLogId = WebLogId.Empty AuthorId = WebLogUserId.Empty @@ -156,59 +147,56 @@ module Page = [] type Post = { /// The ID of this post - Id : PostId + Id: PostId /// The ID of the web log to which this post belongs - WebLogId : WebLogId + WebLogId: WebLogId /// The ID of the author of this post - AuthorId : WebLogUserId + AuthorId: WebLogUserId /// The status - Status : PostStatus + Status: PostStatus /// The title - Title : string + Title: string /// The link at which the post resides - Permalink : Permalink + Permalink: Permalink /// The instant on which the post was originally published - PublishedOn : Instant option + PublishedOn: Instant option /// The instant on which the post was last updated - UpdatedOn : Instant + UpdatedOn: Instant /// The template to use in displaying the post - Template : string option + Template: string option /// The text of the post in HTML (ready to display) format - Text : string + Text: string /// The Ids of the categories to which this is assigned - CategoryIds : CategoryId list + CategoryIds: CategoryId list /// The tags for the post - Tags : string list + Tags: string list /// Podcast episode information for this post - Episode : Episode option + Episode: Episode option /// Metadata for the post - Metadata : MetaItem list + Metadata: MetaItem list /// Permalinks at which this post may have been previously served (useful for migrated content) - PriorPermalinks : Permalink list + PriorPermalinks: Permalink list /// The revisions for this post - Revisions : Revision list -} - -/// Functions to support posts -module Post = + Revisions: Revision list +} with /// An empty post - let empty = { + static member Empty = { Id = PostId.Empty WebLogId = WebLogId.Empty AuthorId = WebLogUserId.Empty @@ -229,25 +217,23 @@ module Post = /// 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 - Id : TagMapId + Id: TagMapId /// The ID of the web log to which this tag mapping belongs - WebLogId : WebLogId + WebLogId: WebLogId /// The tag which should be mapped to a different value in links - Tag : string + Tag: string /// The value by which the tag should be linked - UrlValue : string -} - -/// Functions to support tag mappings -module TagMap = + UrlValue: string +} with /// An empty tag mapping - let empty = { + static member Empty = { Id = TagMapId.Empty WebLogId = WebLogId.Empty Tag = "" @@ -256,26 +242,24 @@ module TagMap = /// A theme +[] type Theme = { /// The ID / path of the theme - Id : ThemeId + Id: ThemeId /// A long name of the theme - Name : string + Name: string /// The version of the theme - Version : string + Version: string /// The templates for this theme Templates: ThemeTemplate list -} - -/// Functions to support themes -module Theme = +} with /// An empty theme - let empty = { - Id = ThemeId "" + static member Empty = { + Id = ThemeId.Empty Name = "" Version = "" Templates = [] @@ -283,51 +267,47 @@ module Theme = /// A theme asset (a file served as part of a theme, at /themes/[theme]/[asset-path]) +[] type ThemeAsset = { /// The ID of the asset (consists of theme and path) - Id : ThemeAssetId + Id: ThemeAssetId /// The updated date (set from the file date from the ZIP archive) - UpdatedOn : Instant + 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 "", "") + static member Empty = { + Id = ThemeAssetId.Empty UpdatedOn = Noda.epoch Data = [||] } /// An uploaded file +[] type Upload = { /// The ID of the upload - Id : UploadId + Id: UploadId /// The ID of the web log to which this upload belongs - WebLogId : WebLogId + WebLogId: WebLogId /// The link at which this upload is served - Path : Permalink + Path: Permalink /// The updated date/time for this upload - UpdatedOn : Instant + 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 = { + static member Empty = { Id = UploadId.Empty WebLogId = WebLogId.Empty Path = Permalink.Empty @@ -336,54 +316,53 @@ module Upload = } +open Newtonsoft.Json + /// A web log [] type WebLog = { /// The ID of the web log - Id : WebLogId + Id: WebLogId /// The name of the web log - Name : string + Name: string /// The slug of the web log - Slug : string + Slug: string /// A subtitle for the web log - Subtitle : string option + Subtitle: string option /// The default page ("posts" or a page Id) - DefaultPage : string + DefaultPage: string /// The number of posts to display on pages of posts - PostsPerPage : int + PostsPerPage: int /// The ID of the theme (also the path within /themes) - ThemeId : ThemeId + ThemeId: ThemeId /// The URL base - UrlBase : string + UrlBase: string /// The time zone in which dates/times should be displayed - TimeZone : string + TimeZone: string /// The RSS options for this web log - Rss : RssOptions + Rss: RssOptions /// Whether to automatically load htmx - AutoHtmx : bool + AutoHtmx: bool /// Where uploads are placed - Uploads : UploadDestination + Uploads: UploadDestination /// Redirect rules for this weblog - RedirectRules : RedirectRule list -} - -/// Functions to support web logs -module WebLog = + RedirectRules: RedirectRule list +} with /// An empty web log - let empty = { + static member Empty = { Id = WebLogId.Empty Name = "" Slug = "" @@ -399,24 +378,23 @@ module WebLog = 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) + [] + member this.ExtraPath = + let path = this.UrlBase.Split("://").[1].Split "/" + if path.Length > 1 then $"""/{String.Join("/", path |> Array.skip 1)}""" else "" /// Generate an absolute URL for the given link - let absoluteUrl webLog (permalink: Permalink) = - $"{webLog.UrlBase}/{permalink}" - + member this.AbsoluteUrl(permalink: Permalink) = + $"{this.UrlBase}/{permalink}" + /// Generate a relative URL for the given link - let relativeUrl webLog (permalink: Permalink) = - let _, leadPath = hostAndPath webLog - $"{leadPath}/{permalink}" + member this.RelativeUrl(permalink: Permalink) = + $"{this.ExtraPath}/{permalink}" /// Convert an Instant (UTC reference) to the web log's local date/time - let localTime webLog (date: Instant) = - match DateTimeZoneProviders.Tzdb[webLog.TimeZone] with + member this.LocalTime(date: Instant) = + match DateTimeZoneProviders.Tzdb[this.TimeZone] with | null -> date.ToDateTimeUtc() | tz -> date.InZone(tz).ToDateTimeUnspecified() @@ -425,44 +403,41 @@ module WebLog = [] type WebLogUser = { /// The ID of the user - Id : WebLogUserId + Id: WebLogUserId /// The ID of the web log to which this user belongs - WebLogId : WebLogId + WebLogId: WebLogId /// The user name (e-mail address) - Email : string + Email: string /// The user's first name - FirstName : string + FirstName: string /// The user's last name - LastName : string + LastName: string /// The user's preferred name - PreferredName : string + PreferredName: string /// The hash of the user's password - PasswordHash : string + PasswordHash: string /// The URL of the user's personal site - Url : string option + Url: string option /// The user's access level - AccessLevel : AccessLevel + AccessLevel: AccessLevel /// When the user was created - CreatedOn : Instant + CreatedOn: Instant /// When the user last logged on - LastSeenOn : Instant option -} - -/// Functions to support web log users -module WebLogUser = + LastSeenOn: Instant option +} with /// An empty web log user - let empty = { + static member Empty = { Id = WebLogUserId.Empty WebLogId = WebLogId.Empty Email = "" @@ -477,12 +452,7 @@ module WebLogUser = } /// 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 = - user.AccessLevel.HasAccess level + [] + member this.DisplayName = + (seq { match this.PreferredName with "" -> this.FirstName | n -> n; " "; this.LastName } + |> Seq.reduce (+)).Trim() diff --git a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj index 048dc6c..9460006 100644 --- a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj +++ b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj @@ -9,6 +9,7 @@ + diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index ee3c01c..8a9c98b 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -72,13 +72,11 @@ type AccessLevel = /// Does a given access level allow an action that requires a certain access level? member this.HasAccess(needed: AccessLevel) = - // TODO: Move this to user where it seems to belong better... let weights = [ Author, 10 Editor, 20 WebLogAdmin, 30 - Administrator, 40 - ] + Administrator, 40 ] |> Map.ofList weights[needed] <= weights[this] @@ -639,6 +637,9 @@ type TagMapId = type ThemeId = | ThemeId of string + /// An empty theme ID + static member Empty = ThemeId "" + /// The string representation of a theme ID override this.ToString() = match this with ThemeId it -> it @@ -649,6 +650,9 @@ type ThemeId = type ThemeAssetId = | ThemeAssetId of ThemeId * string + /// An empty theme asset ID + static member Empty = ThemeAssetId(ThemeId.Empty, "") + /// Convert a string into a theme asset ID static member Parse(it : string) = let themeIdx = it.IndexOf "/" diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 2005de8..d8ec0b4 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -103,46 +103,46 @@ module DisplayCustomFeed = /// Details about a page used to display page lists [] -type DisplayPage = - { /// The ID of this page - Id : string +type DisplayPage = { + /// The ID of this page + Id: string - /// The ID of the author of this page - AuthorId : string - - /// The title of the page - Title : string + /// The ID of the author of this page + AuthorId: string + + /// The title of the page + Title: string - /// The link at which this page is displayed - Permalink : string + /// The link at which this page is displayed + Permalink: string - /// When this page was published - PublishedOn : DateTime + /// When this page was published + PublishedOn: DateTime - /// When this page was last updated - UpdatedOn : DateTime + /// When this page was last updated + UpdatedOn: DateTime - /// Whether this page shows as part of the web log's navigation - IsInPageList : bool - - /// Is this the default page? - IsDefault : bool - - /// The text of the page - Text : string - - /// The metadata for the page - Metadata : MetaItem list - } + /// Whether this page shows as part of the web log's navigation + IsInPageList: bool + + /// Is this the default page? + IsDefault: bool + + /// The text of the page + Text: string + + /// The metadata for the page + Metadata: MetaItem list +} with /// Create a minimal display page (no text or metadata) from a database page - static member FromPageMinimal webLog (page: Page) = { + static member FromPageMinimal (webLog: WebLog) (page: Page) = { Id = string page.Id AuthorId = string page.AuthorId Title = page.Title Permalink = string page.Permalink - PublishedOn = WebLog.localTime webLog page.PublishedOn - UpdatedOn = WebLog.localTime webLog page.UpdatedOn + PublishedOn = webLog.LocalTime page.PublishedOn + UpdatedOn = webLog.LocalTime page.UpdatedOn IsInPageList = page.IsInPageList IsDefault = string page.Id = webLog.DefaultPage Text = "" @@ -150,18 +150,10 @@ type DisplayPage = } /// Create a display page from a database page - static member FromPage webLog (page : Page) = - let _, extra = WebLog.hostAndPath webLog - { Id = string page.Id - AuthorId = string page.AuthorId - Title = page.Title - Permalink = string page.Permalink - PublishedOn = WebLog.localTime webLog page.PublishedOn - UpdatedOn = WebLog.localTime webLog page.UpdatedOn - IsInPageList = page.IsInPageList - IsDefault = string page.Id = webLog.DefaultPage - Text = addBaseToRelativeUrls extra page.Text - Metadata = page.Metadata + static member FromPage webLog page = + { DisplayPage.FromPageMinimal webLog page with + Text = addBaseToRelativeUrls webLog.ExtraPath page.Text + Metadata = page.Metadata } @@ -169,22 +161,22 @@ type DisplayPage = [] type DisplayRevision = { /// The as-of date/time for the revision - AsOf : DateTime + AsOf: DateTime /// The as-of date/time for the revision in the web log's local time zone - AsOfLocal : DateTime + AsOfLocal: DateTime /// The format of the text of the revision - Format : string + Format: string } /// Functions to support displaying revisions module DisplayRevision = /// Create a display revision from an actual revision - let fromRevision webLog (rev : Revision) = + let fromRevision (webLog: WebLog) (rev : Revision) = { AsOf = rev.AsOf.ToDateTimeUtc () - AsOfLocal = WebLog.localTime webLog rev.AsOf + AsOfLocal = webLog.LocalTime rev.AsOf Format = rev.Text.SourceType } @@ -250,13 +242,13 @@ type DisplayUpload = { module DisplayUpload = /// Create a display uploaded file - let fromUpload webLog (source: UploadDestination) (upload: Upload) = + let fromUpload (webLog: WebLog) (source: UploadDestination) (upload: Upload) = let path = string upload.Path let name = Path.GetFileName path { Id = string upload.Id Name = name Path = path.Replace(name, "") - UpdatedOn = Some (WebLog.localTime webLog upload.UpdatedOn) + UpdatedOn = Some (webLog.LocalTime upload.UpdatedOn) Source = string source } @@ -296,17 +288,17 @@ type DisplayUser = { module DisplayUser = /// Construct a displayed user from a web log user - let fromUser webLog (user: WebLogUser) = - { Id = string user.Id - Email = user.Email - FirstName = user.FirstName - LastName = user.LastName - PreferredName = user.PreferredName - Url = defaultArg user.Url "" - AccessLevel = string user.AccessLevel - CreatedOn = WebLog.localTime webLog user.CreatedOn - LastSeenOn = user.LastSeenOn |> Option.map (WebLog.localTime webLog) |> Option.toNullable - } + let fromUser (webLog: WebLog) (user: WebLogUser) = { + Id = string user.Id + Email = user.Email + FirstName = user.FirstName + LastName = user.LastName + PreferredName = user.PreferredName + Url = defaultArg user.Url "" + AccessLevel = string user.AccessLevel + CreatedOn = webLog.LocalTime user.CreatedOn + LastSeenOn = user.LastSeenOn |> Option.map webLog.LocalTime |> Option.toNullable + } /// View model for editing categories @@ -708,7 +700,7 @@ type EditPostModel = { } with /// Create an edit model from an existing past - static member fromPost webLog (post: Post) = + static member fromPost (webLog: WebLog) (post: Post) = let latest = match post.Revisions |> List.sortByDescending _.AsOf |> List.tryHead with | Some rev -> rev @@ -728,7 +720,7 @@ type EditPostModel = { MetaNames = post.Metadata |> List.map _.Name |> Array.ofList MetaValues = post.Metadata |> List.map _.Value |> Array.ofList SetPublished = false - PubOverride = post.PublishedOn |> Option.map (WebLog.localTime webLog) |> Option.toNullable + PubOverride = post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable SetUpdated = false IsEpisode = Option.isSome post.Episode Media = episode.Media @@ -1111,22 +1103,20 @@ type PostListItem = { } with /// Create a post list item from a post - static member fromPost (webLog: WebLog) (post: Post) = - let _, extra = WebLog.hostAndPath webLog - let inTZ = WebLog.localTime webLog - { Id = string post.Id - AuthorId = string post.AuthorId - Status = string post.Status - Title = post.Title - Permalink = string post.Permalink - PublishedOn = post.PublishedOn |> Option.map inTZ |> Option.toNullable - UpdatedOn = inTZ post.UpdatedOn - Text = addBaseToRelativeUrls extra post.Text - CategoryIds = post.CategoryIds |> List.map string - Tags = post.Tags - Episode = post.Episode - Metadata = post.Metadata - } + static member fromPost (webLog: WebLog) (post: Post) = { + Id = string post.Id + AuthorId = string post.AuthorId + Status = string post.Status + Title = post.Title + Permalink = string post.Permalink + PublishedOn = post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable + UpdatedOn = webLog.LocalTime post.UpdatedOn + Text = addBaseToRelativeUrls webLog.ExtraPath post.Text + CategoryIds = post.CategoryIds |> List.map string + Tags = post.Tags + Episode = post.Episode + Metadata = post.Metadata + } /// View model for displaying posts diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index 74b09d9..9230cae 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -53,7 +53,7 @@ module Extensions = /// Does the current user have the requested level of access? member this.HasAccessLevel level = - defaultArg (this.UserAccessLevel |> Option.map (fun it -> it.HasAccess level)) false + defaultArg (this.UserAccessLevel |> Option.map _.HasAccess(level)) false open System.Collections.Concurrent @@ -93,13 +93,13 @@ module WebLogCache = _redirectCache[webLog.Id] <- webLog.RedirectRules |> List.map (fun it -> - let relUrl = Permalink >> WebLog.relativeUrl webLog + 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.Substring 1)}" else it.From - RegEx (new Regex (pattern, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo) + 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)) + Text(relUrl it.From, urlTo)) /// Get all cached web logs let all () = diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 2718d43..8cfdc9d 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -21,7 +21,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,64 +29,64 @@ 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 +type AbsoluteLinkFilter() = + static member AbsoluteLink(ctx: Context, item: obj) = + permalink item ctx.WebLog.AbsoluteUrl /// A filter to generate a link with posts categorized under the given category -type CategoryLinkFilter () = - static member CategoryLink (ctx : Context, catObj : obj) = +type CategoryLinkFilter() = + static member CategoryLink(ctx: Context, catObj: obj) = match catObj with | :? DisplayCategory as cat -> Some cat.Slug | :? DropProxy as proxy -> Option.ofObj proxy["Slug"] |> Option.map string | _ -> None |> function - | Some slug -> WebLog.relativeUrl ctx.WebLog (Permalink $"category/{slug}/") + | Some slug -> ctx.WebLog.RelativeUrl(Permalink $"category/{slug}/") | None -> $"alert('unknown category object type {catObj.GetType().Name}')" - + /// A filter to generate a link that will edit a page -type EditPageLinkFilter () = - static member EditPageLink (ctx : Context, pageObj : obj) = +type EditPageLinkFilter() = + static member EditPageLink(ctx: Context, pageObj: obj) = match pageObj with | :? DisplayPage as page -> Some page.Id | :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string | :? String as theId -> Some theId | _ -> None |> function - | Some pageId -> 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}')" - - + + /// A filter to generate a link that will edit a post -type EditPostLinkFilter () = - static member EditPostLink (ctx : Context, postObj : obj) = +type EditPostLinkFilter() = + static member EditPostLink(ctx: Context, postObj: obj) = match postObj with | :? PostListItem as post -> Some post.Id | :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string | :? String as theId -> Some theId | _ -> None |> function - | Some postId -> 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}/" +type NavLinkFilter() = + static member NavLink(ctx: Context, url: string, text: string) = + let extraPath = ctx.WebLog.ExtraPath + let path = if extraPath = "" then "" else $"{extraPath[1..]}/" seq { "
  • " text "
    • " @@ -97,7 +97,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/{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 @@ -122,12 +122,12 @@ type PageHeadTag() = // RSS feeds and canonical URLs let feedLink title url = let escTitle = HttpUtility.HtmlAttributeEncode title - let relUrl = WebLog.relativeUrl webLog (Permalink url) + let relUrl = webLog.RelativeUrl(Permalink url) $"""{s}""" if webLog.Rss.IsFeedEnabled && getBool "is_home" then result.WriteLine(feedLink webLog.Name webLog.Rss.FeedName) - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" if webLog.Rss.IsCategoryEnabled && getBool "is_category_home" then let slug = context.Environments[0].["slug"] :?> string @@ -139,12 +139,12 @@ type PageHeadTag() = if getBool "is_post" then let post = context.Environments[0].["model"] :?> PostDisplay - let url = WebLog.absoluteUrl webLog (Permalink post.Posts[0].Permalink) + let url = webLog.AbsoluteUrl (Permalink post.Posts[0].Permalink) result.WriteLine $"""{s}""" if getBool "is_page" then let page = context.Environments[0].["page"] :?> DisplayPage - let url = WebLog.absoluteUrl webLog (Permalink page.Permalink) + let url = webLog.AbsoluteUrl (Permalink page.Permalink) result.WriteLine $"""{s}""" @@ -167,26 +167,26 @@ 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 -type TagLinkFilter () = - static member TagLink (ctx : Context, tag : string) = +type TagLinkFilter() = + static member TagLink(ctx: Context, tag: string) = ctx.Environments[0].["tag_mappings"] :?> TagMap list |> List.tryFind (fun it -> it.Tag = tag) |> function | Some tagMap -> tagMap.UrlValue - | None -> tag.Replace (" ", "+") - |> function tagUrl -> WebLog.relativeUrl ctx.WebLog (Permalink $"tag/{tagUrl}/") + | None -> tag.Replace(" ", "+") + |> function tagUrl -> ctx.WebLog.RelativeUrl(Permalink $"tag/{tagUrl}/") /// Create links for a user to log on or off, and a dashboard link if they are logged off -type UserLinksTag () = - inherit Tag () +type UserLinksTag() = + inherit Tag() - override this.Render (context : Context, result : TextWriter) = - let link it = WebLog.relativeUrl context.WebLog (Permalink it) + override this.Render(context: Context, result: TextWriter) = + let link it = context.WebLog.RelativeUrl(Permalink it) seq { """
      """ match Convert.ToBoolean context.Environments[0].["is_logged_on"] with @@ -201,8 +201,8 @@ type UserLinksTag () = /// A filter to retrieve the value of a meta item from a list // (shorter than `{% assign item = list | where: "Name", [name] | first %}{{ item.value }}`) -type ValueFilter () = - static member Value (_ : Context, items : MetaItem list, name : string) = +type ValueFilter() = + static member Value(_: Context, items: MetaItem list, name: string) = match items |> List.tryFind (fun it -> it.Name = name) with | Some item -> item.Value | None -> $"-- {name} not found --" diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 42bed16..6fd5d5f 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -156,7 +156,7 @@ module Category = 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) @@ -177,7 +177,7 @@ module Category = let data = ctx.Data let! model = ctx.BindFormAsync () 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 -> @@ -333,7 +333,7 @@ module TagMapping = 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 -> @@ -350,7 +350,7 @@ module TagMapping = let data = ctx.Data let! model = ctx.BindFormAsync() 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 -> @@ -455,7 +455,7 @@ module Theme = let! isNew, theme = backgroundTask { match! data.Theme.FindById themeId with | Some t -> return false, t - | None -> return true, { Theme.empty with Id = themeId } + | None -> return true, { Theme.Empty with Id = themeId } } use zip = new ZipArchive (file, ZipArchiveMode.Read) let! theme = updateNameAndVersion theme zip diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 605b038..996ae5e 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -86,13 +86,13 @@ 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 array) (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 "

      " 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 = post.PublishedOn.Value.ToDateTimeOffset(), LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset(), @@ -115,30 +115,31 @@ let private toFeedItem webLog (authors: MetaItem list) (cats: DisplayCategory ar [ post.CategoryIds |> List.map (fun catId -> let cat = cats |> Array.find (fun c -> c.Id = string catId) - SyndicationCategory(cat.Name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.Slug}/"), cat.Name)) + 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 (string podcast.ImageUrl) |> toAbsolute webLog let epExplicit = string (defaultArg episode.Explicit podcast.Explicit) @@ -234,22 +235,22 @@ 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 addChild (doc : XmlDocument) ns prefix name value (elt : XmlElement) = +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) + if ns = "" then doc.CreateElement name else doc.CreateElement(prefix, name, ns) |> elt.AppendChild child.InnerText <- value 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 () + let xmlDoc = XmlDocument() [ "dc", Namespace.dc "itunes", Namespace.iTunes @@ -260,12 +261,12 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) = |> List.iter (fun (alias, nsUrl) -> addNamespace rssFeed alias nsUrl) let categorization = - let it = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes) - it.SetAttribute ("text", podcast.AppleCategory) + let it = xmlDoc.CreateElement("itunes", "category", Namespace.iTunes) + it.SetAttribute("text", podcast.AppleCategory) podcast.AppleSubcategory |> Option.iter (fun subCat -> - let subCatElt = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes) - subCatElt.SetAttribute ("text", subCat) + let subCatElt = xmlDoc.CreateElement("itunes", "category", Namespace.iTunes) + subCatElt.SetAttribute("text", subCat) it.AppendChild subCatElt |> ignore) it let image = @@ -275,19 +276,19 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) = ] |> List.fold (fun elt (name, value) -> addChild xmlDoc "" "" name value elt) (xmlDoc.CreateElement "image") let iTunesImage = - let it = xmlDoc.CreateElement ("itunes", "image", Namespace.iTunes) - it.SetAttribute ("href", imageUrl) + let it = xmlDoc.CreateElement("itunes", "image", Namespace.iTunes) + it.SetAttribute("href", imageUrl) it let owner = [ "name", podcast.DisplayedAuthor "email", podcast.Email ] |> List.fold (fun elt (name, value) -> addChild xmlDoc Namespace.iTunes "itunes" name value elt) - (xmlDoc.CreateElement ("itunes", "owner", Namespace.iTunes)) + (xmlDoc.CreateElement("itunes", "owner", Namespace.iTunes)) let rawVoice = - let it = xmlDoc.CreateElement ("rawvoice", "subscribe", Namespace.rawVoice) - it.SetAttribute ("feed", feedUrl) - it.SetAttribute ("itunes", "") + let it = xmlDoc.CreateElement("rawvoice", "subscribe", Namespace.rawVoice) + it.SetAttribute("feed", feedUrl) + it.SetAttribute("itunes", "") it rssFeed.ElementExtensions.Add image @@ -298,7 +299,7 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) = rssFeed.ElementExtensions.Add("summary", Namespace.iTunes, podcast.Summary) rssFeed.ElementExtensions.Add("author", Namespace.iTunes, podcast.DisplayedAuthor) rssFeed.ElementExtensions.Add("explicit", Namespace.iTunes, string podcast.Explicit) - podcast.Subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add ("subtitle", Namespace.iTunes, sub)) + podcast.Subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add("subtitle", Namespace.iTunes, sub)) podcast.FundingUrl |> Option.iter (fun url -> let funding = xmlDoc.CreateElement("podcast", "funding", Namespace.podcast) @@ -353,7 +354,7 @@ let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCat feed.Description <- cleanText None $"""Posts with the "{tag}" tag""" /// Create a feed with a known non-zero-length list of posts -let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask { +let createFeed (feedType: FeedType) posts : HttpHandler = fun next ctx -> backgroundTask { let webLog = ctx.WebLog let data = ctx.Data let! authors = getAuthors webLog posts data @@ -371,36 +372,36 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg item | _ -> item - let feed = SyndicationFeed () + let feed = SyndicationFeed() addNamespace feed "content" Namespace.content setTitleAndDescription feedType webLog cats feed - feed.LastUpdatedTime <- (List.head posts).UpdatedOn.ToDateTimeOffset () + 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) - use mem = new MemoryStream () + use mem = new MemoryStream() use xml = XmlWriter.Create mem feed.SaveAsRss20 xml - xml.Close () + xml.Close() - let _ = mem.Seek (0L, SeekOrigin.Begin) + let _ = mem.Seek(0L, SeekOrigin.Begin) let rdr = new StreamReader(mem) - let! output = rdr.ReadToEndAsync () + let! output = rdr.ReadToEndAsync() return! (setHttpHeader "Content-Type" "text/xml" >=> setStatusCode 200 >=> setBodyFromString output) next ctx } // GET {any-prescribed-feed} -let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask { +let generate (feedType: FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask { match! getFeedPosts ctx feedType postCount with | posts when List.length posts > 0 -> return! createFeed feedType posts next ctx | _ -> return! Error.notFound next ctx diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index a2a9ded..43ccc11 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -234,7 +234,7 @@ let messagesToHeaders (messages : UserMessage array) : HttpHandler = /// 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 } diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 1c442f5..099c7b3 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -28,7 +28,7 @@ let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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) @@ -129,11 +129,10 @@ 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 -> - let _, extra = WebLog.hostAndPath ctx.WebLog return! {| content = [ """
      """ - rev.Text.AsHtml() |> addBaseToRelativeUrls extra + rev.Text.AsHtml() |> addBaseToRelativeUrls ctx.WebLog.ExtraPath "
      " ] |> String.concat "" @@ -179,7 +178,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let now = Noda.now () let tryPage = if model.IsNew then - { Page.empty with + { Page.Empty with Id = PageId.Create() WebLogId = ctx.WebLog.Id AuthorId = ctx.UserId diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index ee8b3db..161b441 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -42,7 +42,7 @@ 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 @@ -115,7 +115,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 +184,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 @@ -223,7 +223,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) @@ -329,11 +329,10 @@ 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 -> - let _, extra = WebLog.hostAndPath ctx.WebLog return! {| content = [ """
      """ - rev.Text.AsHtml() |> addBaseToRelativeUrls extra + rev.Text.AsHtml() |> addBaseToRelativeUrls ctx.WebLog.ExtraPath "
      " ] |> String.concat "" @@ -378,7 +377,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let data = ctx.Data let tryPost = if model.IsNew then - { Post.empty with + { Post.Empty with Id = PostId.Create() WebLogId = ctx.WebLog.Id AuthorId = ctx.UserId diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 72582ad..52fe990 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -16,14 +16,14 @@ module CatchAll = let data = ctx.Data let debug = debug "Routes.CatchAll" ctx let textLink = - let _, extra = WebLog.hostAndPath webLog - let url = string ctx.Request.Path - (if extra = "" then url else url.Substring extra.Length).ToLowerInvariant() + let extra = webLog.ExtraPath + let url = string ctx.Request.Path + (if extra = "" then url else url[..extra.Length]).ToLowerInvariant() let await it = (Async.AwaitTask >> Async.RunSynchronously) it seq { debug (fun () -> $"Considering URL {textLink}") // Home page directory without the directory slash - if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.Empty) + 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 @@ -56,25 +56,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") } @@ -239,7 +239,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 diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index f192f76..6e1b33a 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -146,7 +146,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName), Path.GetExtension(upload.FileName).ToLowerInvariant()) let now = Noda.now () - let localNow = WebLog.localTime ctx.WebLog now + let localNow = ctx.WebLog.LocalTime now let year = localNow.ToString "yyyy" let month = localNow.ToString "MM" let! form = ctx.BindFormAsync() diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index f9a039d..aa518c4 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -122,7 +122,7 @@ 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 @@ -141,13 +141,13 @@ let delete userId : HttpHandler = fun next ctx -> task { | Ok _ -> do! addMessage ctx { UserMessage.success with - Message = $"User {WebLogUser.displayName user} deleted successfully" + 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" + Message = $"User {user.DisplayName} was not deleted" Detail = Some msg } return! all next ctx @@ -155,15 +155,13 @@ let delete userId : HttpHandler = fun next ctx -> task { } /// Display the user "my info" page, with information possibly filled in -let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandler = fun next ctx -> +let private showMyInfo (model: EditMyInfoModel) (user: WebLogUser) : HttpHandler = fun next ctx -> hashForPage "Edit Your Information" |> withAntiCsrf ctx |> addToHash ViewContext.Model model |> addToHash "access_level" (string user.AccessLevel) - |> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn) - |> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog - (defaultArg user.LastSeenOn (Instant.FromUnixTimeSeconds 0))) - + |> addToHash "created_on" (ctx.WebLog.LocalTime user.CreatedOn) + |> addToHash "last_seen_on" (ctx.WebLog.LocalTime (defaultArg user.LastSeenOn (Instant.FromUnixTimeSeconds 0))) |> adminView "my-info" next ctx @@ -207,7 +205,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let data = ctx.Data let tryUser = if model.IsNew then - { WebLogUser.empty with + { WebLogUser.Empty with Id = WebLogUserId.Create() WebLogId = ctx.WebLog.Id CreatedOn = Noda.now () diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 685c9dc..00a8dbc 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -32,7 +32,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { let accessLevel = if List.isEmpty webLogs then Administrator else WebLogAdmin do! data.WebLog.Add - { WebLog.empty with + { WebLog.Empty with Id = webLogId Name = args[2] Slug = slug @@ -44,7 +44,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { // Create the admin user let now = Noda.now () let user = - { WebLogUser.empty with + { WebLogUser.Empty with Id = userId WebLogId = webLogId Email = args[3] @@ -58,7 +58,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { // Create the default home page do! data.Page.Add - { Page.empty with + { Page.Empty with Id = homePageId WebLogId = webLogId AuthorId = userId -- 2.45.1 From 8ec84e8680f8e330a6c32c6db21d1953690c8976 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Dec 2023 17:59:33 -0500 Subject: [PATCH 018/123] WIP on module/member conversion View models complete --- src/MyWebLog.Domain/ViewModels.fs | 761 +++++++++++++++--------------- src/MyWebLog/Handlers/Admin.fs | 72 +-- src/MyWebLog/Handlers/Feed.fs | 10 +- src/MyWebLog/Handlers/Helpers.fs | 10 +- src/MyWebLog/Handlers/Page.fs | 20 +- src/MyWebLog/Handlers/Post.fs | 22 +- src/MyWebLog/Handlers/Upload.fs | 8 +- src/MyWebLog/Handlers/User.fs | 26 +- 8 files changed, 453 insertions(+), 476 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index d8ec0b4..db7f8d8 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -9,7 +9,7 @@ open NodaTime module private Helpers = /// Create a string option if a string is blank - let noneIfBlank (it : string) = + let noneIfBlank it = match (defaultArg (Option.ofObj it) "").Trim() with "" -> None | trimmed -> Some trimmed @@ -19,31 +19,31 @@ module PublicHelpers = /// If the web log is not being served from the domain root, add the path information to relative URLs in page and /// post text - let addBaseToRelativeUrls extra (text : string) = + let addBaseToRelativeUrls extra (text: string) = if extra = "" then text - else text.Replace("href=\"/", $"href=\"{extra}/").Replace ("src=\"/", $"src=\"{extra}/") + else text.Replace("href=\"/", $"href=\"{extra}/").Replace("src=\"/", $"src=\"{extra}/") /// The model used to display the admin dashboard [] type DashboardModel = { /// The number of published posts - Posts : int + Posts: int /// The number of post drafts - Drafts : int + Drafts: int /// The number of pages - Pages : int + Pages: int /// The number of pages in the page list - ListedPages : int + ListedPages: int /// The number of categories - Categories : int + Categories: int /// The top-level categories - TopLevelCategories : int + TopLevelCategories: int } @@ -51,22 +51,22 @@ type DashboardModel = { [] type DisplayCategory = { /// The ID of the category - Id : string + Id: string /// The slug for the category - Slug : string + Slug: string /// The name of the category - Name : string + Name: string /// A description of the category - Description : string option + Description: string option /// The parent category names for this (sub)category - ParentNames : string[] + ParentNames: string array /// The number of posts in this category - PostCount : int + PostCount: int } @@ -83,13 +83,10 @@ type DisplayCustomFeed = { /// Whether this custom feed is for a podcast IsPodcast: bool -} - -/// Support functions for custom feed displays -module DisplayCustomFeed = +} with /// Create a display version from a custom feed - let fromFeed (cats: DisplayCategory array) (feed: CustomFeed) : DisplayCustomFeed = + static member FromFeed (cats: DisplayCategory array) (feed: CustomFeed) = let source = match feed.Source with | Category (CategoryId catId) -> $"Category: {(cats |> Array.find (fun cat -> cat.Id = catId)).Name}" @@ -168,17 +165,14 @@ type DisplayRevision = { /// The format of the text of the revision Format: string -} - -/// Functions to support displaying revisions -module DisplayRevision = +} with /// Create a display revision from an actual revision - let fromRevision (webLog: WebLog) (rev : Revision) = - { AsOf = rev.AsOf.ToDateTimeUtc () - AsOfLocal = webLog.LocalTime rev.AsOf - Format = rev.Text.SourceType - } + static member FromRevision (webLog: WebLog) (rev : Revision) = { + AsOf = rev.AsOf.ToDateTimeUtc() + AsOfLocal = webLog.LocalTime rev.AsOf + Format = rev.Text.SourceType + } open System.IO @@ -203,20 +197,17 @@ type DisplayTheme = { /// Whether the theme .zip file exists on the filesystem IsOnDisk: bool -} - -/// Functions to support displaying themes -module DisplayTheme = +} with /// Create a display theme from a theme - let fromTheme inUseFunc (theme: Theme) = - { Id = string theme.Id - Name = theme.Name - Version = theme.Version - TemplateCount = List.length theme.Templates - IsInUse = inUseFunc theme.Id - IsOnDisk = File.Exists $"{theme.Id}-theme.zip" - } + static member FromTheme inUseFunc (theme: Theme) = { + Id = string theme.Id + Name = theme.Name + Version = theme.Version + TemplateCount = List.length theme.Templates + IsInUse = inUseFunc theme.Id + IsOnDisk = File.Exists $"{theme.Id}-theme.zip" + } /// Information about an uploaded file used for display @@ -236,13 +227,10 @@ type DisplayUpload = { /// The source for this file (created from UploadDestination DU) Source: string -} - -/// Functions to support displaying uploads -module DisplayUpload = +} with /// Create a display uploaded file - let fromUpload (webLog: WebLog) (source: UploadDestination) (upload: Upload) = + static member FromUpload (webLog: WebLog) (source: UploadDestination) (upload: Upload) = let path = string upload.Path let name = Path.GetFileName path { Id = string upload.Id @@ -282,13 +270,10 @@ type DisplayUser = { /// When the user last logged on LastSeenOn: Nullable -} - -/// Functions to support displaying a user's information -module DisplayUser = +} with /// Construct a displayed user from a web log user - let fromUser (webLog: WebLog) (user: WebLogUser) = { + static member FromUser (webLog: WebLog) (user: WebLogUser) = { Id = string user.Id Email = user.Email FirstName = user.FirstName @@ -321,119 +306,119 @@ type EditCategoryModel = { } with /// Create an edit model from an existing category - static member fromCategory (cat: Category) = - { CategoryId = string cat.Id - Name = cat.Name - Slug = cat.Slug - Description = defaultArg cat.Description "" - ParentId = cat.ParentId |> Option.map string |> Option.defaultValue "" - } + static member FromCategory (cat: Category) = { + CategoryId = string cat.Id + Name = cat.Name + Slug = cat.Slug + Description = defaultArg cat.Description "" + ParentId = cat.ParentId |> Option.map string |> Option.defaultValue "" + } /// Is this a new category? - member this.IsNew = this.CategoryId = "new" + member this.IsNew = + this.CategoryId = "new" /// View model to edit a custom RSS feed [] -type EditCustomFeedModel = - { /// The ID of the feed being editing - Id : string - - /// The type of source for this feed ("category" or "tag") - SourceType : string - - /// The category ID or tag on which this feed is based - SourceValue : string - - /// The relative path at which this feed is served - Path : string - - /// Whether this feed defines a podcast - IsPodcast : bool - - /// The title of the podcast - Title : string - - /// A subtitle for the podcast - Subtitle : string - - /// The number of items in the podcast feed - ItemsInFeed : int - - /// A summary of the podcast (iTunes field) - Summary : string - - /// The display name of the podcast author (iTunes field) - DisplayedAuthor : string - - /// The e-mail address of the user who registered the podcast at iTunes - Email : string - - /// The link to the image for the podcast - ImageUrl : string - - /// The category from Apple Podcasts (iTunes) under which this podcast is categorized - AppleCategory : string - - /// A further refinement of the categorization of this podcast (Apple Podcasts/iTunes field / values) - AppleSubcategory : string - - /// The explictness rating (iTunes field) - Explicit : string - - /// The default media type for files in this podcast - DefaultMediaType : string - - /// The base URL for relative URL media files for this podcast (optional; defaults to web log base) - MediaBaseUrl : string - - /// The URL for funding information for the podcast - FundingUrl : string - - /// The text for the funding link - FundingText : string - - /// A unique identifier to follow this podcast - PodcastGuid : string - - /// The medium for the content of this podcast - Medium : string - } +type EditCustomFeedModel = { + /// The ID of the feed being editing + Id: string + + /// The type of source for this feed ("category" or "tag") + SourceType: string + + /// The category ID or tag on which this feed is based + SourceValue: string + + /// The relative path at which this feed is served + Path: string + + /// Whether this feed defines a podcast + IsPodcast: bool + + /// The title of the podcast + Title: string + + /// A subtitle for the podcast + Subtitle: string + + /// The number of items in the podcast feed + ItemsInFeed: int + + /// A summary of the podcast (iTunes field) + Summary: string + + /// The display name of the podcast author (iTunes field) + DisplayedAuthor: string + + /// The e-mail address of the user who registered the podcast at iTunes + Email: string + + /// The link to the image for the podcast + ImageUrl: string + + /// The category from Apple Podcasts (iTunes) under which this podcast is categorized + AppleCategory: string + + /// A further refinement of the categorization of this podcast (Apple Podcasts/iTunes field / values) + AppleSubcategory: string + + /// The explictness rating (iTunes field) + Explicit: string + + /// The default media type for files in this podcast + DefaultMediaType: string + + /// The base URL for relative URL media files for this podcast (optional; defaults to web log base) + MediaBaseUrl: string + + /// The URL for funding information for the podcast + FundingUrl: string + + /// The text for the funding link + FundingText: string + + /// A unique identifier to follow this podcast + PodcastGuid: string + + /// The medium for the content of this podcast + Medium: string +} with /// An empty custom feed model - static member empty = - { Id = "" - SourceType = "category" - SourceValue = "" - Path = "" - IsPodcast = false - Title = "" - Subtitle = "" - ItemsInFeed = 25 - Summary = "" - DisplayedAuthor = "" - Email = "" - ImageUrl = "" - AppleCategory = "" - AppleSubcategory = "" - Explicit = "no" - DefaultMediaType = "audio/mpeg" - MediaBaseUrl = "" - FundingUrl = "" - FundingText = "" - PodcastGuid = "" - Medium = "" - } + static member Empty = { + Id = "" + SourceType = "category" + SourceValue = "" + Path = "" + IsPodcast = false + Title = "" + Subtitle = "" + ItemsInFeed = 25 + Summary = "" + DisplayedAuthor = "" + Email = "" + ImageUrl = "" + AppleCategory = "" + AppleSubcategory = "" + Explicit = "no" + DefaultMediaType = "audio/mpeg" + MediaBaseUrl = "" + FundingUrl = "" + FundingText = "" + PodcastGuid = "" + Medium = "" + } /// Create a model from a custom feed - static member fromFeed (feed: CustomFeed) = + static member FromFeed (feed: CustomFeed) = let rss = - { EditCustomFeedModel.empty with + { EditCustomFeedModel.Empty with Id = string feed.Id SourceType = match feed.Source with Category _ -> "category" | Tag _ -> "tag" SourceValue = match feed.Source with Category (CategoryId catId) -> catId | Tag tag -> tag - Path = string feed.Path - } + Path = string feed.Path } match feed.Podcast with | Some p -> { rss with @@ -453,12 +438,11 @@ type EditCustomFeedModel = FundingUrl = defaultArg p.FundingUrl "" FundingText = defaultArg p.FundingText "" PodcastGuid = p.PodcastGuid |> Option.map _.ToString().ToLowerInvariant() |> Option.defaultValue "" - Medium = p.Medium |> Option.map string |> Option.defaultValue "" - } + Medium = p.Medium |> Option.map string |> Option.defaultValue "" } | None -> rss /// Update a feed with values from this model - member this.UpdateFeed (feed : CustomFeed) = + member this.UpdateFeed (feed: CustomFeed) = { feed with Source = if this.SourceType = "tag" then Tag this.SourceValue else Category (CategoryId this.SourceValue) Path = Permalink this.Path @@ -480,40 +464,38 @@ type EditCustomFeedModel = PodcastGuid = noneIfBlank this.PodcastGuid |> Option.map Guid.Parse FundingUrl = noneIfBlank this.FundingUrl FundingText = noneIfBlank this.FundingText - Medium = noneIfBlank this.Medium |> Option.map PodcastMedium.Parse - } + Medium = noneIfBlank this.Medium |> Option.map PodcastMedium.Parse } else - None - } + None } /// View model for a user to edit their own information [] -type EditMyInfoModel = - { /// The user's first name - FirstName : string - - /// The user's last name - LastName : string - - /// The user's preferred name - PreferredName : string - - /// A new password for the user - NewPassword : string - - /// A new password for the user, confirmed - NewPasswordConfirm : string - } +type EditMyInfoModel = { + /// The user's first name + FirstName: string + + /// The user's last name + LastName: string + + /// The user's preferred name + PreferredName: string + + /// A new password for the user + NewPassword: string + + /// A new password for the user, confirmed + NewPasswordConfirm: string +} with /// Create an edit model from a user - static member fromUser (user : WebLogUser) = - { FirstName = user.FirstName - LastName = user.LastName - PreferredName = user.PreferredName - NewPassword = "" - NewPasswordConfirm = "" - } + static member FromUser (user: WebLogUser) = { + FirstName = user.FirstName + LastName = user.LastName + PreferredName = user.PreferredName + NewPassword = "" + NewPasswordConfirm = "" + } /// View model to edit a page @@ -548,7 +530,7 @@ type EditPageModel = { } with /// Create an edit model from an existing page - static member fromPage (page: Page) = + static member FromPage (page: Page) = let latest = match page.Revisions |> List.sortByDescending _.AsOf |> List.tryHead with | Some rev -> rev @@ -566,7 +548,8 @@ type EditPageModel = { } /// Whether this is a new page - member this.IsNew = this.PageId = "new" + member this.IsNew = + this.PageId = "new" /// Update a page with values from this model member this.UpdatePage (page: Page) now = @@ -588,12 +571,11 @@ type EditPageModel = { Metadata = Seq.zip this.MetaNames this.MetaValues |> Seq.filter (fun it -> fst it > "") |> Seq.map (fun it -> { Name = fst it; Value = snd it }) - |> Seq.sortBy (fun it -> $"{it.Name.ToLower ()} {it.Value.ToLower ()}") + |> Seq.sortBy (fun it -> $"{it.Name.ToLower()} {it.Value.ToLower()}") |> List.ofSeq Revisions = match page.Revisions |> List.tryHead with | Some r when r.Text = revision.Text -> page.Revisions - | _ -> revision :: page.Revisions - } + | _ -> revision :: page.Revisions } /// View model to edit a post @@ -700,7 +682,7 @@ type EditPostModel = { } with /// Create an edit model from an existing past - static member fromPost (webLog: WebLog) (post: Post) = + static member FromPost (webLog: WebLog) (post: Post) = let latest = match post.Revisions |> List.sortByDescending _.AsOf |> List.tryHead with | Some rev -> rev @@ -712,7 +694,7 @@ type EditPostModel = { Permalink = string post.Permalink Source = latest.Text.SourceType Text = latest.Text.Text - Tags = String.Join (", ", post.Tags) + Tags = String.Join(", ", post.Tags) Template = defaultArg post.Template "" CategoryIds = post.CategoryIds |> List.map string |> Array.ofList Status = string post.Status @@ -743,7 +725,8 @@ type EditPostModel = { } /// Whether this is a new post - member this.IsNew = this.PostId = "new" + member this.IsNew = + this.PostId = "new" /// Update a post with values from the submitted form member this.UpdatePost (post: Post) now = @@ -763,17 +746,17 @@ type EditPostModel = { Text = revision.Text.AsHtml() Tags = this.Tags.Split "," |> Seq.ofArray - |> Seq.map (fun it -> it.Trim().ToLower ()) + |> Seq.map _.Trim().ToLower() |> Seq.filter (fun it -> it <> "") |> Seq.sort |> List.ofSeq - Template = match this.Template.Trim () with "" -> None | tmpl -> Some tmpl + Template = match this.Template.Trim() with "" -> None | tmpl -> Some tmpl CategoryIds = this.CategoryIds |> Array.map CategoryId |> List.ofArray Status = if this.DoPublish then Published else post.Status Metadata = Seq.zip this.MetaNames this.MetaValues |> Seq.filter (fun it -> fst it > "") |> Seq.map (fun it -> { Name = fst it; Value = snd it }) - |> Seq.sortBy (fun it -> $"{it.Name.ToLower ()} {it.Value.ToLower ()}") + |> Seq.sortBy (fun it -> $"{it.Name.ToLower()} {it.Value.ToLower()}") |> List.ofSeq Revisions = match post.Revisions |> List.tryHead with | Some r when r.Text = revision.Text -> post.Revisions @@ -805,113 +788,111 @@ type EditPostModel = { EpisodeDescription = noneIfBlank this.EpisodeDescription } else - None - } + None } /// View model to add/edit a redirect rule [] -type EditRedirectRuleModel = - { /// The ID (index) of the rule being edited - RuleId : int +type EditRedirectRuleModel = { + /// The ID (index) of the rule being edited + RuleId: int - /// The "from" side of the rule - From : string + /// The "from" side of the rule + From: string - /// The "to" side of the rule - To : string + /// The "to" side of the rule + To: string - /// Whether this rule uses a regular expression - IsRegex : bool + /// Whether this rule uses a regular expression + IsRegex: bool - /// Whether a new rule should be inserted at the top or appended to the end (ignored for edits) - InsertAtTop : bool - } + /// Whether a new rule should be inserted at the top or appended to the end (ignored for edits) + InsertAtTop: bool +} with /// Create a model from an existing rule - static member fromRule idx (rule : RedirectRule) = - { RuleId = idx - From = rule.From - To = rule.To - IsRegex = rule.IsRegex - InsertAtTop = false - } + static member FromRule idx (rule: RedirectRule) = { + RuleId = idx + From = rule.From + To = rule.To + IsRegex = rule.IsRegex + InsertAtTop = false + } /// Update a rule with the values from this model - member this.UpdateRule (rule : RedirectRule) = - { rule with - From = this.From - To = this.To - IsRegex = this.IsRegex - } + member this.ToRule() = { + From = this.From + To = this.To + IsRegex = this.IsRegex + } /// View model to edit RSS settings [] -type EditRssModel = - { /// Whether the site feed of posts is enabled - IsFeedEnabled : bool - - /// The name of the file generated for the site feed - FeedName : string - - /// Override the "posts per page" setting for the site feed - ItemsInFeed : int - - /// Whether feeds are enabled for all categories - IsCategoryEnabled : bool - - /// Whether feeds are enabled for all tags - IsTagEnabled : bool - - /// A copyright string to be placed in all feeds - Copyright : string - } +type EditRssModel = { + /// Whether the site feed of posts is enabled + IsFeedEnabled: bool + + /// The name of the file generated for the site feed + FeedName: string + + /// Override the "posts per page" setting for the site feed + ItemsInFeed: int + + /// Whether feeds are enabled for all categories + IsCategoryEnabled: bool + + /// Whether feeds are enabled for all tags + IsTagEnabled: bool + + /// A copyright string to be placed in all feeds + Copyright: string +} with /// Create an edit model from a set of RSS options - static member fromRssOptions (rss : RssOptions) = - { IsFeedEnabled = rss.IsFeedEnabled - FeedName = rss.FeedName - ItemsInFeed = defaultArg rss.ItemsInFeed 0 - IsCategoryEnabled = rss.IsCategoryEnabled - IsTagEnabled = rss.IsTagEnabled - Copyright = defaultArg rss.Copyright "" - } + static member FromRssOptions (rss: RssOptions) = { + IsFeedEnabled = rss.IsFeedEnabled + FeedName = rss.FeedName + ItemsInFeed = defaultArg rss.ItemsInFeed 0 + IsCategoryEnabled = rss.IsCategoryEnabled + IsTagEnabled = rss.IsTagEnabled + Copyright = defaultArg rss.Copyright "" + } /// Update RSS options from values in this model - member this.UpdateOptions (rss : RssOptions) = + member this.UpdateOptions (rss: RssOptions) = { rss with IsFeedEnabled = this.IsFeedEnabled FeedName = this.FeedName ItemsInFeed = if this.ItemsInFeed = 0 then None else Some this.ItemsInFeed IsCategoryEnabled = this.IsCategoryEnabled IsTagEnabled = this.IsTagEnabled - Copyright = noneIfBlank this.Copyright - } + Copyright = noneIfBlank this.Copyright } /// View model to edit a tag mapping [] -type EditTagMapModel = - { /// The ID of the tag mapping being edited - Id : string - - /// The tag being mapped to a different link value - Tag : string - - /// The link value for the tag - UrlValue : string +type EditTagMapModel = { + /// The ID of the tag mapping being edited + Id: string + + /// The tag being mapped to a different link value + Tag: string + + /// The link value for the tag + UrlValue: string +} with + + /// Create an edit model from the tag mapping + static member FromMapping (tagMap: TagMap) : EditTagMapModel = { + Id = string tagMap.Id + Tag = tagMap.Tag + UrlValue = tagMap.UrlValue } /// Whether this is a new tag mapping - member this.IsNew = this.Id = "new" - - /// Create an edit model from the tag mapping - static member fromMapping (tagMap : TagMap) : EditTagMapModel = - { Id = string tagMap.Id - Tag = tagMap.Tag - UrlValue = tagMap.UrlValue - } + member this.IsNew = + this.Id = "new" /// View model to display a user's information @@ -945,21 +926,22 @@ type EditUserModel = { PasswordConfirm: string } with - /// Construct a displayed user from a web log user - static member fromUser (user: WebLogUser) = - { Id = string user.Id - AccessLevel = string user.AccessLevel - Url = defaultArg user.Url "" - Email = user.Email - FirstName = user.FirstName - LastName = user.LastName - PreferredName = user.PreferredName - Password = "" - PasswordConfirm = "" - } + /// Construct a user edit form from a web log user + static member FromUser (user: WebLogUser) = { + Id = string user.Id + AccessLevel = string user.AccessLevel + Url = defaultArg user.Url "" + Email = user.Email + FirstName = user.FirstName + LastName = user.LastName + PreferredName = user.PreferredName + Password = "" + PasswordConfirm = "" + } /// Is this a new user? - member this.IsNew = this.Id = "new" + member this.IsNew = + this.Id = "new" /// Update a user with values from this model (excludes password) member this.UpdateUser (user: WebLogUser) = @@ -969,25 +951,24 @@ type EditUserModel = { Url = noneIfBlank this.Url FirstName = this.FirstName LastName = this.LastName - PreferredName = this.PreferredName - } + PreferredName = this.PreferredName } /// The model to use to allow a user to log on [] -type LogOnModel = - { /// The user's e-mail address - EmailAddress : string +type LogOnModel = { + /// The user's e-mail address + EmailAddress : string + + /// The user's password + Password : string - /// The user's password - Password : string - - /// Where the user should be redirected once they have logged on - ReturnTo : string option - } + /// Where the user should be redirected once they have logged on + ReturnTo : string option +} with /// An empty log on model - static member empty = + static member Empty = { EmailAddress = ""; Password = ""; ReturnTo = None } @@ -1011,55 +992,55 @@ type ManagePermalinksModel = { } with /// Create a permalink model from a page - static member fromPage (pg: Page) = - { Id = string pg.Id - Entity = "page" - CurrentTitle = pg.Title - CurrentPermalink = string pg.Permalink - Prior = pg.PriorPermalinks |> List.map string |> Array.ofList - } + static member FromPage (page: Page) = { + Id = string page.Id + Entity = "page" + CurrentTitle = page.Title + CurrentPermalink = string page.Permalink + Prior = page.PriorPermalinks |> List.map string |> Array.ofList + } /// Create a permalink model from a post - static member fromPost (post: Post) = - { Id = string post.Id - Entity = "post" - CurrentTitle = post.Title - CurrentPermalink = string post.Permalink - Prior = post.PriorPermalinks |> List.map string |> Array.ofList - } + static member FromPost (post: Post) = { + Id = string post.Id + Entity = "post" + CurrentTitle = post.Title + CurrentPermalink = string post.Permalink + Prior = post.PriorPermalinks |> List.map string |> Array.ofList + } /// View model to manage revisions [] -type ManageRevisionsModel = - { /// The ID for the entity being edited - Id : string - - /// The type of entity being edited ("page" or "post") - Entity : string - - /// The current title of the page or post - CurrentTitle : string - - /// The revisions for the page or post - Revisions : DisplayRevision array - } +type ManageRevisionsModel = { + /// The ID for the entity being edited + Id: string + + /// The type of entity being edited ("page" or "post") + Entity: string + + /// The current title of the page or post + CurrentTitle: string + + /// The revisions for the page or post + Revisions: DisplayRevision array +} with /// Create a revision model from a page - static member fromPage webLog (pg: Page) = - { Id = string pg.Id - Entity = "page" - CurrentTitle = pg.Title - Revisions = pg.Revisions |> List.map (DisplayRevision.fromRevision webLog) |> Array.ofList - } + static member FromPage webLog (page: Page) = { + Id = string page.Id + Entity = "page" + CurrentTitle = page.Title + Revisions = page.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList + } /// Create a revision model from a post - static member fromPost webLog (post: Post) = - { Id = string post.Id - Entity = "post" - CurrentTitle = post.Title - Revisions = post.Revisions |> List.map (DisplayRevision.fromRevision webLog) |> Array.ofList - } + static member FromPost webLog (post: Post) = { + Id = string post.Id + Entity = "post" + CurrentTitle = post.Title + Revisions = post.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList + } /// View model for posts in a list @@ -1103,7 +1084,7 @@ type PostListItem = { } with /// Create a post list item from a post - static member fromPost (webLog: WebLog) (post: Post) = { + static member FromPost (webLog: WebLog) (post: Post) = { Id = string post.Id AuthorId = string post.AuthorId Status = string post.Status @@ -1120,28 +1101,28 @@ type PostListItem = { /// View model for displaying posts -type PostDisplay = - { /// The posts to be displayed - Posts : PostListItem[] - - /// Author ID -> name lookup - Authors : MetaItem list - - /// A subtitle for the page - Subtitle : string option - - /// The link to view newer (more recent) posts - NewerLink : string option - - /// The name of the next newer post (single-post only) - NewerName : string option - - /// The link to view older (less recent) posts - OlderLink : string option - - /// The name of the next older post (single-post only) - OlderName : string option - } +type PostDisplay = { + /// The posts to be displayed + Posts: PostListItem array + + /// Author ID -> name lookup + Authors: MetaItem list + + /// A subtitle for the page + Subtitle: string option + + /// The link to view newer (more recent) posts + NewerLink: string option + + /// The name of the next newer post (single-post only) + NewerName: string option + + /// The link to view older (less recent) posts + OlderLink: string option + + /// The name of the next older post (single-post only) + OlderName: string option +} /// View model for editing web log settings @@ -1176,20 +1157,20 @@ type SettingsModel = { } with /// Create a settings model from a web log - static member fromWebLog (webLog: WebLog) = - { Name = webLog.Name - Slug = webLog.Slug - Subtitle = defaultArg webLog.Subtitle "" - DefaultPage = webLog.DefaultPage - PostsPerPage = webLog.PostsPerPage - TimeZone = webLog.TimeZone - ThemeId = string webLog.ThemeId - AutoHtmx = webLog.AutoHtmx - Uploads = string webLog.Uploads - } + static member FromWebLog(webLog: WebLog) = { + Name = webLog.Name + Slug = webLog.Slug + Subtitle = defaultArg webLog.Subtitle "" + DefaultPage = webLog.DefaultPage + PostsPerPage = webLog.PostsPerPage + TimeZone = webLog.TimeZone + ThemeId = string webLog.ThemeId + AutoHtmx = webLog.AutoHtmx + Uploads = string webLog.Uploads + } /// Update a web log with settings from the form - member this.update (webLog : WebLog) = + member this.Update(webLog: WebLog) = { webLog with Name = this.Name Slug = this.Slug @@ -1199,53 +1180,49 @@ type SettingsModel = { TimeZone = this.TimeZone ThemeId = ThemeId this.ThemeId AutoHtmx = this.AutoHtmx - Uploads = UploadDestination.Parse this.Uploads - } + Uploads = UploadDestination.Parse this.Uploads } /// View model for uploading a file [] -type UploadFileModel = - { /// The upload destination - Destination : string - } +type UploadFileModel = { + /// The upload destination + Destination : string +} /// View model for uploading a theme [] -type UploadThemeModel = - { /// Whether the uploaded theme should overwrite an existing theme - DoOverwrite : bool - } +type UploadThemeModel = { + /// Whether the uploaded theme should overwrite an existing theme + DoOverwrite : bool +} /// A message displayed to the user [] -type UserMessage = - { /// The level of the message - Level : string - - /// The message - Message : string - - /// Further details about the message - Detail : string option - } - -/// Functions to support user messages -module UserMessage = +type UserMessage = { + /// The level of the message + Level: string + + /// The message + Message: string + + /// Further details about the message + Detail: string option +} with /// An empty user message (use one of the others for pre-filled level) - let empty = { Level = ""; Message = ""; Detail = None } + static member Empty = { Level = ""; Message = ""; Detail = None } /// A blank success message - let success = { empty with Level = "success" } + static member Success = { UserMessage.Empty with Level = "success" } /// A blank informational message - let info = { empty with Level = "primary" } + static member Info = { UserMessage.Empty with Level = "primary" } /// A blank warning message - let warning = { empty with Level = "warning" } + static member Warning = { UserMessage.Empty with Level = "warning" } /// A blank error message - let error = { empty with Level = "danger" } + static member Error = { UserMessage.Empty with Level = "danger" } diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 6fd5d5f..bae83c0 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -44,7 +44,7 @@ module Dashboard = |> withAntiCsrf ctx |> addToHash "themes" ( themes - |> List.map (DisplayTheme.fromTheme WebLogCache.isThemeInUse) + |> List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) |> Array.ofList) |> addToHash "cached_themes" ( themes @@ -87,7 +87,7 @@ module Cache = 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" } + { UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" } else match! data.WebLog.FindById (WebLogId webLogId) with | Some webLog -> @@ -95,9 +95,9 @@ module Cache = 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}" } + { 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}" } + do! addMessage ctx { UserMessage.Error with Message = $"No web log exists with ID {webLogId}" } return! toAdminDashboard next ctx } @@ -108,7 +108,7 @@ module Cache = TemplateCache.empty () do! ThemeAssetCache.fill data do! addMessage ctx - { UserMessage.success with + { UserMessage.Success with Message = "Successfully cleared template cache and refreshed theme asset cache" } else @@ -117,11 +117,11 @@ module Cache = TemplateCache.invalidateTheme theme.Id do! ThemeAssetCache.refreshTheme theme.Id data do! addMessage ctx - { UserMessage.success with + { 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}" } + do! addMessage ctx { UserMessage.Error with Message = $"No theme exists with ID {themeId}" } return! toAdminDashboard next ctx } @@ -167,7 +167,7 @@ module Category = return! hashForPage title |> withAntiCsrf ctx - |> addToHash ViewContext.Model (EditCategoryModel.fromCategory cat) + |> addToHash ViewContext.Model (EditCategoryModel.FromCategory cat) |> adminBareView "category-edit" next ctx | None -> return! Error.notFound next ctx } @@ -190,7 +190,7 @@ module Category = } 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" } + do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" } return! bare next ctx | None -> return! Error.notFound next ctx } @@ -207,9 +207,9 @@ module Category = | ReassignedChildCategories -> Some "(Its child categories were reassigned to its parent category)" | _ -> None - do! addMessage ctx { UserMessage.success with Message = "Category deleted successfully"; Detail = detail } + 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" } + do! addMessage ctx { UserMessage.Error with Message = "Category not found; cannot delete" } return! bare next ctx } @@ -233,7 +233,7 @@ module RedirectRules = if idx = -1 then return! hashForPage "Add Redirect Rule" - |> addToHash "model" (EditRedirectRuleModel.fromRule -1 RedirectRule.Empty) + |> addToHash "model" (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty) |> withAntiCsrf ctx |> adminBareView "redirect-edit" next ctx else @@ -243,7 +243,7 @@ module RedirectRules = else return! hashForPage "Edit Redirect Rule" - |> addToHash "model" (EditRedirectRuleModel.fromRule idx (List.item idx rules)) + |> addToHash "model" (EditRedirectRuleModel.FromRule idx (List.item idx rules)) |> withAntiCsrf ctx |> adminBareView "redirect-edit" next ctx } @@ -257,17 +257,17 @@ module RedirectRules = // POST /admin/settings/redirect-rules/[index] let save idx : HttpHandler = fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let isNew = idx = -1 let rules = ctx.WebLog.RedirectRules - let rule = model.UpdateRule (if isNew then RedirectRule.Empty else List.item idx rules) + let rule = model.ToRule() let newRules = match isNew with | true when model.InsertAtTop -> List.insertAt 0 rule rules - | true -> List.insertAt (rules.Length) rule rules + | true -> List.insertAt rules.Length rule rules | false -> rules |> List.removeAt idx |> List.insertAt idx rule do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } - do! addMessage ctx { UserMessage.success with Message = "Redirect rule saved successfully" } + do! addMessage ctx { UserMessage.Success with Message = "Redirect rule saved successfully" } return! all next ctx } @@ -300,7 +300,7 @@ module RedirectRules = 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" } + do! addMessage ctx { UserMessage.Success with Message = "Redirect rule deleted successfully" } return! all next ctx } @@ -340,7 +340,7 @@ module TagMapping = return! hashForPage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") |> withAntiCsrf ctx - |> addToHash ViewContext.Model (EditTagMapModel.fromMapping tm) + |> addToHash ViewContext.Model (EditTagMapModel.FromMapping tm) |> adminBareView "tag-mapping-edit" next ctx | None -> return! Error.notFound next ctx } @@ -355,7 +355,7 @@ module TagMapping = 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" } + do! addMessage ctx { UserMessage.Success with Message = "Tag mapping saved successfully" } return! all next ctx | None -> return! Error.notFound next ctx } @@ -363,8 +363,8 @@ module TagMapping = // POST /admin/settings/tag-mapping/{id}/delete 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" } + | 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 } @@ -384,7 +384,7 @@ module Theme = return! hashForPage "Themes" |> withAntiCsrf ctx - |> addToHash "themes" (themes |> List.map (DisplayTheme.fromTheme WebLogCache.isThemeInUse) |> Array.ofList) + |> addToHash "themes" (themes |> List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) |> Array.ofList) |> adminBareView "theme-list-body" next ctx } @@ -488,21 +488,21 @@ module Theme = use file = new FileStream($"{themeId}-theme.zip", FileMode.Create) do! themeFile.CopyToAsync file do! addMessage ctx - { UserMessage.success with + { UserMessage.Success with Message = $"""Theme {if isNew then "add" else "updat"}ed successfully""" } return! toAdminDashboard next ctx else do! addMessage ctx - { UserMessage.error with + { 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" } + 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 } + do! addMessage ctx { UserMessage.Error with Message = message } return! toAdminDashboard next ctx else return! RequestErrors.BAD_REQUEST "Bad request" next ctx } @@ -512,11 +512,11 @@ module Theme = let data = ctx.Data match themeId with | "admin" | "default" -> - do! addMessage ctx { UserMessage.error with Message = $"You may not delete the {themeId} theme" } + 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 + { UserMessage.Error with Message = $"You may not delete the {themeId} theme, as it is currently in use" } return! all next ctx @@ -525,7 +525,7 @@ module Theme = | true -> let zippedTheme = $"{themeId}-theme.zip" if File.Exists zippedTheme then File.Delete zippedTheme - do! addMessage ctx { UserMessage.success with Message = $"Theme ID {themeId} deleted successfully" } + do! addMessage ctx { UserMessage.Success with Message = $"Theme ID {themeId} deleted successfully" } return! all next ctx | false -> return! Error.notFound next ctx } @@ -550,7 +550,7 @@ module WebLog = let! hash = hashForPage "Web Log Settings" |> withAntiCsrf ctx - |> addToHash ViewContext.Model (SettingsModel.fromWebLog ctx.WebLog) + |> addToHash ViewContext.Model (SettingsModel.FromWebLog ctx.WebLog) |> addToHash "pages" ( seq { KeyValuePair.Create("posts", "- First Page of Posts -") @@ -569,11 +569,11 @@ module WebLog = KeyValuePair.Create(string Database, "Database") KeyValuePair.Create(string Disk, "Disk") |] - |> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList) - |> addToHash "rss_model" (EditRssModel.fromRssOptions ctx.WebLog.Rss) + |> addToHash "users" (users |> List.map (DisplayUser.FromUser ctx.WebLog) |> Array.ofList) + |> addToHash "rss_model" (EditRssModel.FromRssOptions ctx.WebLog.Rss) |> addToHash "custom_feeds" ( ctx.WebLog.Rss.CustomFeeds - |> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx)) + |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) |> Array.ofList) |> addViewContext ctx let! hash' = TagMapping.withTagMappings ctx hash @@ -592,7 +592,7 @@ module WebLog = 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 @@ -604,7 +604,7 @@ module WebLog = 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 } diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 996ae5e..35b668b 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -418,7 +418,7 @@ 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" } + 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 } @@ -433,7 +433,7 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next | Some f -> hashForPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" |> withAntiCsrf ctx - |> addToHash ViewContext.Model (EditCustomFeedModel.fromFeed f) + |> addToHash ViewContext.Model (EditCustomFeedModel.FromFeed f) |> addToHash "medium_values" [| KeyValuePair.Create("", "– Unspecified –") KeyValuePair.Create(string Podcast, "Podcast") @@ -464,7 +464,7 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> do! data.WebLog.UpdateRssOptions webLog WebLogCache.set webLog do! addMessage ctx { - UserMessage.success with + 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 @@ -488,9 +488,9 @@ let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun ne } 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" } + 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 } diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 43ccc11..07041af 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -252,7 +252,7 @@ module Error = else if isHtmx ctx then let messages = [| - { UserMessage.error with + { UserMessage.Error with Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" } |] @@ -264,7 +264,7 @@ module Error = 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" } |] RequestErrors.notFound (messagesToHeaders messages) earlyReturn ctx else RequestErrors.NOT_FOUND "Not found" earlyReturn ctx) @@ -272,7 +272,7 @@ module Error = let server message : HttpHandler = handleContext (fun ctx -> if isHtmx ctx then - let messages = [| { UserMessage.error with Message = message } |] + let messages = [| { UserMessage.Error with Message = message } |] ServerErrors.internalError (messagesToHeaders messages) earlyReturn ctx else ServerErrors.INTERNAL_ERROR message earlyReturn ctx) @@ -351,14 +351,14 @@ let requireAccess level : HttpHandler = fun next ctx -> task { | Some userLevel when userLevel.HasAccess level -> return! next ctx | Some userLevel -> do! addMessage ctx - { UserMessage.warning with + { 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 } diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 099c7b3..9609427 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -36,7 +36,7 @@ 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 @@ -56,8 +56,8 @@ let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta 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" } + 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 } @@ -68,7 +68,7 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> return! hashForPage "Manage Prior Permalinks" |> withAntiCsrf ctx - |> addToHash ViewContext.Model (ManagePermalinksModel.fromPage pg) + |> addToHash ViewContext.Model (ManagePermalinksModel.FromPage pg) |> adminView "permalinks" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx @@ -83,7 +83,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 @@ -97,7 +97,7 @@ let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> return! hashForPage "Manage Page Revisions" |> withAntiCsrf ctx - |> addToHash ViewContext.Model (ManageRevisionsModel.fromPage ctx.WebLog pg) + |> addToHash ViewContext.Model (ManageRevisionsModel.FromPage ctx.WebLog pg) |> adminView "revisions" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx @@ -109,7 +109,7 @@ let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> 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" } + do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } return! redirectToGet $"admin/page/{pgId}/revisions" next ctx | None -> return! Error.notFound next ctx } @@ -152,7 +152,7 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun 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" } + 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, _ @@ -164,7 +164,7 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun 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" } + do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } return! adminBareView "" next ctx (makeHash {| content = "" |}) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ @@ -191,7 +191,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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" } + 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 diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 161b441..780cac5 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -47,7 +47,7 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I posts |> Seq.ofList |> Seq.truncate perPage - |> Seq.map (PostListItem.fromPost webLog) + |> Seq.map (PostListItem.FromPost webLog) |> Array.ofSeq let! olderPost, newerPost = match listType with @@ -232,7 +232,7 @@ 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 + let model = EditPostModel.FromPost ctx.WebLog post return! hashForPage title |> withAntiCsrf ctx @@ -255,8 +255,8 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { // POST /admin/post/{id}/delete 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" } + | 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 } @@ -267,7 +267,7 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx return! hashForPage "Manage Prior Permalinks" |> withAntiCsrf ctx - |> addToHash ViewContext.Model (ManagePermalinksModel.fromPost post) + |> addToHash ViewContext.Model (ManagePermalinksModel.FromPost post) |> adminView "permalinks" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx @@ -282,7 +282,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 @@ -296,7 +296,7 @@ let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx - return! hashForPage "Manage Post Revisions" |> withAntiCsrf ctx - |> addToHash ViewContext.Model (ManageRevisionsModel.fromPost ctx.WebLog post) + |> addToHash ViewContext.Model (ManageRevisionsModel.FromPost ctx.WebLog post) |> adminView "revisions" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx @@ -308,7 +308,7 @@ let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx 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" } + do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } return! redirectToGet $"admin/post/{postId}/revisions" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx @@ -352,7 +352,7 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f 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" } + 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, _ @@ -364,7 +364,7 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu 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" } + do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } return! adminBareView "" next ctx (makeHash {| content = "" |}) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ @@ -408,7 +408,7 @@ 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" } + 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 diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index 6e1b33a..3493bf6 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -117,7 +117,7 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { [] let allFiles = dbUploads - |> List.map (DisplayUpload.fromUpload webLog Database) + |> List.map (DisplayUpload.FromUpload webLog Database) |> List.append diskUploads |> List.sortByDescending (fun file -> file.UpdatedOn, file.Path) return! @@ -169,7 +169,7 @@ 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" } + do! addMessage ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" } return! showUploads next ctx else return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx @@ -179,7 +179,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> 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" } + do! addMessage ctx { UserMessage.Success with Message = $"{fileName} deleted successfully" } return! showUploads next ctx | Error _ -> return! Error.notFound next ctx } @@ -202,7 +202,7 @@ let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun ne if File.Exists path then File.Delete path removeEmptyDirectories ctx.WebLog filePath - do! addMessage ctx { UserMessage.success with Message = $"{filePath} deleted successfully" } + do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" } return! showUploads next ctx else return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index aa518c4..9f19efe 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -38,7 +38,7 @@ let logOn returnUrl : HttpHandler = fun next ctx -> | 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 } + |> addToHash ViewContext.Model { LogOnModel.Empty with ReturnTo = returnTo } |> adminView "log-on" next ctx @@ -66,7 +66,7 @@ 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 + { UserMessage.Success with Message = "Log on successful" Detail = Some $"Welcome to {ctx.WebLog.Name}!" } @@ -75,14 +75,14 @@ let doLogOn : HttpHandler = fun next ctx -> task { | Some url -> redirectTo false url next ctx | None -> redirectToGet "admin/dashboard" next ctx | Error msg -> - do! addMessage ctx { UserMessage.error with Message = 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 } @@ -100,7 +100,7 @@ let all : HttpHandler = fun next ctx -> task { return! hashForPage "User Administration" |> withAntiCsrf ctx - |> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList) + |> addToHash "users" (users |> List.map (DisplayUser.FromUser ctx.WebLog) |> Array.ofList) |> adminBareView "user-list-body" next ctx } @@ -125,7 +125,7 @@ let edit usrId : HttpHandler = fun next ctx -> task { 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 } @@ -140,13 +140,13 @@ let delete userId : HttpHandler = fun next ctx -> task { match! data.WebLogUser.Delete user.Id user.WebLogId with | Ok _ -> do! addMessage ctx - { UserMessage.success with + { UserMessage.Success with Message = $"User {user.DisplayName} deleted successfully" } return! all next ctx | Error msg -> do! addMessage ctx - { UserMessage.error with + { UserMessage.Error with Message = $"User {user.DisplayName} was not deleted" Detail = Some msg } @@ -168,7 +168,7 @@ let private showMyInfo (model: EditMyInfoModel) (user: WebLogUser) : HttpHandler // 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! showMyInfo (EditMyInfoModel.FromUser user) user next ctx | None -> return! Error.notFound next ctx } @@ -188,10 +188,10 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { } 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" } + 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" } + do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" } return! showMyInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user next ctx | None -> return! Error.notFound next ctx } @@ -222,12 +222,12 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { 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 + { 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" } + 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 -- 2.45.1 From cb02055d875959590686248bacce659948054ed9 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Dec 2023 20:38:37 -0500 Subject: [PATCH 019/123] WIP on formatting --- src/MyWebLog.Data/Interfaces.fs | 3 +- src/MyWebLog.Data/PostgresData.fs | 6 +- src/MyWebLog.Data/RethinkDbData.fs | 39 ++++---- src/MyWebLog.Data/Utils.fs | 17 ++-- src/MyWebLog/Caches.fs | 46 ++++----- src/MyWebLog/DotLiquidBespoke.fs | 16 +-- src/MyWebLog/Handlers/Admin.fs | 74 +++++++------- src/MyWebLog/Handlers/Feed.fs | 43 ++++---- src/MyWebLog/Handlers/Helpers.fs | 93 +++++++++--------- src/MyWebLog/Handlers/Page.fs | 7 +- src/MyWebLog/Handlers/Post.fs | 27 +++-- src/MyWebLog/Handlers/Routes.fs | 4 +- src/MyWebLog/Handlers/Upload.fs | 40 ++++---- src/MyWebLog/Handlers/User.fs | 37 +++---- src/MyWebLog/Maintenance.fs | 152 +++++++++++++---------------- src/MyWebLog/Program.fs | 98 +++++++++---------- 16 files changed, 331 insertions(+), 371 deletions(-) diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index 0ec05d5..15d8069 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -7,6 +7,7 @@ open Newtonsoft.Json open NodaTime /// The result of a category deletion attempt +[] type CategoryDeleteResult = /// The category was deleted successfully | CategoryDeleted @@ -32,7 +33,7 @@ type ICategoryData = abstract member Delete : CategoryId -> WebLogId -> Task /// Find all categories for a web log, sorted alphabetically and grouped by hierarchy - abstract member FindAllForView : WebLogId -> Task + abstract member FindAllForView : WebLogId -> Task /// Find a category by its ID abstract member FindById : CategoryId -> WebLogId -> Task diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 1c01195..4ea5b44 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -9,15 +9,15 @@ open Newtonsoft.Json open Npgsql.FSharp /// Data implementation for PostgreSQL -type PostgresData (log : ILogger, ser : JsonSerializer) = +type PostgresData(log: ILogger, ser: JsonSerializer) = /// Create any needed tables let ensureTables () = backgroundTask { // Set up the PostgreSQL document store Configuration.useSerializer { new IDocumentSerializer with - member _.Serialize<'T> (it : 'T) : string = Utils.serialize ser it - member _.Deserialize<'T> (it : string) : 'T = Utils.deserialize ser it + member _.Serialize<'T>(it: 'T) : string = Utils.serialize ser it + member _.Deserialize<'T>(it: string) : 'T = Utils.deserialize ser it } let! tables = diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 068b2b1..59bf934 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -69,20 +69,20 @@ module private RethinkHelpers = let r = RethinkDB.R /// Verify that the web log ID matches before returning an item - let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (f : Net.IConnection -> Task<'T option>) = + let verifyWebLog<'T> webLogId (prop: 'T -> WebLogId) (f: Net.IConnection -> Task<'T option>) = fun conn -> backgroundTask { match! f conn with Some it when (prop it) = webLogId -> return Some it | _ -> return None } /// Get the first item from a list, or None if the list is empty - let tryFirst<'T> (f : Net.IConnection -> Task<'T list>) = + let tryFirst<'T> (f: Net.IConnection -> Task<'T list>) = fun conn -> backgroundTask { let! results = f conn return results |> List.tryHead } /// Cast a strongly-typed list to an object list - let objList<'T> (objects : 'T list) = objects |> List.map (fun it -> it :> obj) + let objList<'T> (objects: 'T list) = objects |> List.map (fun it -> it :> obj) open System @@ -92,15 +92,15 @@ open RethinkDb.Driver.FSharp open RethinkHelpers /// RethinkDB implementation of data functions for myWebLog -type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger) = +type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger) = /// Match theme asset IDs by their prefix (the theme ID) let matchAssetByThemeId themeId = let keyPrefix = $"^{themeId}/" - fun (row : Ast.ReqlExpr) -> row[nameof ThemeAsset.Empty.Id].Match keyPrefix :> obj + 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 = + let withoutTemplateText (row: Ast.ReqlExpr) : obj = {| Templates = row[nameof Theme.Empty.Templates].Without [| nameof ThemeTemplate.Empty.Text |] |} /// Ensure field indexes exist, as well as special indexes for selected tables @@ -192,7 +192,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger Array.tryFind (fun c -> fst c = cat.Id) |> Option.map snd - |> Option.defaultValue 0 - }) + |> Option.defaultValue 0 }) |> Array.ofSeq } @@ -331,7 +330,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger verifyWebLog webLogId (fun c -> c.WebLogId) <| conn + |> verifyWebLog webLogId _.WebLogId <| conn member _.FindByWebLog webLogId = rethink { withTable Table.Category @@ -533,7 +532,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger verifyWebLog webLogId (fun p -> p.WebLogId) <| conn + |> verifyWebLog webLogId _.WebLogId <| conn member _.FindByPermalink permalink webLogId = rethink { @@ -604,7 +603,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger verifyWebLog webLogId (fun p -> p.WebLogId) <| conn + |> verifyWebLog webLogId _.WebLogId <| conn member _.FindCurrentPermalink permalinks webLogId = backgroundTask { let! result = @@ -617,7 +616,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger tryFirst) conn - return result |> Option.map (fun post -> post.Permalink) + return result |> Option.map _.Permalink } member _.FindFullByWebLog webLogId = rethink { @@ -756,7 +755,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger verifyWebLog webLogId (_.WebLogId) <| conn + |> verifyWebLog webLogId _.WebLogId <| conn member _.FindByUrlValue urlValue webLogId = rethink { @@ -908,7 +907,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger verifyWebLog webLogId (fun u -> u.WebLogId) <| conn + |> verifyWebLog webLogId _.WebLogId <| conn match upload with | Some up -> do! rethink { @@ -939,7 +938,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Upload - between [| webLogId :> obj; r.Minval () |] [| webLogId :> obj; r.Maxval () |] + between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |] [ Index Index.WebLogAndPath ] resultCursor; withRetryCursorDefault; toList conn } @@ -971,7 +970,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { + let! thePostIds = rethink<{| Id: string |} list> { withTable Table.Post getAll [ webLogId ] (nameof Post.Empty.WebLogId) pluck [ nameof Post.Empty.Id ] @@ -1078,7 +1077,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger verifyWebLog webLogId (fun u -> u.WebLogId) <| conn + |> verifyWebLog webLogId _.WebLogId <| conn member this.Delete userId webLogId = backgroundTask { match! this.FindById userId webLogId with @@ -1205,7 +1204,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { + let! version = rethink<{| Id: string |} list> { withTable Table.DbVersion limit 1 result; withRetryOnce conn diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index 2af59a7..f26ff02 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -9,17 +9,16 @@ open MyWebLog.ViewModels let currentDbVersion = "v2.1" /// Create a category hierarchy from the given list of categories -let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq { +let rec orderByHierarchy (cats: Category list) parentId slugBase parentNames = seq { for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.Slug - { 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 - } + { 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 } yield! orderByHierarchy cats (Some cat.Id) (Some fullSlug) ([ cat.Name ] |> List.append parentNames) } diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index 9230cae..c459920 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -13,25 +13,25 @@ module Extensions = open Microsoft.Extensions.DependencyInjection /// Hold variable for the configured generator string - let mutable private generatorString : string option = None + let mutable private generatorString: string option = None type HttpContext with /// The anti-CSRF service - member this.AntiForgery = this.RequestServices.GetRequiredService () + member this.AntiForgery = this.RequestServices.GetRequiredService() /// The cross-site request forgery token set for this request member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this /// The data implementation - member this.Data = this.RequestServices.GetRequiredService () + member this.Data = this.RequestServices.GetRequiredService() /// The generator string member this.Generator = match generatorString with | Some gen -> gen | None -> - let cfg = this.RequestServices.GetRequiredService () + let cfg = this.RequestServices.GetRequiredService() generatorString <- match Option.ofObj cfg["Generator"] with | Some gen -> Some gen @@ -84,7 +84,7 @@ module WebLogCache = 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 @@ -106,8 +106,8 @@ module WebLogCache = _cache /// Fill the web log cache from the database - let fill (data : IData) = backgroundTask { - let! webLogs = data.WebLog.All () + let fill (data: IData) = backgroundTask { + let! webLogs = data.WebLog.All() webLogs |> List.iter set } @@ -126,28 +126,28 @@ module PageListCache = open MyWebLog.ViewModels /// Cache of displayed pages - let private _cache = ConcurrentDictionary () + let private _cache = ConcurrentDictionary () - let private fillPages (webLog : WebLog) pages = + 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.Id + 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.Id] + let get (ctx: HttpContext) = _cache[ctx.WebLog.Id] /// Update the pages for the current web log - let update (ctx : HttpContext) = backgroundTask { + let update (ctx: HttpContext) = backgroundTask { let! pages = ctx.Data.Page.FindListed ctx.WebLog.Id fillPages ctx.WebLog pages } /// Refresh the pages for the given web log - let refresh (webLog : WebLog) (data : IData) = backgroundTask { + let refresh (webLog: WebLog) (data: IData) = backgroundTask { let! pages = data.Page.FindListed webLog.Id fillPages webLog pages } @@ -159,22 +159,22 @@ module CategoryCache = open MyWebLog.ViewModels /// The cache itself - let private _cache = ConcurrentDictionary () + let private _cache = ConcurrentDictionary () /// Are there categories cached for this web log? - let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.Id + let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id /// Get the categories for the web log for this request - let get (ctx : HttpContext) = _cache[ctx.WebLog.Id] + let get (ctx: HttpContext) = _cache[ctx.WebLog.Id] /// Update the cache with fresh data - let update (ctx : HttpContext) = backgroundTask { + let update (ctx: HttpContext) = backgroundTask { let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id _cache[ctx.WebLog.Id] <- cats } /// Refresh the category cache for the given web log - let refresh webLogId (data : IData) = backgroundTask { + let refresh webLogId (data: IData) = backgroundTask { let! cats = data.Category.FindAllForView webLogId _cache[webLogId] <- cats } @@ -191,7 +191,7 @@ module TemplateCache = let private _cache = ConcurrentDictionary () /// Custom include parameter pattern - let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2) + let private hasInclude = Regex("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2) /// Get a template for the given theme and template name let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask { @@ -220,7 +220,7 @@ module TemplateCache = 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) + _cache[templatePath] <- Template.Parse(text, SyntaxCompatibility.DotLiquid22) return Ok _cache[templatePath] | None -> return Error $"Theme ID {themeId} does not have a template named {templateName}" @@ -254,14 +254,14 @@ module ThemeAssetCache = let get themeId = _cache[themeId] /// Refresh the list of assets for the given theme - let refreshTheme themeId (data : IData) = backgroundTask { + let refreshTheme themeId (data: IData) = backgroundTask { let! assets = data.ThemeAsset.FindByTheme themeId _cache[themeId] <- assets |> List.map (fun a -> match a.Id with ThemeAssetId (_, path) -> path) } /// Fill the theme asset cache - let fill (data : IData) = backgroundTask { - let! assets = data.ThemeAsset.All () + let fill (data: IData) = backgroundTask { + let! assets = data.ThemeAsset.All() for asset in assets do let (ThemeAssetId (themeId, path)) = asset.Id if not (_cache.ContainsKey themeId) then _cache[themeId] <- [] diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 8cfdc9d..73594f1 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -17,7 +17,7 @@ type Context with /// Does an asset exist for the current theme? -let assetExists fileName (webLog : WebLog) = +let assetExists fileName (webLog: WebLog) = ThemeAssetCache.get webLog.ThemeId |> List.exists (fun it -> it = fileName) /// Obtain the link from known types @@ -149,10 +149,10 @@ type PageHeadTag() = /// Create various items in the page header based on the state of the page being generated -type PageFootTag () = - inherit Tag () +type PageFootTag() = + inherit Tag() - override this.Render (context : Context, result : TextWriter) = + override this.Render(context: Context, result: TextWriter) = let webLog = context.WebLog // spacer let s = " " @@ -161,12 +161,12 @@ type PageFootTag () = result.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}" if assetExists "script.js" webLog then - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" + - /// A filter to generate a relative link -type RelativeLinkFilter () = - static member RelativeLink (ctx : Context, item : obj) = +type RelativeLinkFilter() = + static member RelativeLink(ctx: Context, item: obj) = permalink item ctx.WebLog.RelativeUrl diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index bae83c0..136d793 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -12,7 +12,7 @@ module Dashboard = // GET /admin/dashboard let user : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let getCount (f : WebLogId -> Task) = f ctx.WebLog.Id + let getCount (f: WebLogId -> Task) = f ctx.WebLog.Id let data = ctx.Data let! posts = getCount (data.Post.CountByStatus Published) let! drafts = getCount (data.Post.CountByStatus Draft) @@ -89,7 +89,7 @@ module Cache = do! addMessage ctx { UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" } else - match! data.WebLog.FindById (WebLogId webLogId) with + match! data.WebLog.FindById(WebLogId webLogId) with | Some webLog -> WebLogCache.set webLog do! PageListCache.refresh webLog data @@ -109,17 +109,15 @@ module Cache = do! ThemeAssetCache.fill data do! addMessage ctx { UserMessage.Success with - Message = "Successfully cleared template cache and refreshed theme asset cache" - } + Message = "Successfully cleared template cache and refreshed theme asset cache" } else - match! data.Theme.FindById (ThemeId themeId) with + 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}" - } + 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 @@ -156,10 +154,10 @@ module Category = 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) + | Some cat -> return Some("Edit Category", cat) | None -> return None } match result with @@ -175,7 +173,7 @@ module Category = // POST /admin/category/save let save : HttpHandler = fun next ctx -> task { let data = ctx.Data - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let category = 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 @@ -186,8 +184,7 @@ module Category = 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" } @@ -249,7 +246,7 @@ module RedirectRules = } /// Update the web log's redirect rules in the database, the request web log, and the web log cache - let private updateRedirectRules (ctx : HttpContext) webLog = backgroundTask { + let private updateRedirectRules (ctx: HttpContext) webLog = backgroundTask { do! ctx.Data.WebLog.UpdateRedirectRules webLog ctx.Items["webLog"] <- webLog WebLogCache.set webLog @@ -311,7 +308,7 @@ module TagMapping = open Microsoft.AspNetCore.Http /// Add tag mappings to the given hash - let withTagMappings (ctx : HttpContext) hash = task { + let withTagMappings (ctx: HttpContext) hash = task { let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id return addToHash "mappings" mappings hash @@ -414,9 +411,9 @@ module Theme = zip.Entries |> Seq.filter (fun it -> it.Name.EndsWith ".liquid") |> Seq.map (fun templateItem -> backgroundTask { - use templateFile = new StreamReader (templateItem.Open ()) - let! template = templateFile.ReadToEndAsync () - return { Name = templateItem.Name.Replace (".liquid", ""); Text = template } + use templateFile = new StreamReader(templateItem.Open()) + let! template = templateFile.ReadToEndAsync() + return { Name = templateItem.Name.Replace(".liquid", ""); Text = template } }) let! templates = Task.WhenAll tasks return @@ -427,37 +424,37 @@ module Theme = } /// 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 - let assetName = asset.FullName.Replace ("wwwroot/", "") + let private updateAssets themeId (zip: ZipArchive) (data: IData) = backgroundTask { + 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 () + use stream = new MemoryStream() do! asset.Open().CopyToAsync stream do! data.ThemeAsset.Save - { Id = ThemeAssetId (themeId, assetName) + { Id = ThemeAssetId(themeId, assetName) UpdatedOn = LocalDateTime.FromDateTime(asset.LastWriteTime.DateTime) - .InZoneLeniently(DateTimeZone.Utc).ToInstant () - Data = stream.ToArray () + .InZoneLeniently(DateTimeZone.Utc).ToInstant() + Data = stream.ToArray() } } /// Derive the theme ID from the file name given - let deriveIdFromFileName (fileName : string) = - let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-") + let deriveIdFromFileName (fileName: string) = + let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace(" ", "-") if themeName.EndsWith "-theme" then - if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then - Ok (ThemeId (themeName.Substring (0, themeName.Length - 6))) + if Regex.IsMatch(themeName, """^[a-z0-9\-]+$""") then + Ok(ThemeId(themeName[..themeName.Length - 6])) 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 loadFromZip themeId file (data : IData) = backgroundTask { + let loadFromZip themeId file (data: IData) = backgroundTask { let! isNew, theme = backgroundTask { match! data.Theme.FindById themeId with | Some t -> return false, t | None -> return true, { Theme.Empty with Id = themeId } } - use zip = new ZipArchive (file, ZipArchiveMode.Read) + use zip = new ZipArchive(file, ZipArchiveMode.Read) let! theme = updateNameAndVersion theme zip if not isNew then do! data.ThemeAsset.DeleteByTheme theme.Id let! theme = updateTemplates { theme with Templates = [] } zip @@ -489,14 +486,12 @@ module Theme = do! themeFile.CopyToAsync file do! addMessage ctx { UserMessage.Success with - Message = $"""Theme {if isNew then "add" else "updat"}ed successfully""" - } + 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" - } + 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" } @@ -517,8 +512,7 @@ module Theme = | 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" - } + 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 @@ -588,7 +582,7 @@ module WebLog = // POST /admin/settings let saveSettings : HttpHandler = fun next ctx -> task { let data = ctx.Data - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() match! data.WebLog.FindById ctx.WebLog.Id with | Some webLog -> let oldSlug = webLog.Slug @@ -600,9 +594,9 @@ module WebLog = if oldSlug <> webLog.Slug then // Rename disk directory if it exists - let uploadRoot = Path.Combine ("wwwroot", "upload") - let oldDir = Path.Combine (uploadRoot, oldSlug) - if Directory.Exists oldDir then Directory.Move (oldDir, Path.Combine (uploadRoot, webLog.Slug)) + let uploadRoot = Path.Combine("wwwroot", "upload") + 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" } return! redirectToGet "admin/settings" next ctx diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 35b668b..94dfd75 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -23,7 +23,7 @@ type FeedType = | Custom of CustomFeed * string /// Derive the type of RSS feed requested -let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = +let deriveFeedType (ctx: HttpContext) feedPath : (FeedType * int) option = let webLog = ctx.WebLog let debug = debug "Feed" ctx let name = $"/{webLog.Rss.FeedName}" @@ -33,14 +33,14 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = match webLog.Rss.IsFeedEnabled && feedPath = name with | true -> debug (fun () -> "Found standard feed") - Some (StandardFeed feedPath, postCount) + Some(StandardFeed feedPath, postCount) | false -> // Category and tag feeds are handled by defined routes; check for custom feed match webLog.Rss.CustomFeeds |> 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 _.ItemsInFeed |> Option.defaultValue postCount) + Some(Custom(feed, feedPath), feed.Podcast |> Option.map _.ItemsInFeed |> Option.defaultValue postCount) | None -> debug (fun () -> "No matching feed found") None @@ -61,7 +61,7 @@ let private getFeedPosts ctx feedType = | Tag tag -> data.Post.FindPageOfTaggedPosts ctx.WebLog.Id tag 1 /// Strip HTML from a string -let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace (text, "<(.|\n)*?>", "") +let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace(text, "<(.|\n)*?>", "") /// XML namespaces for building RSS feeds [] @@ -231,8 +231,8 @@ let private addEpisode (webLog: WebLog) (podcast: PodcastOptions) (episode: Epis item /// Add a namespace to the feed -let private addNamespace (feed : SyndicationFeed) alias nsUrl = - feed.AttributeExtensions.Add (XmlQualifiedName (alias, "http://www.w3.org/2000/xmlns/"), nsUrl) +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: WebLog) (rssFeed: SyndicationFeed) (feed: CustomFeed) = @@ -313,7 +313,7 @@ let private addPodcast (webLog: WebLog) (rssFeed: SyndicationFeed) (feed: Custom /// Get the feed's self reference and non-feed link let private selfAndLink webLog feedType ctx = - let withoutFeed (it : string) = Permalink (it.Replace ($"/{webLog.Rss.FeedName}", "")) + let withoutFeed (it: string) = Permalink(it.Replace($"/{webLog.Rss.FeedName}", "")) match feedType with | StandardFeed path | CategoryFeed (_, path) @@ -325,8 +325,8 @@ let private selfAndLink webLog feedType ctx = | Tag tag -> feed.Path, Permalink $"""tag/{tag.Replace(" ", "+")}/""" /// Set the title and description of the feed based on its source -let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCategory[]) (feed : SyndicationFeed) = - let cleanText opt def = TextSyndicationContent (stripHtml (defaultArg opt def)) +let private setTitleAndDescription feedType (webLog: WebLog) (cats: DisplayCategory[]) (feed: SyndicationFeed) = + let cleanText opt def = TextSyndicationContent(stripHtml (defaultArg opt def)) match feedType with | StandardFeed _ -> feed.Title <- cleanText None webLog.Name @@ -412,7 +412,7 @@ let generate (feedType: FeedType) postCount : HttpHandler = fun next ctx -> back // POST /admin/settings/rss let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let data = ctx.Data - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() match! data.WebLog.FindById ctx.WebLog.Id with | Some webLog -> let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss } @@ -452,7 +452,7 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> let data = ctx.Data match! data.WebLog.FindById ctx.WebLog.Id with | Some webLog -> - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let theFeed = match model.Id with | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() } @@ -460,13 +460,12 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> 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""" - } + 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 @@ -479,13 +478,11 @@ let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun ne | 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" } diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 07041af..49a1f5f 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -8,8 +8,8 @@ open Microsoft.AspNetCore.Http type ISession with /// Set an item in the session - member this.Set<'T> (key, item : 'T) = - this.SetString (key, JsonSerializer.Serialize item) + member this.Set<'T>(key, item: 'T) = + this.SetString(key, JsonSerializer.Serialize item) /// Get an item from the session member this.TryGet<'T> key = @@ -126,28 +126,28 @@ module ViewContext = let private sessionLoadedKey = "session-loaded" /// Load the session if it has not been loaded already; ensures async access but not excessive loading -let private loadSession (ctx : HttpContext) = task { +let private loadSession (ctx: HttpContext) = task { if not (ctx.Items.ContainsKey sessionLoadedKey) then - do! ctx.Session.LoadAsync () - ctx.Items.Add (sessionLoadedKey, "yes") + do! ctx.Session.LoadAsync() + ctx.Items.Add(sessionLoadedKey, "yes") } /// Ensure that the session is committed -let private commitSession (ctx : HttpContext) = task { - if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync () +let private commitSession (ctx: HttpContext) = task { + if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync() } open MyWebLog.ViewModels /// Add a message to the user's session -let addMessage (ctx : HttpContext) message = task { +let addMessage (ctx: HttpContext) message = task { do! loadSession ctx let msg = match ctx.Session.TryGet ViewContext.Messages with Some it -> it | None -> [] - ctx.Session.Set (ViewContext.Messages, message :: msg) + ctx.Session.Set(ViewContext.Messages, message :: msg) } /// Get any messages from the user's session, removing them in the process -let messages (ctx : HttpContext) = task { +let messages (ctx: HttpContext) = task { do! loadSession ctx match ctx.Session.TryGet ViewContext.Messages with | Some msg -> @@ -160,21 +160,21 @@ open MyWebLog open DotLiquid /// Shorthand for creating a DotLiquid hash from an anonymous object -let makeHash (values : obj) = +let makeHash (values: obj) = Hash.FromAnonymousObject values /// Create a hash with the page title filled -let hashForPage (title : string) = +let hashForPage (title: string) = makeHash {| page_title = title |} /// Add a key to the hash, returning the modified hash // (note that the hash itself is mutated; this is only used to make it pipeable) -let addToHash key (value : obj) (hash : Hash) = - if hash.ContainsKey key then hash[key] <- value else hash.Add (key, value) +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) = +let withAntiCsrf (ctx: HttpContext) = addToHash ViewContext.AntiCsrfTokens ctx.CsrfTokenSet open System.Security.Claims @@ -186,13 +186,13 @@ open Giraffe.ViewEngine let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified /// Populate the DotLiquid hash with standard information -let addViewContext ctx (hash : Hash) = task { +let addViewContext ctx (hash: Hash) = 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[ViewContext.Messages] <- Array.concat [ hash[ViewContext.Messages] :?> UserMessage array; messages ] hash else ctx.User.Claims @@ -214,11 +214,11 @@ let addViewContext ctx (hash : Hash) = task { } /// Is the request from htmx? -let isHtmx (ctx : HttpContext) = +let isHtmx (ctx: HttpContext) = ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh /// Convert messages to headers (used for htmx responses) -let messagesToHeaders (messages : UserMessage array) : HttpHandler = +let messagesToHeaders (messages: UserMessage array) : HttpHandler = seq { yield! messages @@ -253,8 +253,7 @@ module Error = if isHtmx ctx then let messages = [| { UserMessage.Error with - Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" - } + Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" } |] (messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx else setStatusCode 401 earlyReturn ctx @@ -278,7 +277,7 @@ module Error = /// Render a view for the specified theme, using the specified template, layout, and hash -let viewForTheme themeId template next ctx (hash : Hash) = task { +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; @@ -296,13 +295,13 @@ let viewForTheme themeId template next ctx (hash : Hash) = task { } /// Render a bare view for the specified theme, using the specified template and hash -let bareForTheme themeId template next ctx (hash : Hash) = task { +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) + | Ok contentTemplate -> return Ok(addToHash ViewContext.Content (contentTemplate.Render hash) hash) | Error message -> return Error message } match! withContent with @@ -311,7 +310,7 @@ let bareForTheme themeId template next ctx (hash : Hash) = task { match! TemplateCache.get themeId "layout-bare" ctx.Data with | Ok layoutTemplate -> return! - (messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[]) + (messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array) >=> htmlString (layoutTemplate.Render completeHash)) next ctx | Error message -> return! Error.server message next ctx @@ -353,8 +352,7 @@ let requireAccess level : HttpHandler = fun next ctx -> task { do! addMessage ctx { UserMessage.Warning with Message = $"The page you tried to access requires {level} privileges" - Detail = Some $"Your account only has {userLevel} privileges" - } + Detail = Some $"Your account only has {userLevel} privileges" } return! Error.notAuthorized next ctx | None -> do! addMessage ctx @@ -363,44 +361,44 @@ let requireAccess level : HttpHandler = fun next ctx -> task { } /// Determine if a user is authorized to edit a page or post, given the author -let canEdit authorId (ctx : HttpContext) = +let canEdit authorId (ctx: HttpContext) = ctx.UserId = authorId || ctx.HasAccessLevel Editor open System.Threading.Tasks /// Create a Task with a Some result for the given object -let someTask<'T> (it : 'T) = Task.FromResult (Some it) +let someTask<'T> (it: 'T) = Task.FromResult(Some it) open System.Collections.Generic open MyWebLog.Data /// Get the templates available for the current web log's theme (in a key/value pair list) -let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask { +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}) -") + KeyValuePair.Create("", $"- 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 -> KeyValuePair.Create(it.Name, it.Name)) } |> Array.ofSeq - | None -> return [| KeyValuePair.Create ("", $"- Default (single-{typ}) -") |] + | None -> return [| KeyValuePair.Create("", $"- Default (single-{typ}) -") |] } /// Get all authors for a list of posts as metadata items -let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) = +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) = +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 @@ -421,8 +419,8 @@ open System.Globalization open NodaTime /// Parse a date/time to UTC -let parseToUtc (date : string) = - Instant.FromDateTimeUtc (DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal)) +let parseToUtc (date: string) = + Instant.FromDateTimeUtc(DateTime.Parse(date, null, DateTimeStyles.AdjustToUniversal)) open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.Logging @@ -431,25 +429,24 @@ open Microsoft.Extensions.Logging let mutable private debugEnabled : bool option = None /// Is debug enabled for handlers? -let private isDebugEnabled (ctx : HttpContext) = +let private isDebugEnabled (ctx: HttpContext) = match debugEnabled with | Some flag -> flag | None -> - let fac = ctx.RequestServices.GetRequiredService () + let fac = ctx.RequestServices.GetRequiredService() let log = fac.CreateLogger "MyWebLog.Handlers" - debugEnabled <- Some (log.IsEnabled LogLevel.Debug) + debugEnabled <- Some(log.IsEnabled LogLevel.Debug) debugEnabled.Value /// Log a debug message -let debug (name : string) ctx msg = +let debug (name: string) ctx msg = if isDebugEnabled ctx then - let fac = ctx.RequestServices.GetRequiredService () + let fac = ctx.RequestServices.GetRequiredService() let log = fac.CreateLogger $"MyWebLog.Handlers.{name}" - log.LogDebug (msg ()) + log.LogDebug(msg ()) /// Log a warning message -let warn (name : string) (ctx : HttpContext) msg = - let fac = ctx.RequestServices.GetRequiredService () +let warn (name: string) (ctx: HttpContext) msg = + let fac = ctx.RequestServices.GetRequiredService() let log = fac.CreateLogger $"MyWebLog.Handlers.{name}" log.LogWarning msg - \ No newline at end of file diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 9609427..28b8074 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -76,7 +76,7 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> // POST /admin/page/permalinks let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let pageId = PageId model.Id match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with | Some pg when canEdit pg.AuthorId ctx -> @@ -117,7 +117,7 @@ let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> open Microsoft.AspNetCore.Http /// Find the page and the requested revision -let private findPageRevision pgId revDate (ctx : HttpContext) = task { +let private findPageRevision pgId revDate (ctx: HttpContext) = task { match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with | Some pg -> let asOf = parseToUtc revDate @@ -150,8 +150,7 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun do! ctx.Data.Page.Update { pg with Revisions = { rev with AsOf = Noda.now () } - :: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) - } + :: (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 diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 780cac5..c5d6bec 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -6,7 +6,7 @@ open System.Collections.Generic open MyWebLog /// Parse a slug and page number from an "everything else" URL -let private parseSlugAndPage webLog (slugAndPage : string seq) = +let private parseSlugAndPage webLog (slugAndPage: string seq) = let fullPath = slugAndPage |> Seq.head let slugPath = slugAndPage |> Seq.skip 1 |> Seq.head let slugs, isFeed = @@ -24,9 +24,10 @@ let private parseSlugAndPage webLog (slugAndPage : string seq) = | idx when idx + 2 = slugs.Length -> Some (int slugs[pageIdx + 1]) | _ -> None let slugParts = if pageIdx > 0 then Array.truncate pageIdx slugs else slugs - pageNbr, String.Join ("/", slugParts), isFeed + pageNbr, String.Join("/", slugParts), isFeed /// The type of post list being prepared +[] type ListType = | AdminList | CategoryList @@ -55,7 +56,7 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I let post = List.head posts let target = defaultArg post.PublishedOn post.UpdatedOn data.Post.FindSurroundingPosts webLog.Id target - | _ -> Task.FromResult (None, None) + | _ -> Task.FromResult(None, None) let newerLink = match listType, pageNbr with | SinglePost, _ -> newerPost |> Option.map (fun it -> string it.Permalink) @@ -114,7 +115,7 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { } // GET /page/{pageNbr}/ -let redirectToPageOfPosts (pageNbr : int) : HttpHandler = fun next ctx -> +let redirectToPageOfPosts (pageNbr: int) : HttpHandler = fun next ctx -> redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx // GET /category/{slug}/ @@ -163,7 +164,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { | None -> return urlTag } if isFeed then - return! Feed.generate (Feed.TagFeed (tag, $"tag/{rawTag}/{webLog.Rss.FeedName}")) + return! Feed.generate (Feed.TagFeed(tag, $"tag/{rawTag}/{webLog.Rss.FeedName}")) (defaultArg webLog.Rss.ItemsInFeed webLog.PostsPerPage) next ctx else match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with @@ -178,7 +179,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { |> themedView "index" next ctx // Other systems use hyphens for spaces; redirect if this is an old tag link | _ -> - let spacedTag = tag.Replace ("-", " ") + let spacedTag = tag.Replace("-", " ") match! data.Post.FindPageOfTaggedPosts webLog.Id spacedTag pageNbr 1 with | posts when List.length posts > 0 -> let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}" @@ -275,7 +276,7 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx // POST /admin/post/permalinks let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let postId = PostId model.Id match! ctx.Data.Post.FindById postId ctx.WebLog.Id with | Some post when canEdit post.AuthorId ctx -> @@ -317,7 +318,7 @@ let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx open Microsoft.AspNetCore.Http /// Find the post and the requested revision -let private findPostRevision postId revDate (ctx : HttpContext) = task { +let private findPostRevision postId revDate (ctx: HttpContext) = task { match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with | Some post -> let asOf = parseToUtc revDate @@ -350,8 +351,7 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f do! ctx.Data.Post.Update { post with Revisions = { rev with AsOf = Noda.now () } - :: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) - } + :: (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 @@ -380,8 +380,8 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { { Post.Empty with Id = PostId.Create() WebLogId = ctx.WebLog.Id - AuthorId = ctx.UserId - } |> someTask + AuthorId = ctx.UserId } + |> someTask else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id match! tryPost with | Some post when canEdit post.AuthorId ctx -> @@ -396,8 +396,7 @@ 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 diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 52fe990..d103a00 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -11,7 +11,7 @@ module CatchAll = open MyWebLog.ViewModels /// Sequence where the first returned value is the proper handler for the link - let private deriveAction (ctx: HttpContext): HttpHandler seq = + let private deriveAction (ctx: HttpContext) : HttpHandler seq = let webLog = ctx.WebLog let data = ctx.Data let debug = debug "Routes.CatchAll" ctx @@ -80,7 +80,7 @@ module CatchAll = } // GET {all-of-the-above} - let route: HttpHandler = fun next ctx -> + let route : HttpHandler = fun next ctx -> match deriveAction ctx |> Seq.tryHead with Some handler -> handler next ctx | None -> Error.notFound next ctx diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index 3493bf6..aac82d9 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -12,7 +12,7 @@ module private Helpers = open Microsoft.AspNetCore.StaticFiles /// A MIME type mapper instance to use when serving files from the database - let mimeMap = FileExtensionContentTypeProvider () + let mimeMap = FileExtensionContentTypeProvider() /// A cache control header that instructs the browser to cache the result for no more than 30 days let cacheForThirtyDays = @@ -24,7 +24,7 @@ module private Helpers = let slash = Path.DirectorySeparatorChar /// The base directory where uploads are stored, relative to the executable - let uploadDir = Path.Combine ("wwwroot", "upload") + let uploadDir = Path.Combine("wwwroot", "upload") // ~~ SERVING UPLOADS ~~ @@ -35,10 +35,10 @@ 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 = +let checkModified since (ctx: HttpContext) : HttpHandler option = match ctx.Request.Headers.IfModifiedSince with | it when it.Count < 1 -> None - | it when since > Instant.FromDateTimeUtc (DateTime.Parse (it[0], null, DateTimeStyles.AdjustToUniversal)) -> None + | it when since > Instant.FromDateTimeUtc(DateTime.Parse(it[0], null, DateTimeStyles.AdjustToUniversal)) -> None | _ -> Some (setStatusCode 304) @@ -53,29 +53,29 @@ let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx -> let headers = ResponseHeaders ctx.Response.Headers headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path headers.CacheControl <- cacheForThirtyDays - let stream = new MemoryStream (data) + let stream = new MemoryStream(data) streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx open MyWebLog // GET /upload/{web-log-slug}/{**path} -let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task { +let serve (urlParts: string seq) : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog let parts = (urlParts |> Seq.skip 1 |> Seq.head).Split '/' let slug = Array.head parts if slug = webLog.Slug then // Static file middleware will not work in subdirectories; check for an actual file first - let fileName = Path.Combine ("wwwroot", (Seq.head urlParts)[1..]) + let fileName = Path.Combine("wwwroot", (Seq.head urlParts)[1..]) if File.Exists fileName then return! streamFile true fileName None None next ctx else - let path = String.Join ('/', Array.skip 1 parts) + let path = String.Join('/', Array.skip 1 parts) match! ctx.Data.Upload.FindByPath path webLog.Id with | Some upload -> match checkModified upload.UpdatedOn ctx with | Some threeOhFour -> return! threeOhFour next ctx - | None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc ()) 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 @@ -87,28 +87,27 @@ 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 { let webLog = ctx.WebLog let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id let diskUploads = - let path = Path.Combine (uploadDir, webLog.Slug) + let path = Path.Combine(uploadDir, webLog.Slug) try - Directory.EnumerateFiles (path, "*", SearchOption.AllDirectories) + Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories) |> Seq.map (fun file -> let name = Path.GetFileName file let create = - match File.GetCreationTime (Path.Combine (path, file)) with + match File.GetCreationTime(Path.Combine(path, file)) with | dt when dt > DateTime.UnixEpoch -> Some dt | _ -> None { DisplayUpload.Id = "" Name = name - Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace (slash, '/') + Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/') UpdatedOn = create - Source = string Disk - }) + Source = string Disk }) |> List.ofSeq with | :? DirectoryNotFoundException -> [] // This is fine @@ -160,8 +159,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { WebLogId = ctx.WebLog.Id Path = Permalink $"{year}/{month}/{fileName}" UpdatedOn = now - Data = stream.ToArray() - } + Data = stream.ToArray() } do! ctx.Data.Upload.Add file | Disk -> let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month) @@ -185,11 +183,11 @@ let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx } /// Remove a directory tree if it is empty -let removeEmptyDirectories (webLog : WebLog) (filePath : string) = +let removeEmptyDirectories (webLog: WebLog) (filePath: string) = let mutable path = Path.GetDirectoryName filePath let mutable finished = false while (not finished) && path > "" do - let fullPath = Path.Combine (uploadDir, webLog.Slug, path) + let fullPath = Path.Combine(uploadDir, webLog.Slug, path) if Directory.EnumerateFileSystemEntries fullPath |> Seq.isEmpty then Directory.Delete fullPath path <- String.Join(slash, path.Split slash |> Array.rev |> Array.skip 1 |> Array.rev) @@ -198,7 +196,7 @@ let removeEmptyDirectories (webLog : WebLog) (filePath : string) = // POST /admin/upload/delete/{**path} let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let filePath = urlParts |> Seq.skip 1 |> Seq.head - let path = Path.Combine (uploadDir, ctx.WebLog.Slug, filePath) + let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath) if File.Exists path then File.Delete path removeEmptyDirectories ctx.WebLog filePath diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 9f19efe..979ad9e 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -11,17 +11,17 @@ open NodaTime /// Create a password hash a password for a given user let createPasswordHash user password = - PasswordHasher().HashPassword (user, password) + PasswordHasher().HashPassword(user, password) /// Verify whether a password is valid -let verifyPassword user password (ctx : HttpContext) = backgroundTask { +let verifyPassword user password (ctx: HttpContext) = backgroundTask { match user with | Some usr -> - let hasher = PasswordHasher () - match hasher.VerifyHashedPassword (usr, usr.PasswordHash, password) with + let hasher = PasswordHasher() + 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) } + 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" @@ -68,11 +68,10 @@ let doLogOn : HttpHandler = fun next ctx -> task { do! addMessage ctx { UserMessage.Success with Message = "Log on successful" - Detail = Some $"Welcome to {ctx.WebLog.Name}!" - } + 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 | Error msg -> do! addMessage ctx { UserMessage.Error with Message = msg } @@ -105,7 +104,7 @@ let all : HttpHandler = fun next ctx -> task { } /// Show the edit user page -let private showEdit (model : EditUserModel) : HttpHandler = fun next ctx -> +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 @@ -141,15 +140,13 @@ let delete userId : HttpHandler = fun next ctx -> task { | Ok _ -> do! addMessage ctx { UserMessage.Success with - Message = $"User {user.DisplayName} deleted successfully" - } + Message = $"User {user.DisplayName} deleted successfully" } return! all next ctx | Error msg -> do! addMessage ctx { UserMessage.Error with Message = $"User {user.DisplayName} was not deleted" - Detail = Some msg - } + Detail = Some msg } return! all next ctx | None -> return! Error.notFound next ctx } @@ -174,7 +171,7 @@ let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { // POST /admin/my-info let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let data = ctx.Data match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with | Some user when model.NewPassword = model.NewPasswordConfirm -> @@ -184,8 +181,7 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { FirstName = model.FirstName LastName = model.LastName PreferredName = model.PreferredName - PasswordHash = pw - } + 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" } @@ -201,15 +197,15 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { // POST /admin/settings/user/save let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () + let! model = ctx.BindFormAsync() let data = ctx.Data let tryUser = if model.IsNew then { WebLogUser.Empty with Id = WebLogUserId.Create() WebLogId = ctx.WebLog.Id - CreatedOn = Noda.now () - } |> someTask + CreatedOn = Noda.now () } + |> someTask else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id match! tryUser with | Some user when model.Password = model.PasswordConfirm -> @@ -223,8 +219,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { 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""" - } + 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" } diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 00a8dbc..54ab9fc 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -7,9 +7,9 @@ open MyWebLog.Data open NodaTime /// Create the web log information -let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { +let private doCreateWebLog (args: string[]) (sp: IServiceProvider) = task { - let data = sp.GetRequiredService () + let data = sp.GetRequiredService() let timeZone = let local = TimeZoneInfo.Local.Id @@ -38,8 +38,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { Slug = slug UrlBase = args[1] DefaultPage = string homePageId - TimeZone = timeZone - } + TimeZone = timeZone } // Create the admin user let now = Noda.now () @@ -52,8 +51,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { LastName = "User" PreferredName = "Admin" AccessLevel = accessLevel - CreatedOn = now - } + CreatedOn = now } do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] } // Create the default home page @@ -69,16 +67,14 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { Text = "

      This is your default home page.

      " Revisions = [ { AsOf = now - Text = Html "

      This is your default home page.

      " - } - ] - } + Text = Html "

      This is your default home page.

      " } + ] } printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}" match accessLevel with | Administrator -> printfn $" ({args[3]} is an installation administrator)" | WebLogAdmin -> - printfn $" ({args[3]} is a web log administrator;" + printfn $" ({args[3]} is a web log administrator;" printfn """ use "upgrade-user" to promote to installation administrator)""" | _ -> () } @@ -91,8 +87,8 @@ let createWebLog args sp = task { } /// Import prior permalinks from a text files with lines in the format "[old] [new]" -let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task { - let data = sp.GetRequiredService () +let private importPriorPermalinks urlBase file (sp: IServiceProvider) = task { + let data = sp.GetRequiredService() match! data.WebLog.FindByHost urlBase with | Some webLog -> @@ -129,7 +125,7 @@ let importLinks args sp = task { open Microsoft.Extensions.Logging /// Load a theme from the given ZIP file -let loadTheme (args : string[]) (sp : IServiceProvider) = task { +let loadTheme (args: string[]) (sp: IServiceProvider) = task { if args.Length = 2 then let fileName = match args[1].LastIndexOf Path.DirectorySeparatorChar with @@ -137,12 +133,12 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task { | it -> args[1][(it + 1)..] match Handlers.Admin.Theme.deriveIdFromFileName fileName with | Ok themeId -> - let data = sp.GetRequiredService () - use stream = File.Open (args[1], FileMode.Open) - use copy = new MemoryStream () + let data = sp.GetRequiredService() + use stream = File.Open(args[1], FileMode.Open) + use copy = new MemoryStream() do! stream.CopyToAsync copy let! theme = Handlers.Admin.Theme.loadFromZip themeId copy data - let fac = sp.GetRequiredService () + let fac = sp.GetRequiredService() let log = fac.CreateLogger "MyWebLog.Themes" log.LogInformation $"{theme.Name} v{theme.Version} ({theme.Id}) loaded" | Error message -> eprintfn $"{message}" @@ -159,103 +155,96 @@ module Backup = /// A theme asset, with the data base-64 encoded type EncodedAsset = { /// The ID of the theme asset - Id : ThemeAssetId + Id: ThemeAssetId /// The updated date for this asset - UpdatedOn : Instant + 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) = + 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 = + 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 = { /// The ID of the upload - Id : UploadId + Id: UploadId /// The ID of the web log to which the upload belongs - WebLogId : WebLogId + WebLogId: WebLogId /// The path at which this upload is served - Path : Permalink + Path: Permalink /// The date/time this upload was last updated (file time) - UpdatedOn : Instant + 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 = + static member fromUpload (upload: Upload) : EncodedUpload = { Id = upload.Id 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 = + static member toUpload (encoded: EncodedUpload) : Upload = { Id = encoded.Id 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 = { /// The web log to which this archive belongs - WebLog : WebLog + WebLog: WebLog /// The users for this web log - Users : WebLogUser list + Users: WebLogUser list /// The theme used by this web log at the time the archive was made - Theme : Theme + Theme: Theme /// Assets for the theme used by this web log at the time the archive was made - Assets : EncodedAsset list + Assets: EncodedAsset list /// The categories for this web log - Categories : Category list + Categories: Category list /// The tag mappings for this web log - TagMappings : TagMap list + TagMappings: TagMap list /// The pages for this web log (containing only the most recent revision) - Pages : Page list + Pages: Page list /// The posts for this web log (containing only the most recent revision) - Posts : Post list + Posts: Post list /// The uploaded files for this web log - Uploads : EncodedUpload list - } + Uploads: EncodedUpload list } /// Create a JSON serializer let private getSerializer prettyOutput = - let serializer = Json.configure (JsonSerializer.CreateDefault ()) + let serializer = Json.configure (JsonSerializer.CreateDefault()) if prettyOutput then serializer.Formatting <- Formatting.Indented serializer /// Display statistics for a backup archive - let private displayStats (msg : string) (webLog : WebLog) archive = + let private displayStats (msg: string) (webLog: WebLog) archive = let userCount = List.length archive.Users let assetCount = List.length archive.Assets @@ -280,7 +269,7 @@ module Backup = printfn $""" - {uploadCount} uploaded file{plural uploadCount "" "s"}""" /// Create a backup archive - let private createBackup webLog (fileName : string) prettyOutput (data : IData) = task { + let private createBackup webLog (fileName: string) prettyOutput (data: IData) = task { // Create the data structure printfn "- Exporting theme..." let! theme = data.Theme.FindById webLog.ThemeId @@ -312,25 +301,24 @@ 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 let serializer = getSerializer prettyOutput - use writer = new StreamWriter (fileName) - serializer.Serialize (writer, archive) - writer.Close () + use writer = new StreamWriter(fileName) + serializer.Serialize(writer, archive) + writer.Close() displayStats $"{fileName} (for <>NAME<>) contains:" webLog archive } - let private doRestore archive newUrlBase (data : IData) = task { + let private doRestore archive newUrlBase (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() @@ -354,24 +342,18 @@ 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) @@ -413,12 +395,12 @@ module Backup = } /// Decide whether to restore a backup - let private restoreBackup (fileName : string) newUrlBase promptForOverwrite data = task { + let private restoreBackup fileName newUrlBase promptForOverwrite data = task { let serializer = getSerializer false - use stream = new FileStream (fileName, FileMode.Open) - use reader = new StreamReader (stream) - use jsonReader = new JsonTextReader (reader) + use stream = new FileStream(fileName, FileMode.Open) + use reader = new StreamReader(stream) + use jsonReader = new JsonTextReader(reader) let archive = serializer.Deserialize jsonReader let mutable doOverwrite = not promptForOverwrite @@ -428,7 +410,7 @@ 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 @@ -437,9 +419,9 @@ module Backup = } /// Generate a backup archive - let generateBackup (args : string[]) (sp : IServiceProvider) = task { + let generateBackup (args: string[]) (sp: IServiceProvider) = task { if args.Length > 1 && args.Length < 5 then - let data = sp.GetRequiredService () + let data = sp.GetRequiredService() match! data.WebLog.FindByHost args[1] with | Some webLog -> let fileName = @@ -459,9 +441,9 @@ module Backup = } /// Restore a backup archive - let restoreFromBackup (args : string[]) (sp : IServiceProvider) = task { + let restoreFromBackup (args: string[]) (sp: IServiceProvider) = task { if args.Length = 2 || args.Length = 3 then - let data = sp.GetRequiredService () + let data = sp.GetRequiredService() let newUrlBase = if args.Length = 3 then Some args[2] else None do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") data else @@ -472,7 +454,7 @@ module Backup = /// Upgrade a WebLogAdmin user to an Administrator user -let private doUserUpgrade urlBase email (data : IData) = task { +let private doUserUpgrade urlBase email (data: IData) = task { match! data.WebLog.FindByHost urlBase with | Some webLog -> match! data.WebLogUser.FindByEmail email webLog.Id with @@ -487,14 +469,14 @@ 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 { +let upgradeUser (args: string[]) (sp: IServiceProvider) = task { match args.Length with - | 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService ()) + | 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService()) | _ -> eprintfn "Usage: myWebLog upgrade-user [web-log-url-base] [email-address]" } /// Set a user's password -let doSetPassword urlBase email password (data : IData) = task { +let doSetPassword urlBase email password (data: IData) = task { match! data.WebLog.FindByHost urlBase with | Some webLog -> match! data.WebLogUser.FindByEmail email webLog.Id with @@ -506,8 +488,8 @@ let doSetPassword urlBase email password (data : IData) = task { } /// Set a user's password if the command-line arguments are good -let setPassword (args : string[]) (sp : IServiceProvider) = task { +let setPassword (args: string[]) (sp: IServiceProvider) = task { match args.Length with - | 4 -> do! doSetPassword args[1] args[2] args[3] (sp.GetRequiredService ()) + | 4 -> do! doSetPassword args[1] args[2] args[3] (sp.GetRequiredService()) | _ -> eprintfn "Usage: myWebLog set-password [web-log-url-base] [email-address] [password]" } diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 450b383..c86cf62 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -5,12 +5,12 @@ open Microsoft.Extensions.Logging open MyWebLog /// Middleware to derive the current web log -type WebLogMiddleware (next : RequestDelegate, log : ILogger) = +type WebLogMiddleware(next: RequestDelegate, log: ILogger) = /// Is the debug level enabled on the logger? let isDebug = log.IsEnabled LogLevel.Debug - member _.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 @@ -27,14 +27,14 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger) /// Middleware to check redirects for the current web log -type RedirectRuleMiddleware (next : RequestDelegate, log : ILogger) = +type RedirectRuleMiddleware(next: RequestDelegate, log: ILogger) = /// Shorthand for case-insensitive string equality let ciEquals str1 str2 = - System.String.Equals (str1, str2, System.StringComparison.InvariantCultureIgnoreCase) + System.String.Equals(str1, str2, System.StringComparison.InvariantCultureIgnoreCase) - member _.InvokeAsync (ctx : HttpContext) = task { - let path = ctx.Request.Path.Value.ToLower () + member _.InvokeAsync(ctx: HttpContext) = task { + let path = ctx.Request.Path.Value.ToLower() let matched = WebLogCache.redirectRules ctx.WebLog.Id |> List.tryPick (fun rule -> @@ -42,9 +42,9 @@ type RedirectRuleMiddleware (next : RequestDelegate, log : ILogger 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) + if regExFrom.IsMatch path then Some (regExFrom.Replace(path, patternTo)) else None) match matched with - | Some url -> ctx.Response.Redirect (url, permanent = true) + | Some url -> ctx.Response.Redirect(url, permanent = true) | None -> return! next.Invoke ctx } @@ -64,39 +64,39 @@ module DataImplementation = 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 createNpgsqlDataSource (cfg: IConfiguration) = + let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL") + let _ = builder.UseNodaTime() // let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore)) (builder.Build >> Configuration.useDataSource) () /// Get the configured data implementation - let get (sp : IServiceProvider) : IData = - let config = sp.GetRequiredService () + let get (sp: IServiceProvider) : IData = + let config = sp.GetRequiredService() let await it = (Async.AwaitTask >> Async.RunSynchronously) it let connStr name = config.GetConnectionString name let hasConnStr name = (connStr >> isNull >> not) name let createSQLite connStr : IData = - let log = sp.GetRequiredService> () - let conn = new SqliteConnection (connStr) + let log = sp.GetRequiredService>() + let conn = new SqliteConnection(connStr) log.LogInformation $"Using SQLite database {conn.DataSource}" await (SQLiteData.setUpConnection conn) - SQLiteData (conn, log, Json.configure (JsonSerializer.CreateDefault ())) + SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault())) if hasConnStr "SQLite" then createSQLite (connStr "SQLite") elif hasConnStr "RethinkDB" then - let log = sp.GetRequiredService> () + let log = sp.GetRequiredService>() let _ = Json.configure Converter.Serializer let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB") let conn = await (rethinkCfg.CreateConnectionAsync log) - RethinkDbData (conn, rethinkCfg, log) + RethinkDbData(conn, rethinkCfg, log) elif hasConnStr "PostgreSQL" then createNpgsqlDataSource config - use conn = Configuration.dataSource().CreateConnection () - let log = sp.GetRequiredService> () + use conn = Configuration.dataSource().CreateConnection() + let log = sp.GetRequiredService>() log.LogInformation $"Using PostgreSQL database {conn.Database}" - PostgresData (log, Json.configure (JsonSerializer.CreateDefault ())) + PostgresData(log, Json.configure (JsonSerializer.CreateDefault())) else createSQLite "Data Source=./myweblog.db;Cache=Shared" @@ -119,7 +119,7 @@ let showHelp () = 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 () + Task.FromResult() open System.IO @@ -146,16 +146,16 @@ let main args = opts.ExpireTimeSpan <- TimeSpan.FromMinutes 60. opts.SlidingExpiration <- true opts.AccessDeniedPath <- "/forbidden") - let _ = builder.Services.AddLogging () - let _ = builder.Services.AddAuthorization () - let _ = builder.Services.AddAntiforgery () + let _ = builder.Services.AddLogging() + let _ = builder.Services.AddAuthorization() + let _ = builder.Services.AddAntiforgery() - let sp = builder.Services.BuildServiceProvider () + let sp = builder.Services.BuildServiceProvider() let data = DataImplementation.get sp let _ = builder.Services.AddSingleton data.Serializer task { - do! data.StartUp () + do! data.StartUp() do! WebLogCache.fill data do! ThemeAssetCache.fill data } |> Async.AwaitTask |> Async.RunSynchronously @@ -166,30 +166,30 @@ let main args = // A RethinkDB connection is designed to work as a singleton let _ = builder.Services.AddSingleton data let _ = - builder.Services.AddDistributedRethinkDBCache (fun opts -> + builder.Services.AddDistributedRethinkDBCache(fun opts -> opts.TableName <- "Session" opts.Connection <- rethink.Conn) () | :? SQLiteData as sql -> // ADO.NET connections are designed to work as per-request instantiation - let cfg = sp.GetRequiredService () + let cfg = sp.GetRequiredService() let _ = - builder.Services.AddScoped (fun sp -> - let conn = new SqliteConnection (sql.Conn.ConnectionString) + builder.Services.AddScoped(fun sp -> + let conn = new SqliteConnection(sql.Conn.ConnectionString) SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously conn) - let _ = builder.Services.AddScoped () |> ignore + let _ = builder.Services.AddScoped() // Use SQLite for caching as well let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" - let _ = builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath) + 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 (Configuration.dataSource ()) + let _ = builder.Services.AddSingleton(Configuration.dataSource ()) let _ = builder.Services.AddSingleton postgres let _ = - builder.Services.AddSingleton (fun _ -> - Postgres.DistributedCache () :> IDistributedCache) + builder.Services.AddSingleton(fun _ -> + Postgres.DistributedCache() :> IDistributedCache) () | _ -> () @@ -197,12 +197,12 @@ let main args = opts.IdleTimeout <- TimeSpan.FromMinutes 60 opts.Cookie.HttpOnly <- true opts.Cookie.IsEssential <- true) - let _ = builder.Services.AddGiraffe () + let _ = builder.Services.AddGiraffe() // Set up DotLiquid DotLiquidBespoke.register () - let app = builder.Build () + let app = builder.Build() match args |> Array.tryHead with | Some it when it = "init" -> Maintenance.createWebLog args app.Services @@ -219,25 +219,25 @@ let main args = showHelp () | None -> task { // Load all themes in the application directory - for themeFile in Directory.EnumerateFiles (".", "*-theme.zip") do + for themeFile in Directory.EnumerateFiles(".", "*-theme.zip") do do! Maintenance.loadTheme [| ""; themeFile |] app.Services - let _ = app.UseForwardedHeaders () + let _ = app.UseForwardedHeaders() (app.Services.GetRequiredService().GetSection "CanonicalDomains").Value |> (isNull >> not) - |> function true -> app.UseCanonicalDomains () |> ignore | false -> () + |> function true -> app.UseCanonicalDomains() |> ignore | false -> () - let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) - let _ = app.UseMiddleware () - let _ = app.UseMiddleware () - let _ = app.UseAuthentication () - let _ = app.UseStaticFiles () - let _ = app.UseRouting () - let _ = app.UseSession () + let _ = app.UseCookiePolicy(CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) + let _ = app.UseMiddleware() + let _ = app.UseMiddleware() + let _ = app.UseAuthentication() + let _ = app.UseStaticFiles() + let _ = app.UseRouting() + let _ = app.UseSession() let _ = app.UseGiraffe Handlers.Routes.endpoint - app.Run () + app.Run() } |> Async.AwaitTask |> Async.RunSynchronously -- 2.45.1 From a439430cc537b088251651de48d2f865a5d6c078 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Dec 2023 22:36:08 -0500 Subject: [PATCH 020/123] Update Postgres data implementation Changes for doc library v2 --- src/MyWebLog.Data/Postgres/PostgresCache.fs | 84 +++++++------ .../Postgres/PostgresCategoryData.fs | 62 +++++---- src/MyWebLog.Data/Postgres/PostgresHelpers.fs | 118 +++++++++--------- .../Postgres/PostgresPageData.fs | 51 ++++---- .../Postgres/PostgresPostData.fs | 74 ++++++----- .../Postgres/PostgresTagMapData.fs | 37 +++--- .../Postgres/PostgresThemeData.fs | 55 ++++---- .../Postgres/PostgresUploadData.fs | 43 ++++--- .../Postgres/PostgresWebLogData.fs | 19 ++- .../Postgres/PostgresWebLogUserData.fs | 40 +++--- src/MyWebLog.Data/PostgresData.fs | 20 ++- 11 files changed, 321 insertions(+), 282 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresCache.fs b/src/MyWebLog.Data/Postgres/PostgresCache.fs index a7b0280..4f665f5 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCache.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCache.fs @@ -5,35 +5,34 @@ open System.Threading.Tasks open BitBadger.Npgsql.FSharp.Documents open Microsoft.Extensions.Caching.Distributed open NodaTime -open Npgsql.FSharp /// Helper types and functions for the cache [] module private Helpers = /// The cache entry - type Entry = - { /// The ID of the cache entry - Id : string - - /// The value to be cached - Payload : byte[] - - /// 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 - } + 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) + let sync<'T> (it: Task<'T>) = it |> (Async.AwaitTask >> Async.RunSynchronously) /// Get the current instant - let getNow () = SystemClock.Instance.GetCurrentInstant () + let getNow () = SystemClock.Instance.GetCurrentInstant() /// Create a parameter for the expire-at time let expireParam = @@ -69,13 +68,15 @@ type DistributedCache () = 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 "expire_at" - SlidingExpiration = row.fieldValueOrNone "sliding_expiration" - AbsoluteExpiration = row.fieldValueOrNone "absolute_expiration" }) + Custom.single + "SELECT * FROM session WHERE id = @id" + [ idParam ] + (fun row -> + { Id = row.string "id" + Payload = row.bytea "payload" + ExpireAt = row.fieldValue "expire_at" + SlidingExpiration = row.fieldValueOrNone "sliding_expiration" + AbsoluteExpiration = row.fieldValueOrNone "absolute_expiration" }) match tryEntry with | Some entry -> let now = getNow () @@ -88,8 +89,9 @@ type DistributedCache () = 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 ] + 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 @@ -101,17 +103,17 @@ type DistributedCache () = /// Purge expired entries every 30 minutes let purge () = backgroundTask { let now = getNow () - if lastPurge.Plus (Duration.FromMinutes 30L) < now then + 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 = - Delete.byId "session" key + Custom.nonQuery "DELETE FROM session WHERE id = @id" [ "@id", Sql.string key ] /// Save an entry - let saveEntry (opts : DistributedCacheEntryOptions) key payload = + let saveEntry (opts: DistributedCacheEntryOptions) key payload = let now = getNow () let expireAt, slideExp, absExp = if opts.SlidingExpiration.HasValue then @@ -121,7 +123,7 @@ type DistributedCache () = 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) + let exp = now.Plus(Duration.FromTimeSpan opts.AbsoluteExpirationRelativeToNow.Value) exp, None, Some exp else // Default to 1 hour sliding expiration @@ -146,7 +148,7 @@ type DistributedCache () = // ~~~ IMPLEMENTATION FUNCTIONS ~~~ /// Retrieve the data for a cache entry - let get key (_ : CancellationToken) = backgroundTask { + let get key (_: CancellationToken) = backgroundTask { match! getEntry key with | Some entry -> do! purge () @@ -155,29 +157,29 @@ type DistributedCache () = } /// Refresh an entry - let refresh key (cancelToken : CancellationToken) = backgroundTask { + let refresh key (cancelToken: CancellationToken) = backgroundTask { let! _ = get key cancelToken () } /// Remove an entry - let remove key (_ : CancellationToken) = backgroundTask { + let remove key (_: CancellationToken) = backgroundTask { do! removeEntry key do! purge () } /// Set an entry - let set key value options (_ : CancellationToken) = backgroundTask { + 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 _.GetAsync(key, token) = get key token member _.Refresh key = refresh key CancellationToken.None |> sync - member _.RefreshAsync (key, token) = refresh key token + 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 + 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 diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index a740ea8..ce12e88 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -23,8 +23,10 @@ type PostgresCategoryData(log: ILogger) = 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 + Custom.list + $"{selectWithCriteria Table.Category} ORDER BY LOWER(data ->> '{nameof Category.Empty.Name}')" + [ webLogContains webLogId ] + fromData let ordered = Utils.orderByHierarchy cats None None [] let counts = ordered @@ -39,12 +41,12 @@ type PostgresCategoryData(log: ILogger) = |> arrayContains (nameof Post.Empty.CategoryIds) id let postCount = Custom.scalar - $"""SELECT COUNT(DISTINCT id) AS {countName} + $"""SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') AS {countName} FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"} AND {catIdSql}""" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} - catIdParams ] + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} + catIdParams ] Map.toCount |> Async.AwaitTask |> Async.RunSynchronously @@ -57,60 +59,56 @@ type PostgresCategoryData(log: ILogger) = PostCount = counts |> List.tryFind (fun c -> fst c = cat.Id) |> Option.map snd - |> Option.defaultValue 0 - }) + |> 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 Table.Category catId string webLogId + Document.findByIdAndWebLog Table.Category catId webLogId /// Find all categories for the given web log let findByWebLog webLogId = log.LogTrace "Category.findByWebLog" Document.findByWebLog Table.Category webLogId - /// Create parameters for a category insert / update - let catParameters (cat : Category) = - Query.docParameters (string cat.Id) cat - /// 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 Table.Category {| ParentId = string catId |} + let! children = Find.byContains Table.Category {| ParentId = catId |} let hasChildren = not (List.isEmpty children) if hasChildren then let! _ = Configuration.dataSource () |> Sql.fromDataSource - |> Sql.executeTransactionAsync [ - Query.Update.partialById Table.Category, - children |> List.map (fun child -> [ - "@id", Sql.string (string child.Id) - "@data", Query.jsonbDocParam {| ParentId = cat.ParentId |} - ]) - ] + |> Sql.executeTransactionAsync + [ Query.Update.partialById Table.Category, + children + |> List.map (fun child -> + [ "@id", Sql.string (string child.Id) + "@data", Query.jsonbDocParam {| ParentId = cat.ParentId |} ]) ] () // 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" - [ "@id", Query.jsonbDocParam [| string catId |] ] fromData + Custom.list + $"SELECT data FROM {Table.Post} WHERE data -> '{nameof Post.Empty.CategoryIds}' @> @id" + [ "@id", Query.jsonbDocParam [| string catId |] ] + fromData if not (List.isEmpty posts) then let! _ = Configuration.dataSource () |> Sql.fromDataSource - |> Sql.executeTransactionAsync [ - Query.Update.partialById Table.Post, - posts |> List.map (fun post -> [ - "@id", Sql.string (string post.Id) - "@data", Query.jsonbDocParam - {| CategoryIds = post.CategoryIds |> List.filter (fun cat -> cat <> catId) |} - ]) - ] + |> Sql.executeTransactionAsync + [ Query.Update.partialById Table.Post, + posts + |> List.map (fun post -> + [ "@id", Sql.string (string post.Id) + "@data", Query.jsonbDocParam + {| CategoryIds = post.CategoryIds + |> List.filter (fun cat -> cat <> catId) |} ]) ] () // Delete the category itself do! Delete.byId Table.Category (string catId) @@ -119,7 +117,7 @@ type PostgresCategoryData(log: ILogger) = } /// Save a category - let save (cat : Category) = backgroundTask { + let save (cat: Category) = backgroundTask { log.LogTrace "Category.save" do! save Table.Category cat } @@ -131,7 +129,7 @@ type PostgresCategoryData(log: ILogger) = Configuration.dataSource () |> Sql.fromDataSource |> Sql.executeTransactionAsync [ - Query.insert Table.Category, cats |> List.map catParameters + Query.insert Table.Category, cats |> List.map (fun c -> [ "@data", Query.jsonbDocParam c ]) ] () } diff --git a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs index ae73f49..601b1e8 100644 --- a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs +++ b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs @@ -69,11 +69,11 @@ open Npgsql open Npgsql.FSharp /// Create a SQL parameter for the web log ID -let webLogIdParam webLogId = +let webLogIdParam (webLogId: WebLogId) = "@webLogId", Sql.string (string webLogId) /// Create an anonymous record with the given web log ID -let webLogDoc (webLogId : WebLogId) = +let webLogDoc (webLogId: WebLogId) = {| WebLogId = webLogId |} /// Create a parameter for a web log document-contains query @@ -91,7 +91,7 @@ let selectWithCriteria tableName = $"""{Query.selectFromTable tableName} WHERE {Query.whereDataContains "@criteria"}""" /// Create the SQL and parameters for an IN clause -let inClause<'T> colNameAndPrefix paramName (valueFunc: 'T -> string) (items : 'T list) = +let inClause<'T> colNameAndPrefix paramName (items: 'T list) = if List.isEmpty items then "", [] else let mutable idx = 0 @@ -99,113 +99,116 @@ let inClause<'T> colNameAndPrefix paramName (valueFunc: 'T -> string) (items : ' |> List.skip 1 |> List.fold (fun (itemS, itemP) it -> idx <- idx + 1 - $"{itemS}, @%s{paramName}{idx}", ($"@%s{paramName}{idx}", Sql.string (valueFunc it)) :: itemP) + $"{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 (valueFunc 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) = +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 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)) +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) +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 = /// Get a count from a row - let toCount (row : RowReader) = + let toCount (row: RowReader) = row.int countName /// Get a true/false value as to whether an item exists - let toExists (row : RowReader) = + let toExists (row: RowReader) = row.bool existsName /// Create a permalink from the current row - let toPermalink (row : RowReader) = + let toPermalink (row: RowReader) = Permalink (row.string "permalink") /// Create a revision from the current row - let toRevision (row : RowReader) : Revision = - { AsOf = row.fieldValue "as_of" - Text = row.string "revision_text" |> MarkupText.Parse - } + let toRevision (row: RowReader) : Revision = + { AsOf = row.fieldValue "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 "updated_on" - Data = if includeData then row.bytea "data" else [||] - } + let toThemeAsset includeData (row: RowReader) : ThemeAsset = + { Id = ThemeAssetId (ThemeId (row.string "theme_id"), row.string "path") + UpdatedOn = row.fieldValue "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 "updated_on" - Data = if includeData then row.bytea "data" else [||] - } + 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 "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) (keyFunc : 'TKey -> string) webLogId = + let existsByWebLog<'TKey> table (key: 'TKey) webLogId = Custom.scalar - $""" SELECT EXISTS ( - SELECT 1 FROM %s{table} WHERE id = @id AND {Query.whereDataContains "@criteria"} - ) AS {existsName}""" - [ "@id", Sql.string (keyFunc key); webLogContains webLogId ] Map.toExists + $"""SELECT EXISTS ( + SELECT 1 FROM %s{table} WHERE {Query.whereById "@id"} AND {Query.whereDataContains "@criteria"} + ) AS {existsName}""" + [ "@id", Sql.string (string key); webLogContains webLogId ] + Map.toExists /// Find a document by its ID for the given web log - let findByIdAndWebLog<'TKey, 'TDoc> table (key : 'TKey) (keyFunc : 'TKey -> string) webLogId = - Custom.single $"""{Query.selectFromTable table} WHERE id = @id AND {Query.whereDataContains "@criteria"}""" - [ "@id", Sql.string (keyFunc key); webLogContains webLogId ] fromData<'TDoc> + 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 a document by its ID for the given web log + /// 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) (keyFunc : 'TKey -> string) = - Custom.list $"SELECT as_of, revision_text FROM %s{revTable} WHERE %s{entityTable}_id = @id ORDER BY as_of DESC" - [ "@id", Sql.string (keyFunc key) ] Map.toRevision + 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 = + let findByWebLog<'TKey> revTable entityTable (keyFunc: string -> 'TKey) webLogId = Custom.list $"""SELECT pr.* FROM %s{revTable} pr - INNER JOIN %s{entityTable} p ON p.id = pr.{entityTable}_id + INNER JOIN %s{entityTable} p ON p.data ->> '{nameof Post.Empty.Id}' = pr.{entityTable}_id WHERE p.{Query.whereDataContains "@criteria"} ORDER BY as_of DESC""" - [ webLogContains webLogId ] (fun row -> keyFunc (row.string $"{entityTable}_id"), Map.toRevision row) + [ webLogContains webLogId ] + (fun row -> keyFunc (row.string $"{entityTable}_id"), Map.toRevision row) /// Parameters for a revision INSERT statement - let revParams<'TKey> (key : 'TKey) (keyFunc : 'TKey -> string) rev = [ + let revParams<'TKey> (key: 'TKey) rev = [ typedParam "asOf" rev.AsOf - "@id", Sql.string (keyFunc key) + "@id", Sql.string (string key) "@text", Sql.string (string rev.Text) ] @@ -214,23 +217,20 @@ module Revisions = $"INSERT INTO %s{table} VALUES (@id, @asOf, @text)" /// Update a page's revisions - let update<'TKey> revTable entityTable (key : 'TKey) (keyFunc : 'TKey -> string) oldRevs newRevs = backgroundTask { + 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 + |> 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 (keyFunc key) - typedParam "asOf" it.AsOf - ]) - if not (List.isEmpty toAdd) then - insertSql revTable, toAdd |> List.map (revParams key keyFunc) - ] + |> 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) ] () } - diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 766fd14..364a99f 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -6,15 +6,15 @@ open MyWebLog open MyWebLog.Data open Npgsql.FSharp -/// PostgreSQL myWebLog page data implementation -type PostgresPageData (log: ILogger) = +/// 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 string + let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id return { page with Revisions = revisions } } @@ -25,20 +25,22 @@ type PostgresPageData (log: ILogger) = /// Update a page's revisions let updatePageRevisions (pageId: PageId) oldRevs newRevs = log.LogTrace "Page.updatePageRevisions" - Revisions.update Table.PageRevision Table.Page pageId string oldRevs newRevs + 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 string webLogId + Document.existsByWebLog Table.Page pageId webLogId // IMPLEMENTATION FUNCTIONS /// Get all pages for a web log (without text or revisions) let all webLogId = log.LogTrace "Page.all" - Custom.list $"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" - [ webLogContains webLogId ] fromData + Custom.list + $"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" + [ webLogContains webLogId ] + fromData /// Count all pages for the given web log let countAll webLogId = @@ -53,7 +55,7 @@ type PostgresPageData (log: ILogger) = /// Find a page by its ID (without revisions) let findById pageId webLogId = log.LogTrace "Page.findById" - Document.findByIdAndWebLog Table.Page pageId string webLogId + Document.findByIdAndWebLog Table.Page pageId webLogId /// Find a complete page by its ID let findFullById pageId webLogId = backgroundTask { @@ -65,12 +67,16 @@ type PostgresPageData (log: ILogger) = | 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! Delete.byId Table.Page (string pageId) + do! Custom.nonQuery + $"""DELETE FROM {Table.PageRevision} WHERE page_id = @id; + DELETE FROM {Table.Page} WHERE {Query.whereById "@id"}""" + [ "@id", Sql.string (string pageId) ] return true | false -> return false } @@ -78,7 +84,7 @@ type PostgresPageData (log: ILogger) = /// Find a page by its permalink for the given web log let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Page.findByPermalink" - Find.byContains Table.Page {| webLogDoc webLogId with Permalink = string permalink |} + Find.byContains Table.Page {| webLogDoc webLogId with Permalink = permalink |} |> tryHead /// Find the current permalink within a set of potential prior permalinks for the given web log @@ -92,7 +98,9 @@ type PostgresPageData (log: ILogger) = $"""SELECT data ->> '{nameof Page.Empty.Permalink}' AS permalink FROM page WHERE {Query.whereDataContains "@criteria"} - AND {linkSql}""" [ webLogContains webLogId; linkParam ] Map.toPermalink + AND {linkSql}""" + [ webLogContains webLogId; linkParam ] + Map.toPermalink } /// Get all complete pages for the given web log @@ -109,9 +117,10 @@ type PostgresPageData (log: ILogger) = /// 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}')" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with IsInPageList = true |} ] - pageWithoutText + Custom.list + $"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with IsInPageList = true |} ] + pageWithoutText /// Get a page of pages for the given web log (without revisions) let findPageOfPages webLogId pageNbr = @@ -130,13 +139,11 @@ type PostgresPageData (log: ILogger) = let! _ = Configuration.dataSource () |> Sql.fromDataSource - |> Sql.executeTransactionAsync [ - Query.insert Table.Page, - pages - |> List.map (fun page -> Query.docParameters (string page.Id) { page with Revisions = [] }) - Revisions.insertSql Table.PageRevision, - revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId string rev) - ] + |> Sql.executeTransactionAsync + [ Query.insert Table.Page, + pages |> List.map (fun page -> [ "@data", Query.jsonbDocParam { page with Revisions = [] } ]) + Revisions.insertSql Table.PageRevision, + revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId rev) ] () } @@ -150,7 +157,7 @@ type PostgresPageData (log: ILogger) = } /// Update a page's prior permalinks - let updatePriorPermalinks pageId webLogId permalinks = backgroundTask { + let updatePriorPermalinks pageId webLogId (permalinks: Permalink list) = backgroundTask { log.LogTrace "Page.updatePriorPermalinks" match! pageExists pageId webLogId with | true -> diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index 3ccef17..b33abc6 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -15,23 +15,23 @@ type PostgresPostData(log: ILogger) = /// Append revisions to a post let appendPostRevisions (post: Post) = backgroundTask { log.LogTrace "Post.appendPostRevisions" - let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id string + let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id return { post with Revisions = revisions } } - /// Return a post with no revisions, prior permalinks, or text + /// Return a post with no revisions or text let postWithoutText row = { fromData 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 string oldRevs newRevs + 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 string webLogId + Document.existsByWebLog Table.Post postId webLogId // IMPLEMENTATION FUNCTIONS @@ -43,14 +43,15 @@ type PostgresPostData(log: ILogger) = /// Find a post by its ID for the given web log (excluding revisions) let findById postId webLogId = log.LogTrace "Post.findById" - Document.findByIdAndWebLog Table.Post postId string webLogId + Document.findByIdAndWebLog Table.Post postId webLogId - /// Find a post by its permalink for the given web log (excluding revisions and prior permalinks) + /// 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) - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Permalink = string permalink |} ] - fromData + Custom.single + (selectWithCriteria Table.Post) + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Permalink = permalink |} ] + fromData /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { @@ -68,8 +69,9 @@ type PostgresPostData(log: ILogger) = match! postExists postId webLogId with | true -> do! Custom.nonQuery - $"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"}; - DELETE FROM {Table.Post} WHERE id = @id""" + $"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"}; + DELETE FROM {Table.PostRevision} WHERE post_id = @id; + DELETE FROM {Table.Post} WHERE {Query.whereById "@id"}""" [ "@id", Sql.string (string postId); "@criteria", Query.jsonbDocParam {| PostId = postId |} ] return true | false -> return false @@ -86,7 +88,9 @@ type PostgresPostData(log: ILogger) = $"""SELECT data ->> '{nameof Post.Empty.Permalink}' AS permalink FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"} - AND {linkSql}""" [ webLogContains webLogId; linkParam ] Map.toPermalink + AND {linkSql}""" + [ webLogContains webLogId; linkParam ] + Map.toPermalink } /// Get all complete posts for the given web log @@ -109,9 +113,8 @@ type PostgresPostData(log: ILogger) = AND {catSql} ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} - catParam - ] fromData + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |}; catParam ] + fromData /// Get a page of posts for the given web log (excludes text and revisions) let findPageOfPosts webLogId pageNbr postsPerPage = @@ -121,7 +124,8 @@ type PostgresPostData(log: ILogger) = 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 + [ webLogContains webLogId ] + postWithoutText /// Get a page of published posts for the given web log (excludes revisions) let findPageOfPublishedPosts webLogId pageNbr postsPerPage = @@ -134,37 +138,40 @@ type PostgresPostData(log: ILogger) = fromData /// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks) - let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = + 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}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} - "@tag", Query.jsonbDocParam [| tag |] - ] fromData + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} + "@tag", Query.jsonbDocParam [| tag |] ] + fromData /// Find the next newest and oldest post from a publish date for the given web log let findSurroundingPosts webLogId publishedOn = backgroundTask { log.LogTrace "Post.findSurroundingPosts" - let queryParams () = [ - "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} - "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn)[..19]) - ] - let pubField = nameof Post.Empty.PublishedOn + let queryParams () = + [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} + "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn)[..19]) ] + let pubField = nameof Post.Empty.PublishedOn let! older = Custom.list $"{selectWithCriteria Table.Post} AND SUBSTR(data ->> '{pubField}', 1, 19) < @publishedOn ORDER BY data ->> '{pubField}' DESC - LIMIT 1" (queryParams ()) fromData + LIMIT 1" + (queryParams ()) + fromData let! newer = Custom.list $"{selectWithCriteria Table.Post} AND SUBSTR(data ->> '{pubField}', 1, 19) > @publishedOn ORDER BY data ->> '{pubField}' - LIMIT 1" (queryParams ()) fromData + LIMIT 1" + (queryParams ()) + fromData return List.tryHead older, List.tryHead newer } @@ -183,17 +190,16 @@ type PostgresPostData(log: ILogger) = let! _ = Configuration.dataSource () |> Sql.fromDataSource - |> Sql.executeTransactionAsync [ - Query.insert Table.Post, - posts |> List.map (fun post -> Query.docParameters (string post.Id) { post with Revisions = [] }) - Revisions.insertSql Table.PostRevision, - revisions |> List.map (fun (postId, rev) -> Revisions.revParams postId string rev) - ] + |> Sql.executeTransactionAsync + [ Query.insert Table.Post, + posts |> List.map (fun post -> [ "@data", Query.jsonbDocParam { 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 = backgroundTask { + let updatePriorPermalinks postId webLogId (permalinks: Permalink list) = backgroundTask { log.LogTrace "Post.updatePriorPermalinks" match! postExists postId webLogId with | true -> diff --git a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs index c252f7b..04e33c9 100644 --- a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -6,18 +6,18 @@ open MyWebLog open MyWebLog.Data open Npgsql.FSharp -/// PostgreSQL myWebLog tag mapping data implementation -type PostgresTagMapData (log : ILogger) = +/// 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 Table.TagMap tagMapId string webLogId + Document.findByIdAndWebLog 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 string webLogId + let! exists = Document.existsByWebLog Table.TagMap tagMapId webLogId if exists then do! Delete.byId Table.TagMap (string tagMapId) return true @@ -25,38 +25,39 @@ type PostgresTagMapData (log : ILogger) = } /// Find a tag mapping by its URL value for the given web log - let findByUrlValue (urlValue : string) webLogId = + let findByUrlValue (urlValue: string) webLogId = log.LogTrace "TagMap.findByUrlValue" - Custom.single (selectWithCriteria Table.TagMap) - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with UrlValue = urlValue |} ] - fromData + Find.firstByContains 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 + Custom.list + $"{selectWithCriteria Table.TagMap} ORDER BY data ->> 'tag'" + [ webLogContains webLogId ] + fromData /// 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 + Custom.list + $"{selectWithCriteria Table.TagMap} AND {tagSql}" + [ webLogContains webLogId; tagParam ] + fromData /// Save a tag mapping - let save (tagMap : TagMap) = + let save (tagMap: TagMap) = save Table.TagMap tagMap /// Restore tag mappings from a backup - let restore (tagMaps : TagMap list) = backgroundTask { + let restore (tagMaps: TagMap list) = backgroundTask { let! _ = Configuration.dataSource () |> Sql.fromDataSource - |> Sql.executeTransactionAsync [ - Query.insert Table.TagMap, - tagMaps |> List.map (fun tagMap -> Query.docParameters (string tagMap.Id) tagMap) - ] + |> Sql.executeTransactionAsync + [ Query.insert Table.TagMap, + tagMaps |> List.map (fun tagMap -> [ "@data", Query.jsonbDocParam tagMap ]) ] () } diff --git a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs index ed7e4bb..819489f 100644 --- a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs @@ -6,8 +6,8 @@ open MyWebLog open MyWebLog.Data open Npgsql.FSharp -/// PostreSQL myWebLog theme data implementation -type PostgresThemeData (log : ILogger) = +/// PostreSQL myWebLog theme data implementation +type PostgresThemeData(log: ILogger) = /// Clear out the template text from a theme let withoutTemplateText row = @@ -17,7 +17,10 @@ type PostgresThemeData (log : ILogger) = /// Retrieve all themes (except 'admin'; excludes template text) let all () = log.LogTrace "Theme.all" - Custom.list $"{Query.selectFromTable Table.Theme} WHERE id <> 'admin' ORDER BY id" [] withoutTemplateText + Custom.list + $"{Query.selectFromTable Table.Theme} WHERE data ->> '{nameof Theme.Empty.Id}' <> 'admin' ORDER BY id" + [] + withoutTemplateText /// Does a given theme exist? let exists (themeId: ThemeId) = @@ -39,18 +42,21 @@ type PostgresThemeData (log : ILogger) = log.LogTrace "Theme.delete" match! exists themeId with | true -> - do! Delete.byId Table.Theme (string themeId) + do! Custom.nonQuery + $"""DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; + DELETE FROM {Table.Theme} WHERE {Query.whereById "@id"}""" + [ "@id", Sql.string (string themeId) ] return true | false -> return false } /// Save a theme - let save (theme : Theme) = + let save (theme: Theme) = log.LogTrace "Theme.save" save Table.Theme theme interface IThemeData with - member _.All () = all () + member _.All() = all () member _.Delete themeId = delete themeId member _.Exists themeId = exists themeId member _.FindById themeId = findById themeId @@ -58,8 +64,8 @@ type PostgresThemeData (log : ILogger) = member _.Save theme = save theme -/// PostreSQL myWebLog theme data implementation -type PostgresThemeAssetData (log : ILogger) = +/// PostreSQL myWebLog theme data implementation +type PostgresThemeAssetData(log: ILogger) = /// Get all theme assets (excludes data) let all () = @@ -69,30 +75,35 @@ type PostgresThemeAssetData (log : ILogger) = /// Delete all assets for the given theme let deleteByTheme (themeId: ThemeId) = log.LogTrace "ThemeAsset.deleteByTheme" - Custom.nonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @themeId" - [ "@themeId", Sql.string (string themeId) ] + Custom.nonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ "@id", Sql.string (string 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 = @themeId AND path = @path" - [ "@themeId", Sql.string themeId; "@path", Sql.string path ] (Map.toThemeAsset true) + Custom.single + $"SELECT * FROM {Table.ThemeAsset} WHERE theme_id = @themeId AND path = @path" + [ "@themeId", Sql.string 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 = @themeId" - [ "@themeId", Sql.string (string themeId) ] (Map.toThemeAsset false) + Custom.list + $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @themeId" + [ "@themeId", Sql.string (string 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 = @themeId" - [ "@themeId", Sql.string (string themeId) ] (Map.toThemeAsset true) + Custom.list + $"SELECT * FROM {Table.ThemeAsset} WHERE theme_id = @themeId" + [ "@themeId", Sql.string (string themeId) ] + (Map.toThemeAsset true) /// Save a theme asset - let save (asset : ThemeAsset) = + let save (asset: ThemeAsset) = log.LogTrace "ThemeAsset.save" let (ThemeAssetId (ThemeId themeId, path)) = asset.Id Custom.nonQuery @@ -103,13 +114,13 @@ type PostgresThemeAssetData (log : ILogger) = ) 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 ] + [ "@themeId", Sql.string themeId + "@path", Sql.string path + "@data", Sql.bytea asset.Data + typedParam "updatedOn" asset.UpdatedOn ] interface IThemeAssetData with - member _.All () = all () + member _.All() = all () member _.DeleteByTheme themeId = deleteByTheme themeId member _.FindById assetId = findById assetId member _.FindByTheme themeId = findByTheme themeId diff --git a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs index e97b212..f78c0f3 100644 --- a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs @@ -6,8 +6,8 @@ open MyWebLog open MyWebLog.Data open Npgsql.FSharp -/// PostgreSQL myWebLog uploaded file data implementation -type PostgresUploadData (log : ILogger) = +/// PostgreSQL myWebLog uploaded file data implementation +type PostgresUploadData(log: ILogger) = /// The INSERT statement for an uploaded file let upInsert = $" @@ -18,13 +18,12 @@ type PostgresUploadData (log : ILogger) = )" /// Parameters for adding an uploaded file - let upParams (upload : Upload) = [ - webLogIdParam upload.WebLogId - typedParam "updatedOn" upload.UpdatedOn - "@id", Sql.string (string upload.Id) - "@path", Sql.string (string upload.Path) - "@data", Sql.bytea upload.Data - ] + let upParams (upload: Upload) = + [ webLogIdParam upload.WebLogId + typedParam "updatedOn" upload.UpdatedOn + "@id", Sql.string (string upload.Id) + "@path", Sql.string (string upload.Path) + "@data", Sql.bytea upload.Data ] /// Save an uploaded file let add upload = @@ -36,31 +35,39 @@ type PostgresUploadData (log : ILogger) = log.LogTrace "Upload.delete" let idParam = [ "@id", Sql.string (string 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") + 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 (Query.Delete.byId Table.Upload) idParam return Ok path.Value - else return Error $"""Upload ID {uploadId} not found""" + 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) + 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) + 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) + 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 { diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index 7015724..5c8eb0e 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -5,11 +5,11 @@ open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -/// PostgreSQL myWebLog web log data implementation -type PostgresWebLogData (log : ILogger) = +/// PostgreSQL myWebLog web log data implementation +type PostgresWebLogData(log: ILogger) = /// Add a web log - let add (webLog : WebLog) = + let add (webLog: WebLog) = log.LogTrace "WebLog.add" insert Table.WebLog webLog @@ -31,25 +31,24 @@ type PostgresWebLogData (log : ILogger) = {Query.Delete.byContains Table.TagMap}; {Query.Delete.byContains Table.WebLogUser}; DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId; - DELETE FROM {Table.WebLog} WHERE 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) = + let findByHost (url: string) = log.LogTrace "WebLog.findByHost" - Custom.single (selectWithCriteria Table.WebLog) [ "@criteria", Query.jsonbDocParam {| UrlBase = url |} ] - fromData + Find.firstByContains Table.WebLog {| UrlBase = url |} /// Find a web log by its ID let findById (webLogId: WebLogId) = log.LogTrace "WebLog.findById" Find.byId Table.WebLog (string webLogId) + /// Update redirect rules for a web log let updateRedirectRules (webLog: WebLog) = backgroundTask { log.LogTrace "WebLog.updateRedirectRules" match! findById webLog.Id with - | Some _ -> - do! Update.partialById Table.WebLog (string webLog.Id) {| RedirectRules = webLog.RedirectRules |} + | Some _ -> do! Update.partialById Table.WebLog (string webLog.Id) {| RedirectRules = webLog.RedirectRules |} | None -> () } @@ -68,7 +67,7 @@ type PostgresWebLogData (log : ILogger) = interface IWebLogData with member _.Add webLog = add webLog - member _.All () = all () + member _.All() = all () member _.Delete webLogId = delete webLogId member _.FindByHost url = findByHost url member _.FindById webLogId = findById webLogId diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs index 22090ce..ed7f08c 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -6,13 +6,13 @@ open MyWebLog open MyWebLog.Data open Npgsql.FSharp -/// PostgreSQL myWebLog user data implementation -type PostgresWebLogUserData (log : ILogger) = +/// PostgreSQL myWebLog user data implementation +type PostgresWebLogUserData(log: ILogger) = /// Find a user by their ID for the given web log let findById userId webLogId = log.LogTrace "WebLogUser.findById" - Document.findByIdAndWebLog Table.WebLogUser userId string webLogId + Document.findByIdAndWebLog Table.WebLogUser userId webLogId /// Delete a user if they have no posts or pages let delete userId webLogId = backgroundTask { @@ -22,10 +22,11 @@ type PostgresWebLogUserData (log : ILogger) = let criteria = Query.whereDataContains "@criteria" let! isAuthor = Custom.scalar - $" SELECT ( EXISTS (SELECT 1 FROM {Table.Page} WHERE {criteria} + $" SELECT ( EXISTS (SELECT 1 FROM {Table.Page} WHERE {criteria}) OR EXISTS (SELECT 1 FROM {Table.Post} WHERE {criteria}) ) AS {existsName}" - [ "@criteria", Query.jsonbDocParam {| AuthorId = userId |} ] Map.toExists + [ "@criteria", Query.jsonbDocParam {| AuthorId = userId |} ] + Map.toExists if isAuthor then return Error "User has pages or posts; cannot delete" else @@ -35,26 +36,27 @@ type PostgresWebLogUserData (log : ILogger) = } /// Find a user by their e-mail address for the given web log - let findByEmail (email : string) webLogId = + let findByEmail (email: string) webLogId = log.LogTrace "WebLogUser.findByEmail" - Custom.single (selectWithCriteria Table.WebLogUser) - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Email = email |} ] - fromData + Find.firstByContains 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 + $"{selectWithCriteria Table.WebLogUser} ORDER BY LOWER(data ->> '{nameof WebLogUser.Empty.PreferredName}')" + [ webLogContains webLogId ] + fromData /// 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 id" "id" string userIds + let idSql, idParams = inClause "AND id" "id" userIds let! users = - Custom.list $"{selectWithCriteria Table.WebLogUser} {idSql}" (webLogContains webLogId :: idParams) - fromData + Custom.list + $"{selectWithCriteria Table.WebLogUser} {idSql}" + (webLogContains webLogId :: idParams) + fromData return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) } @@ -64,17 +66,16 @@ type PostgresWebLogUserData (log : ILogger) = let! _ = Configuration.dataSource () |> Sql.fromDataSource - |> Sql.executeTransactionAsync [ - Query.insert Table.WebLogUser, - users |> List.map (fun user -> Query.docParameters (string user.Id) user) - ] + |> Sql.executeTransactionAsync + [ Query.insert Table.WebLogUser, + users |> List.map (fun user -> Query.docParameters (string user.Id) 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 string webLogId with + match! Document.existsByWebLog Table.WebLogUser userId webLogId with | true -> do! Update.partialById Table.WebLogUser (string userId) {| LastSeenOn = Some (Noda.now ()) |} | false -> () } @@ -94,4 +95,3 @@ type PostgresWebLogUserData (log : ILogger) = member _.Restore users = restore users member _.SetLastSeen userId webLogId = setLastSeen userId webLogId member _.Update user = save user - diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 4ea5b44..09e4207 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -32,9 +32,10 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = if needsTable Table.Theme then isNew <- true Definition.createTable Table.Theme + Definition.createKey Table.Theme if needsTable Table.ThemeAsset then $"CREATE TABLE {Table.ThemeAsset} ( - theme_id TEXT NOT NULL REFERENCES {Table.Theme} (id) ON DELETE CASCADE, + theme_id TEXT NOT NULL, path TEXT NOT NULL, updated_on TIMESTAMPTZ NOT NULL, data BYTEA NOT NULL, @@ -43,28 +44,32 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = // Web log table if needsTable Table.WebLog then Definition.createTable Table.WebLog + Definition.createKey Table.WebLog Definition.createIndex Table.WebLog Optimized // Category table if needsTable Table.Category then Definition.createTable Table.Category + Definition.createKey Table.Category Definition.createIndex Table.Category Optimized // Web log user table if needsTable Table.WebLogUser then Definition.createTable Table.WebLogUser + Definition.createKey Table.WebLogUser Definition.createIndex Table.WebLogUser Optimized // Page tables if needsTable Table.Page then Definition.createTable Table.Page + Definition.createKey Table.Page $"CREATE INDEX page_web_log_idx ON {Table.Page} ((data ->> '{nameof Page.Empty.WebLogId}'))" $"CREATE INDEX page_author_idx ON {Table.Page} ((data ->> '{nameof Page.Empty.AuthorId}'))" $"CREATE INDEX page_permalink_idx ON {Table.Page} ((data ->> '{nameof Page.Empty.WebLogId}'), (data ->> '{nameof Page.Empty.Permalink}'))" if needsTable Table.PageRevision then $"CREATE TABLE {Table.PageRevision} ( - page_id TEXT NOT NULL REFERENCES {Table.Page} (id) ON DELETE CASCADE, + page_id TEXT NOT NULL, as_of TIMESTAMPTZ NOT NULL, revision_text TEXT NOT NULL, PRIMARY KEY (page_id, as_of))" @@ -72,6 +77,7 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = // Post tables if needsTable Table.Post then Definition.createTable Table.Post + Definition.createKey Table.Post $"CREATE INDEX post_web_log_idx ON {Table.Post} ((data ->> '{nameof Post.Empty.WebLogId}'))" $"CREATE INDEX post_author_idx ON {Table.Post} ((data ->> '{nameof Post.Empty.AuthorId}'))" $"CREATE INDEX post_status_idx ON {Table.Post} @@ -83,25 +89,27 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = $"CREATE INDEX post_tag_idx ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))" if needsTable Table.PostRevision then $"CREATE TABLE {Table.PostRevision} ( - post_id TEXT NOT NULL REFERENCES {Table.Post} (id) ON DELETE CASCADE, + 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 Definition.createTable Table.PostComment + Definition.createKey Table.PostComment $"CREATE INDEX post_comment_post_idx ON {Table.PostComment} ((data ->> '{nameof Comment.Empty.PostId}'))" // Tag map table if needsTable Table.TagMap then Definition.createTable Table.TagMap + Definition.createKey Table.TagMap Definition.createIndex 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 REFERENCES {Table.WebLog} (id), + web_log_id TEXT NOT NULL, path TEXT NOT NULL, updated_on TIMESTAMPTZ NOT NULL, data BYTEA NOT NULL)" @@ -120,7 +128,7 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = (sql |> Seq.map (fun s -> let parts = s.Replace(" IF NOT EXISTS", "", System.StringComparison.OrdinalIgnoreCase).Split ' ' - if parts[1].ToLowerInvariant () = "table" then + if parts[1].ToLowerInvariant() = "table" then log.LogInformation $"Creating {parts[2]} table..." s, [ [] ]) |> List.ofSeq) @@ -150,7 +158,7 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = " - 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) -> sprintf "./myWebLog backup %s v2-rc2.%s.json" url slug) + yield! webLogs |> List.map (fun (url, slug) -> $"./myWebLog backup {url} v2-rc2.{slug}.json") ] |> String.concat "\n" |> log.LogWarning -- 2.45.1 From 58b83b8d28fbd5d544389bdbd58ce8e2f4f410d7 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Dec 2023 23:39:36 -0500 Subject: [PATCH 021/123] WIP on SQLite JSON documents --- src/MyWebLog.Data/SQLite/Helpers.fs | 33 +- .../SQLite/SQLiteCategoryData.fs | 35 +- src/MyWebLog.Data/SQLiteData.fs | 321 ++++++++---------- 3 files changed, 195 insertions(+), 194 deletions(-) diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index d7031fb..70df4b3 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -66,26 +66,26 @@ open MyWebLog.Data open NodaTime.Text /// Run a command that returns a count -let count (cmd : SqliteCommand) = backgroundTask { - let! it = cmd.ExecuteScalarAsync () +let count (cmd: SqliteCommand) = backgroundTask { + let! it = cmd.ExecuteScalarAsync() return int (it :?> int64) } /// Create a list of items from the given data reader -let toList<'T> (it : SqliteDataReader -> 'T) (rdr : SqliteDataReader) = +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 + 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 () +let write (cmd: SqliteCommand) = backgroundTask { + let! _ = cmd.ExecuteNonQueryAsync() () } @@ -366,7 +366,26 @@ module Map = CreatedOn = getInstant "created_on" rdr LastSeenOn = tryInstant "last_seen_on" rdr } + + /// Map from a document to a domain type, specifying the field name for the document + let fromData<'T> ser rdr fieldName : 'T = + Utils.deserialize<'T> ser (getString fieldName rdr) + + /// Map from a document to a domain type + let fromDoc<'T> ser rdr : 'T = + fromData<'T> ser rdr "data" + +/// Queries to assist with document manipulation +module Query = + + /// Fragment to add an ID condition to a WHERE clause + let whereById = + "data ->> 'Id' = @id" + +/// Fragment to add a web log ID condition to a WHERE clause +let whereWebLogId = + "data ->> 'WebLogId' = @webLogId" /// Add a web log ID parameter let addWebLogId (cmd: SqliteCommand) (webLogId: WebLogId) = - cmd.Parameters.AddWithValue ("@webLogId", string webLogId) |> ignore + cmd.Parameters.AddWithValue("@webLogId", string webLogId) |> ignore diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index d3d96b2..79c862b 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -4,9 +4,10 @@ open System.Threading.Tasks open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data +open Newtonsoft.Json /// SQLite myWebLog category data implementation -type SQLiteCategoryData(conn: SqliteConnection) = +type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer) = /// Add parameters for category INSERT or UPDATE statements let addCategoryParameters (cmd: SqliteCommand) (cat: Category) = @@ -34,8 +35,8 @@ type SQLiteCategoryData(conn: SqliteConnection) = /// 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" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT COUNT(*) FROM {Table.Category} WHERE {whereWebLogId}" addWebLogId cmd webLogId return! count cmd } @@ -44,25 +45,27 @@ type SQLiteCategoryData(conn: SqliteConnection) = 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" + $"SELECT COUNT(*) FROM {Table.Category} + WHERE {whereWebLogId} AND data ->> '{nameof Category.Empty.ParentId}' IS NULL" addWebLogId cmd webLogId return! count cmd } + // TODO: need to get SQLite in clause format for JSON documents /// 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" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT data FROM {Table.Category} WHERE {whereWebLogId}" addWebLogId cmd webLogId - use! rdr = cmd.ExecuteReaderAsync () + use! rdr = cmd.ExecuteReaderAsync() let cats = seq { - while rdr.Read () do - Map.toCategory rdr + while rdr.Read() do + Map.fromDoc ser rdr } - |> Seq.sortBy (fun cat -> cat.Name.ToLowerInvariant ()) + |> Seq.sortBy _.Name.ToLowerInvariant() |> List.ofSeq - do! rdr.CloseAsync () + do! rdr.CloseAsync() let ordered = Utils.orderByHierarchy cats None None [] let! counts = ordered @@ -71,7 +74,7 @@ type SQLiteCategoryData(conn: SqliteConnection) = 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) |> List.ofSeq |> inClause "AND pc.category_id" "catId" id @@ -103,12 +106,12 @@ type SQLiteCategoryData(conn: SqliteConnection) = /// Find a category by its ID for the given web log let findById (catId: CategoryId) webLogId = backgroundTask { use cmd = conn.CreateCommand() - cmd.CommandText <- "SELECT * FROM category WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", string catId) |> ignore + cmd.CommandText <- $"SELECT * FROM {Table.Category} WHERE {Query.whereById}" + cmd.Parameters.AddWithValue("@id", string catId) |> ignore use! rdr = cmd.ExecuteReaderAsync() - return verifyWebLog webLogId (_.WebLogId) Map.toCategory rdr + return verifyWebLog webLogId (_.WebLogId) (Map.fromDoc ser) rdr } - + // TODO: stopped here /// Find all categories for the given web log let findByWebLog (webLogId: WebLogId) = backgroundTask { use cmd = conn.CreateCommand () diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index e30aafd..edb44ff 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -7,58 +7,57 @@ open MyWebLog.Data.SQLite open Newtonsoft.Json open NodaTime -/// SQLite myWebLog data implementation -type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonSerializer) = +/// SQLite myWebLog data implementation +type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSerializer) = let ensureTables () = backgroundTask { - use cmd = conn.CreateCommand () + use cmd = conn.CreateCommand() let! tables = backgroundTask { cmd.CommandText <- "SELECT name FROM sqlite_master WHERE type = 'table'" - let! rdr = cmd.ExecuteReaderAsync () + let! rdr = cmd.ExecuteReaderAsync() let mutable tableList = [] - while rdr.Read() do + while! rdr.ReadAsync() do tableList <- Map.getString "name" rdr :: tableList - do! rdr.CloseAsync () + do! rdr.CloseAsync() return tableList } + let needsTable table = not (List.contains table tables) + + let jsonTable table = + $"CREATE TABLE {table} (data TEXT NOT NULL); + CREATE UNIQUE INDEX idx_{table}_key ON {table} (data ->> 'Id')" + seq { // Theme tables - if needsTable Table.Theme then - $"CREATE TABLE {Table.Theme} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{Table.Theme}_key ON {Table.Theme} (data ->> 'Id')"; - if needsTable "theme_asset" then - "CREATE TABLE theme_asset ( - theme_id TEXT NOT NULL REFERENCES theme (id), + 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 - $"CREATE TABLE {Table.WebLog} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{Table.WebLog}_key ON {Table.WebLog} (data ->> 'Id')" + if needsTable Table.WebLog then jsonTable Table.WebLog // Category table if needsTable Table.Category then - $"CREATE TABLE {Table.Category} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{Table.Category}_key ON {Table.Category} (data -> 'Id'); + $"{jsonTable Table.Category}; CREATE INDEX idx_{Table.Category}_web_log ON {Table.Category} (data ->> 'WebLogId')" // Web log user table if needsTable Table.WebLogUser then - $"CREATE TABLE web_log_user (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{Table.WebLogUser}_key ON {Table.WebLogUser} (data ->> 'Id'); + $"{jsonTable Table.WebLogUser}; CREATE INDEX idx_{Table.WebLogUser}_email ON {Table.WebLogUser} (data ->> 'WebLogId', data ->> 'Email')" // Page tables if needsTable Table.Page then - $"CREATE TABLE {Table.Page} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{Table.Page}_key ON {Table.Page} (data ->> 'Id'); + $"{jsonTable Table.Page}; CREATE INDEX idx_{Table.Page}_author ON {Table.Page} (data ->> 'AuthorId'); CREATE INDEX idx_{Table.Page}_permalink ON {Table.Page} (data ->> 'WebLogId', data ->> 'Permalink')" if needsTable Table.PageRevision then @@ -70,8 +69,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS // Post tables if needsTable Table.Post then - $"CREATE TABLE {Table.Post} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{Table.Post}_key ON {Table.Post} (data ->> 'Id'); + $"{jsonTable Table.Post}; CREATE INDEX idx_{Table.Post}_author ON {Table.Post} (data ->> 'AuthorId'); CREATE INDEX idx_{Table.Post}_status ON {Table.Post} (data ->> 'WebLogId', data ->> 'Status', data ->> 'UpdatedOn'); CREATE INDEX idx_{Table.Post}_permalink ON {Table.Post} (data ->> 'WebLogId', data ->> 'Permalink')" @@ -83,22 +81,12 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS revision_text TEXT NOT NULL, PRIMARY KEY (post_id, as_of))" if needsTable Table.PostComment then - $"CREATE TABLE {Table.PostComment} ( - id TEXT PRIMARY KEY, - post_id TEXT NOT NULL, - 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 idx_{Table.PostComment}_post ON {Table.PostComment} (post_id)" + $"{jsonTable Table.PostComment}; + CREATE INDEX idx_{Table.PostComment}_post ON {Table.PostComment} (data ->> 'PostId')" // Tag map table if needsTable Table.TagMap then - $"CREATE TABLE {Table.TagMap} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{Table.TagMap}_key ON {Table.TagMap} (data ->> 'Id'); + $"{jsonTable Table.TagMap}; CREATE INDEX idx_{Table.TagMap}_tag ON {Table.TagMap} (data ->> 'WebLogId', data ->> 'UrlValue')"; // Uploaded file table @@ -126,7 +114,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS /// Set the database version to the specified version let setDbVersion version = backgroundTask { - use cmd = conn.CreateCommand () + use cmd = conn.CreateCommand() cmd.CommandText <- $"DELETE FROM {Table.DbVersion}; INSERT INTO {Table.DbVersion} VALUES ('%s{version}')" do! write cmd } @@ -135,7 +123,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS let migrateV2Rc1ToV2Rc2 () = backgroundTask { let logStep = Utils.logMigrationStep log "v2-rc1 to v2-rc2" // Move meta items, podcast settings, and episode details to JSON-encoded text fields - use cmd = conn.CreateCommand () + use cmd = conn.CreateCommand() logStep "Adding new columns" cmd.CommandText <- "ALTER TABLE web_log_feed ADD COLUMN podcast TEXT; @@ -146,10 +134,10 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS logStep "Migrating meta items" let migrateMeta entity = backgroundTask { cmd.CommandText <- $"SELECT * FROM %s{entity}_meta" - use! metaRdr = cmd.ExecuteReaderAsync () + use! metaRdr = cmd.ExecuteReaderAsync() let allMetas = seq { - while metaRdr.Read () do + while metaRdr.Read() do Map.getString $"{entity}_id" metaRdr, { Name = Map.getString "name" metaRdr; Value = Map.getString "value" metaRdr } } |> List.ofSeq @@ -165,120 +153,117 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS "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 ()) + [ 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 () + use! podcastRdr = cmd.ExecuteReaderAsync() let podcasts = seq { - while podcastRdr.Read () do + 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 - } + { 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 () + 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.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 () + use! epRdr = cmd.ExecuteReaderAsync() let episodes = seq { - while epRdr.Read () do + 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 ser) - ChapterFile = Map.tryString "chapter_file" epRdr - ChapterType = Map.tryString "chapter_type" epRdr - 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 System.Double.Parse - EpisodeDescription = Map.tryString "episode_description" 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 ser) + ChapterFile = Map.tryString "chapter_file" epRdr + ChapterType = Map.tryString "chapter_type" epRdr + 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 System.Double.Parse + EpisodeDescription = Map.tryString "episode_description" epRdr } } |> List.ofSeq - epRdr.Close () + 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 ()) + [ 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 : System.DateTime) = - System.DateTime (dt.Ticks, System.DateTimeKind.Utc) + let inst (dt: System.DateTime) = + System.DateTime(dt.Ticks, System.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 () + use! pageRdr = cmd.ExecuteReaderAsync() let toUpdate = seq { - while pageRdr.Read () do + while pageRdr.Read() do Map.getString "id" pageRdr, inst (Map.getDateTime "updated_on" pageRdr), inst (Map.getDateTime "published_on" pageRdr) } |> List.ofSeq - pageRdr.Close () + 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 + [ 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 () + let _ = cmd.ExecuteNonQuery() ()) - cmd.Parameters.Clear () + cmd.Parameters.Clear() // page_revision.as_of cmd.CommandText <- "SELECT * FROM page_revision" - use! pageRevRdr = cmd.ExecuteReaderAsync () + use! pageRevRdr = cmd.ExecuteReaderAsync() let toUpdate = seq { - while pageRevRdr.Read () do + 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 @@ -286,141 +271,135 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS 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 + [ 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 () + let _ = cmd.ExecuteNonQuery() ()) - cmd.Parameters.Clear () + cmd.Parameters.Clear() // post.updated_on, post.published_on (opt) cmd.CommandText <- "SELECT id, updated_on, published_on FROM post" - use! postRdr = cmd.ExecuteReaderAsync () + use! postRdr = cmd.ExecuteReaderAsync() let toUpdate = seq { - while postRdr.Read () do + while postRdr.Read() do Map.getString "id" postRdr, - inst (Map.getDateTime "updated_on" postRdr), + inst (Map.getDateTime "updated_on" postRdr), (Map.tryDateTime "published_on" postRdr |> Option.map inst) } |> List.ofSeq - postRdr.Close () + 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 + [ 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 () + let _ = cmd.ExecuteNonQuery() ()) - cmd.Parameters.Clear () + cmd.Parameters.Clear() // post_revision.as_of cmd.CommandText <- "SELECT * FROM post_revision" - use! postRevRdr = cmd.ExecuteReaderAsync () + use! postRevRdr = cmd.ExecuteReaderAsync() let toUpdate = seq { - while postRevRdr.Read () do + 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 () + 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 + [ 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 () + let _ = cmd.ExecuteNonQuery() ()) - cmd.Parameters.Clear () + cmd.Parameters.Clear() // theme_asset.updated_on cmd.CommandText <- "SELECT theme_id, path, updated_on FROM theme_asset" - use! assetRdr = cmd.ExecuteReaderAsync () + use! assetRdr = cmd.ExecuteReaderAsync() let toUpdate = seq { - while assetRdr.Read () do + 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 + [ 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 () + let _ = cmd.ExecuteNonQuery() ()) - cmd.Parameters.Clear () + cmd.Parameters.Clear() // upload.updated_on cmd.CommandText <- "SELECT id, updated_on FROM upload" - use! upRdr = cmd.ExecuteReaderAsync () + use! upRdr = cmd.ExecuteReaderAsync() let toUpdate = seq { - while upRdr.Read () do + 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 + [ 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 () + let _ = cmd.ExecuteNonQuery() ()) - cmd.Parameters.Clear () + 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 () + use! userRdr = cmd.ExecuteReaderAsync() let toUpdate = seq { - while userRdr.Read () do + 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 () + 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 + [ 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 () + let _ = cmd.ExecuteNonQuery() ()) - cmd.Parameters.Clear () + cmd.Parameters.Clear() - conn.Close () - conn.Open () + conn.Close() + conn.Open() logStep "Dropping old tables and columns" cmd.CommandText <- @@ -444,7 +423,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS /// Migrate from v2 to v2.1 let migrateV2ToV2point1 () = backgroundTask { Utils.logMigrationStep log "v2 to v2.1" "Adding redirect rules to web_log table" - use cmd = conn.CreateCommand () + use cmd = conn.CreateCommand() cmd.CommandText <- "ALTER TABLE web_log ADD COLUMN redirect_rules TEXT NOT NULL DEFAULT '[]'" do! write cmd @@ -477,17 +456,17 @@ type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonS member _.Conn = conn /// Make a SQLite connection ready to execute commends - static member setUpConnection (conn : SqliteConnection) = backgroundTask { - do! conn.OpenAsync () - use cmd = conn.CreateCommand () + static member setUpConnection (conn: SqliteConnection) = backgroundTask { + do! conn.OpenAsync() + use cmd = conn.CreateCommand() cmd.CommandText <- "PRAGMA foreign_keys = TRUE" - let! _ = cmd.ExecuteNonQueryAsync () + let! _ = cmd.ExecuteNonQueryAsync() () } interface IData with - member _.Category = SQLiteCategoryData conn + member _.Category = SQLiteCategoryData (conn, ser) member _.Page = SQLitePageData (conn, ser) member _.Post = SQLitePostData (conn, ser) member _.TagMap = SQLiteTagMapData conn -- 2.45.1 From 2062840a5e5265f89c8ff2d34a01cdcd8a925023 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 17 Dec 2023 21:17:46 -0500 Subject: [PATCH 022/123] WIP on SQLite JSON documents through TagMap done --- src/MyWebLog.Data/SQLite/Helpers.fs | 296 +++++++---- .../SQLite/SQLiteCategoryData.fs | 183 +++---- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 317 ++++------- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 490 +++++------------- src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs | 91 ++-- src/MyWebLog.Data/SQLiteData.fs | 41 +- 6 files changed, 585 insertions(+), 833 deletions(-) diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 70df4b3..9ebabeb 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -108,8 +108,25 @@ let maybeDuration = 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) = +let inClause<'T> colNameAndPrefix paramName (valueFunc: 'T -> string) (items: 'T list) = if List.isEmpty items then "", [] else let mutable idx = 0 @@ -131,25 +148,25 @@ module Map = open System.IO /// Get a boolean value from a data reader - let getBoolean col (rdr : SqliteDataReader) = rdr.GetBoolean (rdr.GetOrdinal col) + 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) + 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) + 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) + 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) + 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) + 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) + let getString col (rdr: SqliteDataReader) = rdr.GetString(rdr.GetOrdinal col) /// Parse a Duration from the given value let parseDuration value = @@ -172,27 +189,27 @@ module Map = getString col rdr |> parseInstant /// Get a timespan value from a data reader - let getTimeSpan col (rdr : SqliteDataReader) = rdr.GetTimeSpan (rdr.GetOrdinal col) + 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) + 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) + 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) + 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) + 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) + let tryString col (rdr: SqliteDataReader) = + if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getString col rdr) /// Get a possibly null Duration value from a data reader let tryDuration col rdr = @@ -203,22 +220,12 @@ module Map = tryString col rdr |> Option.map parseInstant /// 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) + 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 ser rdr : CustomFeed = { Id = getString "id" rdr |> CustomFeedId @@ -230,48 +237,10 @@ module Map = /// 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 ser 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 = getInstant "published_on" rdr - UpdatedOn = getInstant "updated_on" rdr - IsInPageList = getBoolean "is_in_page_list" rdr - Template = tryString "template" rdr - Text = getString "page_text" rdr - Metadata = tryString "meta_items" rdr - |> Option.map (Utils.deserialize ser) - |> Option.defaultValue [] - } - - /// Create a post from the current row in the given data reader - let toPost ser 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 = tryInstant "published_on" rdr - UpdatedOn = getInstant "updated_on" rdr - Template = tryString "template" rdr - Text = getString "post_text" rdr - Episode = tryString "episode" rdr |> Option.map (Utils.deserialize ser) - Metadata = tryString "meta_items" rdr - |> Option.map (Utils.deserialize ser) - |> Option.defaultValue [] - } - /// 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 - } + { AsOf = getInstant "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 = @@ -293,16 +262,15 @@ module Map = let toThemeAsset includeData rdr : ThemeAsset = let assetData = if includeData then - use dataStream = new MemoryStream () + use dataStream = new MemoryStream() use blobStream = getStream "data" rdr blobStream.CopyTo dataStream - dataStream.ToArray () + dataStream.ToArray() else [||] - { Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr) - UpdatedOn = getInstant "updated_on" rdr - Data = assetData - } + { Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr) + UpdatedOn = getInstant "updated_on" rdr + Data = assetData } /// Create a theme template from the current row in the given data reader let toThemeTemplate includeText rdr : ThemeTemplate = @@ -320,12 +288,11 @@ module Map = 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 - } + { 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 web log from the current row in the given data reader let toWebLog ser rdr : WebLog = @@ -375,17 +342,170 @@ module Map = let fromDoc<'T> ser rdr : 'T = fromData<'T> ser rdr "data" +/// Create a list of items for the results of the given command +let cmdToList<'TDoc> (cmd: SqliteCommand) ser = backgroundTask { + use! rdr = cmd.ExecuteReaderAsync() + let mutable it: 'TDoc list = [] + while! rdr.ReadAsync() do + it <- Map.fromDoc ser rdr :: it + return List.rev it +} + /// Queries to assist with document manipulation module Query = - /// Fragment to add an ID condition to a WHERE clause + /// Fragment to add an ID condition to a WHERE clause (parameter @id) let whereById = "data ->> 'Id' = @id" -/// Fragment to add a web log ID condition to a WHERE clause -let whereWebLogId = - "data ->> 'WebLogId' = @webLogId" + /// Fragment to add a web log ID condition to a WHERE clause (parameter @webLogId) + let whereByWebLog = + "data ->> 'WebLogId' = @webLogId" + + /// A SELECT/FROM pair for the given table + let selectFromTable table = + $"SELECT data FROM %s{table}" + + /// An INSERT statement for a document (parameter @data) + let insert table = + $"INSERT INTO %s{table} VALUES (@data)" + + /// A SELECT query to count documents for a given web log ID + let countByWebLog table = + $"SELECT COUNT(*) FROM %s{table} WHERE {whereByWebLog}" + + /// An UPDATE query to update a full document by its ID (parameters @data and @id) + let updateById table = + $"UPDATE %s{table} SET data = @data WHERE {whereById}" + + /// A DELETE query to delete a document by its ID (parameter @id) + let deleteById table = + $"DELETE FROM %s{table} WHERE {whereById}" + + +let addParam (cmd: SqliteCommand) name (value: obj) = + cmd.Parameters.AddWithValue(name, value) |> ignore + +/// Add an ID parameter for a document +let addDocId<'TKey> (cmd: SqliteCommand) (id: 'TKey) = + addParam cmd "@id" (string id) + +/// Add a document parameter +let addDocParam<'TDoc> (cmd: SqliteCommand) (doc: 'TDoc) ser = + addParam cmd "@data" (Utils.serialize ser doc) /// Add a web log ID parameter let addWebLogId (cmd: SqliteCommand) (webLogId: WebLogId) = - cmd.Parameters.AddWithValue("@webLogId", string webLogId) |> ignore + addParam cmd "@webLogId" (string webLogId) + +/// Functions for manipulating documents +module Document = + + /// Count documents for the given web log ID + let countByWebLog (conn: SqliteConnection) table webLogId = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- Query.countByWebLog table + addWebLogId cmd webLogId + return! count cmd + } + + /// Find a document by its ID and web log ID + let findByIdAndWebLog<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) webLogId = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.selectFromTable table} WHERE {Query.whereById} AND {Query.whereByWebLog}" + addDocId cmd key + addWebLogId cmd webLogId + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.fromDoc<'TDoc> ser rdr) else None + } + + /// Find documents for the given web log + let findByWebLog<'TDoc> (conn: SqliteConnection) ser table webLogId = + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.selectFromTable table} WHERE {Query.whereByWebLog}" + addWebLogId cmd webLogId + cmdToList<'TDoc> cmd ser + + /// Insert a document + let insert<'TDoc> (conn: SqliteConnection) ser table (doc: 'TDoc) = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- Query.insert table + addDocParam<'TDoc> cmd doc ser + do! write cmd + } + + /// Update (replace) a document by its ID + let update<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) (doc: 'TDoc) = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- Query.updateById table + addDocId cmd key + addDocParam<'TDoc> cmd doc ser + do! write cmd + } + + /// Delete a document by its ID + let delete<'TKey> (conn: SqliteConnection) table (key: 'TKey) = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- Query.deleteById table + addDocId cmd key + do! write cmd + } + +/// Functions to support revisions +module Revisions = + + /// Find all revisions for the given entity + let findByEntityId<'TKey> (conn: SqliteConnection) revTable entityTable (key: 'TKey) = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- + $"SELECT as_of, revision_text FROM %s{revTable} WHERE %s{entityTable}_id = @id ORDER BY as_of DESC" + addDocId cmd key + use! rdr = cmd.ExecuteReaderAsync() + return toList Map.toRevision rdr + } + + /// Find all revisions for all posts for the given web log + let findByWebLog<'TKey> (conn: SqliteConnection) revTable entityTable (keyFunc: string -> 'TKey) + webLogId = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- + $"SELECT pr.* + FROM %s{revTable} pr + INNER JOIN %s{entityTable} p ON p.data ->> 'Id' = pr.{entityTable}_id + WHERE p.{Query.whereByWebLog} + ORDER BY as_of DESC" + addWebLogId cmd webLogId + use! rdr = cmd.ExecuteReaderAsync() + return toList (fun rdr -> keyFunc (Map.getString $"{entityTable}_id" rdr), Map.toRevision rdr) rdr + } + + /// Parameters for a revision INSERT statement + let revParams<'TKey> (key: 'TKey) rev = + [ SqliteParameter("asOf", rev.AsOf) + SqliteParameter("@id", string key) + SqliteParameter("@text", rev.Text) ] + + /// The SQL statement to insert a revision + let insertSql table = + $"INSERT INTO %s{table} VALUES (@id, @asOf, @text)" + + /// Update a page or post's revisions + let update<'TKey> (conn: SqliteConnection) revTable entityTable (key: 'TKey) oldRevs newRevs = backgroundTask { + let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs + if not (List.isEmpty toDelete) || not (List.isEmpty toAdd) then + use cmd = conn.CreateCommand() + if not (List.isEmpty toDelete) then + cmd.CommandText <- $"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf" + for delRev in toDelete do + cmd.Parameters.Clear() + addDocId cmd key + addParam cmd "@asOf" delRev.AsOf + do! write cmd + if not (List.isEmpty toAdd) then + cmd.CommandText <- insertSql revTable + for addRev in toAdd do + cmd.Parameters.Clear() + cmd.Parameters.AddRange(revParams key addRev) + do! write cmd + } diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 79c862b..3e892c2 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -2,71 +2,46 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks 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, ser: JsonSerializer) = +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", string cat.Id) - cmd.Parameters.AddWithValue ("@webLogId", string 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 string)) - ] |> ignore + /// The name of the parent ID field + let parentIdField = nameof Category.Empty.ParentId /// 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 () - () - } + let add (cat: Category) = + log.LogTrace "Category.add" + Document.insert conn ser Table.Category cat /// Count all categories for the given web log - let countAll webLogId = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT COUNT(*) FROM {Table.Category} WHERE {whereWebLogId}" - addWebLogId cmd webLogId - return! count cmd - } + let countAll webLogId = + log.LogTrace "Category.countAll" + Document.countByWebLog conn Table.Category webLogId /// Count all top-level categories for the given web log let countTopLevel webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- - $"SELECT COUNT(*) FROM {Table.Category} - WHERE {whereWebLogId} AND data ->> '{nameof Category.Empty.ParentId}' IS NULL" + log.LogTrace "Category.countTopLevel" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.countByWebLog} AND data ->> '{parentIdField}' IS NULL" addWebLogId cmd webLogId return! count cmd } - // TODO: need to get SQLite in clause format for JSON documents + /// Find all categories for the given web log + let findByWebLog webLogId = + log.LogTrace "Category.findByWebLog" + Document.findByWebLog conn ser Table.Category webLogId + /// Retrieve all categories for the given web log in a DotLiquid-friendly format let findAllForView webLogId = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT data FROM {Table.Category} WHERE {whereWebLogId}" - addWebLogId cmd webLogId - use! rdr = cmd.ExecuteReaderAsync() - let cats = - seq { - while rdr.Read() do - Map.fromDoc ser rdr - } - |> Seq.sortBy _.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 { @@ -77,74 +52,83 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer) = |> Seq.map _.Id |> Seq.append (Seq.singleton it.Id) |> List.ofSeq - |> inClause "AND pc.category_id" "catId" id - cmd.Parameters.Clear () + |> inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId" + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') + FROM {Table.Post} + WHERE {Query.whereByWebLog} + AND data ->> '{nameof Post.Empty.Status}' = '{string Published}' + AND {catSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange catParams - 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' - {catSql}" let! postCount = count cmd return it.Id, 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 = + counts + |> Array.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: CategoryId) webLogId = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT * FROM {Table.Category} WHERE {Query.whereById}" - cmd.Parameters.AddWithValue("@id", string catId) |> ignore - use! rdr = cmd.ExecuteReaderAsync() - return verifyWebLog webLogId (_.WebLogId) (Map.fromDoc ser) rdr - } - // TODO: stopped here - /// Find all categories for the given web log - let findByWebLog (webLogId: WebLogId) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM category WHERE web_log_id = @webLogId" - cmd.Parameters.AddWithValue ("@webLogId", string webLogId) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return toList Map.toCategory rdr - } + let findById catId webLogId = + log.LogTrace "Category.findById" + Document.findByIdAndWebLog conn ser Table.Category catId webLogId /// Delete a category let delete catId webLogId = backgroundTask { + log.LogTrace "Category.delete" match! findById catId webLogId with | Some cat -> - use cmd = conn.CreateCommand () + use cmd = conn.CreateCommand() // Reassign any children to the category's parent category - cmd.CommandText <- "SELECT COUNT(id) FROM category WHERE parent_id = @parentId" - cmd.Parameters.AddWithValue ("@parentId", string catId) |> ignore + cmd.CommandText <- $"SELECT COUNT(*) FROM {Table.Category} WHERE data ->> '{parentIdField}' = @parentId" + addParam cmd "@parentId" (string catId) let! children = count cmd if children > 0 then - cmd.CommandText <- "UPDATE category SET parent_id = @newParentId WHERE parent_id = @parentId" - cmd.Parameters.AddWithValue ("@newParentId", maybe (cat.ParentId |> Option.map string)) - |> ignore + cmd.CommandText <- $" + UPDATE {Table.Category} + SET data = json_set(data, '$.{parentIdField}', @newParentId) + WHERE data ->> '{parentIdField}' = @parentId" + addParam cmd "@newParentId" (maybe (cat.ParentId |> Option.map string)) do! write cmd // Delete the category off all posts where it is assigned, and the category itself - cmd.CommandText <- - "DELETE FROM post_category - WHERE category_id = @id - AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId); - DELETE FROM category WHERE id = @id" - cmd.Parameters.Clear () - let _ = cmd.Parameters.AddWithValue ("@id", string catId) + let catIdField = Post.Empty.CategoryIds + cmd.CommandText <- $" + SELECT data ->> '{Post.Empty.Id}' AS id, data -> '{catIdField}' AS cat_ids + FROM {Table.Post} + WHERE {Query.whereByWebLog} + AND EXISTS + (SELECT 1 FROM json_each({Table.Post}.data -> '{catIdField}') WHERE json_each.value = @id)" + cmd.Parameters.Clear() + addDocId cmd catId addWebLogId cmd webLogId - do! write cmd + use! postRdr = cmd.ExecuteReaderAsync() + if postRdr.HasRows then + let postIdAndCats = + toList + (fun rdr -> + Map.getString "id" rdr, Utils.deserialize ser (Map.getString "cat_ids" rdr)) + postRdr + do! postRdr.CloseAsync() + for postId, cats in postIdAndCats do + cmd.CommandText <- $" + UPDATE {Table.Post} + SET data = json_set(data, '$.{catIdField}', json(@catIds)) + WHERE {Query.whereById}" + cmd.Parameters.Clear() + addDocId cmd postId + addParam cmd "@catIds" (cats |> List.filter (fun it -> it <> string catId) |> Utils.serialize ser) + do! write cmd + do! Document.delete conn Table.Category catId return if children = 0 then CategoryDeleted else ReassignedChildCategories | None -> return CategoryNotFound } @@ -156,17 +140,12 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer) = } /// 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 + let update (cat: Category) = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.updateById} AND {Query.whereByWebLog}" + addDocId cmd cat.Id + addDocParam cmd cat ser + addWebLogId cmd cat.WebLogId do! write cmd } diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index c8ebd49..277e53f 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -2,184 +2,99 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data open Newtonsoft.Json /// SQLite myWebLog page data implementation -type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = +type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = + + /// The JSON field for the permalink + let linkField = $"data ->> '{nameof Page.Empty.Permalink}'" + + /// The JSON field for the "is in page list" flag + let pgListField = $"data ->> '{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", string page.Id) - cmd.Parameters.AddWithValue ("@webLogId", string page.WebLogId) - cmd.Parameters.AddWithValue ("@authorId", string page.AuthorId) - cmd.Parameters.AddWithValue ("@title", page.Title) - cmd.Parameters.AddWithValue ("@permalink", string page.Permalink) - cmd.Parameters.AddWithValue ("@publishedOn", instantParam page.PublishedOn) - cmd.Parameters.AddWithValue ("@updatedOn", instantParam page.UpdatedOn) - cmd.Parameters.AddWithValue ("@isInPageList", page.IsInPageList) - cmd.Parameters.AddWithValue ("@template", maybe page.Template) - cmd.Parameters.AddWithValue ("@text", page.Text) - cmd.Parameters.AddWithValue ("@metaItems", maybe (if List.isEmpty page.Metadata then None - else Some (Utils.serialize ser page.Metadata))) - ] |> ignore - - /// Append revisions and permalinks to a page - let appendPageRevisionsAndPermalinks (page : Page) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@pageId", string 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 } + /// Append revisions to a page + let appendPageRevisions (page : Page) = backgroundTask { + log.LogTrace "Page.appendPageRevisions" + let! revisions = Revisions.findByEntityId conn Table.PageRevision Table.Page page.Id + return { page with Revisions = revisions } } - /// Shorthand for mapping a data reader to a page - let toPage = - Map.toPage ser - - /// Return a page with no text (or prior permalinks or revisions) - let pageWithoutText rdr = - { toPage rdr with Text = "" } - - /// Update a page's prior permalinks - let updatePagePermalinks (pageId: PageId) oldLinks newLinks = backgroundTask { - let toDelete, toAdd = Utils.diffPermalinks oldLinks newLinks - if List.isEmpty toDelete && List.isEmpty toAdd then - return () - else - use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@pageId", string pageId) - cmd.Parameters.Add ("@link", SqliteType.Text) - ] |> ignore - let runCmd (link: Permalink) = backgroundTask { - cmd.Parameters["@link"].Value <- string 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 - } + /// Return a page with no text + let withoutText (page: Page) = + { page with Text = "" } /// Update a page's revisions - let updatePageRevisions (pageId: PageId) oldRevs newRevs = backgroundTask { - let toDelete, toAdd = Utils.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", string pageId) - cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) - ] |> ignore - if withText then cmd.Parameters.AddWithValue ("@text", string 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 conn Table.PageRevision Table.Page pageId oldRevs newRevs // 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, meta_items - ) VALUES ( - @id, @webLogId, @authorId, @title, @permalink, @publishedOn, @updatedOn, @isInPageList, @template, - @text, @metaItems - )" - addPageParameters cmd page - do! write cmd - do! updatePagePermalinks page.Id [] page.PriorPermalinks - do! updatePageRevisions page.Id [] page.Revisions + log.LogTrace "Page.add" + do! Document.insert conn ser 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) + /// Get all pages for a web log (without text or revisions) let all webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM page WHERE web_log_id = @webLogId ORDER BY LOWER(title)" + log.LogTrace "Page.all" + use cmd = conn.CreateCommand() + cmd.CommandText <- + $"{Query.selectFromTable Table.Page} WHERE {Query.whereByWebLog} ORDER BY LOWER({titleField})" addWebLogId cmd webLogId - use! rdr = cmd.ExecuteReaderAsync () - return toList pageWithoutText rdr + let! pages = cmdToList cmd ser + return pages |> List.map withoutText } /// 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 conn Table.Page webLogId /// 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" + log.LogTrace "Page.countListed" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.countByWebLog} AND {pgListField} = 'true'" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore return! count cmd } - /// Find a page by its ID (without revisions and prior permalinks) - let findById (pageId: PageId) webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM page WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", string pageId) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return verifyWebLog webLogId (_.WebLogId) (Map.toPage ser) rdr - } + /// Find a page by its ID (without revisions) + let findById pageId webLogId = + log.LogTrace "Page.findById" + Document.findByIdAndWebLog conn ser Table.Page pageId webLogId /// Find a complete page by its ID let findFullById pageId webLogId = backgroundTask { + log.LogTrace "Page.findFullById" match! findById pageId webLogId 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", string pageId) |> ignore - cmd.CommandText <- - "DELETE FROM page_revision WHERE page_id = @id; - DELETE FROM page_permalink WHERE page_id = @id; - DELETE FROM page WHERE id = @id" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"DELETE FROM {Table.PageRevision} WHERE page_id = @id; {Query.deleteById}" + addDocId cmd pageId do! write cmd return true | None -> return false @@ -187,112 +102,98 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer) = /// Find a page by its permalink for the given web log let findByPermalink (permalink: Permalink) webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM page WHERE web_log_id = @webLogId AND permalink = @link" + log.LogTrace "Page.findByPermalink" + use cmd = conn.CreateCommand() + cmd.CommandText <- $" {Query.selectFromTable Table.Page} WHERE {Query.whereByWebLog} AND {linkField} = @link" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@link", string permalink) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return if rdr.Read () then Some (toPage rdr) else None + addParam cmd "@link" (string permalink) + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.fromDoc ser rdr) else None } /// Find the current permalink within a set of potential prior permalinks for the given web log let findCurrentPermalink (permalinks: Permalink list) webLogId = backgroundTask { - use cmd = conn.CreateCommand () - let linkSql, linkParams = inClause "AND pp.permalink" "link" string permalinks - 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 - {linkSql}" + log.LogTrace "Page.findCurrentPermalink" + let linkSql, linkParams = inJsonArray Table.Page (nameof Page.Empty.PriorPermalinks) "link" permalinks + use cmd = conn.CreateCommand() + cmd.CommandText <- + $"SELECT {linkField} AS permalink FROM {Table.Page} WHERE {Query.whereByWebLog} AND {linkSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange linkParams - use! rdr = cmd.ExecuteReaderAsync () - return if rdr.Read () then Some (Map.toPermalink rdr) else None + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.toPermalink rdr) else None } /// 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 toPage rdr - |> List.map (fun page -> backgroundTask { return! appendPageRevisionsAndPermalinks page }) + log.LogTrace "Page.findFullByWebLog" + let! pages = Document.findByWebLog conn ser Table.Page webLogId + let! withRevs = + pages + |> List.map (fun page -> backgroundTask { return! appendPageRevisions page }) |> Task.WhenAll - return List.ofArray pages + return List.ofArray withRevs } - /// Get all listed pages for the given web log (without revisions, prior permalinks, or text) + /// Get all listed pages for the given web log (without revisions or text) let findListed webLogId = backgroundTask { + log.LogTrace "Page.findListed" use cmd = conn.CreateCommand () - cmd.CommandText <- - "SELECT * - FROM page - WHERE web_log_id = @webLogId - AND is_in_page_list = @isInPageList - ORDER BY LOWER(title)" + cmd.CommandText <- $" + {Query.selectFromTable Table.Page} + WHERE {Query.whereByWebLog} + AND {pgListField} = 'true' + ORDER BY LOWER({titleField})" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return toList pageWithoutText rdr + let! pages = cmdToList cmd ser + return pages |> List.map withoutText } - /// 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" + /// Get a page of pages for the given web log (without revisions) + let findPageOfPages webLogId pageNbr = + log.LogTrace "Page.findPageOfPages" + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + {Query.selectFromTable Table.Page} WHERE {Query.whereByWebLog} + ORDER BY LOWER({titleField}) + 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 toPage rdr - } + addParam cmd "@pageSize" 26 + addParam cmd "@toSkip" ((pageNbr - 1) * 25) + cmdToList cmd ser /// Restore pages from a backup let restore pages = backgroundTask { + log.LogTrace "Page.restore" for page in pages do do! add page } /// Update a page - let update (page : Page) = backgroundTask { + let update (page: Page) = backgroundTask { + log.LogTrace "Page.update" 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, - meta_items = @metaItems - WHERE id = @id - AND web_log_id = @webLogId" - addPageParameters cmd page - do! write cmd - do! updatePagePermalinks page.Id oldPage.PriorPermalinks page.PriorPermalinks - do! updatePageRevisions page.Id oldPage.Revisions page.Revisions - return () - | None -> return () + do! Document.update conn ser 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 = 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 _ -> + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + UPDATE {Table.Page} + SET data = json_set(data, '$.{nameof Page.Empty.PriorPermalinks}', json(@links)) + WHERE {Query.whereById}" + addDocId cmd pageId + addParam cmd "@links" (Utils.serialize ser permalinks) + do! write cmd return true | None -> return false } diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 97c02b4..dc26393 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -2,265 +2,105 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data open Newtonsoft.Json open NodaTime /// SQLite myWebLog post data implementation -type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = - +type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = + + /// The JSON field for the post's permalink + let linkField = $"data ->> '{nameof Post.Empty.Permalink}'" + + /// The JSON field for when the post was published + let publishField = $"data ->> '{nameof Post.Empty.PublishedOn}'" + + /// The JSON field for post status + let statField = $"data ->> '{nameof Post.Empty.Status}'" + // SUPPORT FUNCTIONS - /// Add parameters for post INSERT or UPDATE statements - let addPostParameters (cmd: SqliteCommand) (post: Post) = - [ cmd.Parameters.AddWithValue ("@id", string post.Id) - cmd.Parameters.AddWithValue ("@webLogId", string post.WebLogId) - cmd.Parameters.AddWithValue ("@authorId", string post.AuthorId) - cmd.Parameters.AddWithValue ("@status", string post.Status) - cmd.Parameters.AddWithValue ("@title", post.Title) - cmd.Parameters.AddWithValue ("@permalink", string post.Permalink) - cmd.Parameters.AddWithValue ("@publishedOn", maybeInstant post.PublishedOn) - cmd.Parameters.AddWithValue ("@updatedOn", instantParam post.UpdatedOn) - cmd.Parameters.AddWithValue ("@template", maybe post.Template) - cmd.Parameters.AddWithValue ("@text", post.Text) - cmd.Parameters.AddWithValue ("@episode", maybe (if Option.isSome post.Episode then - Some (Utils.serialize ser post.Episode) - else None)) - cmd.Parameters.AddWithValue ("@metaItems", maybe (if List.isEmpty post.Metadata then None - else Some (Utils.serialize ser post.Metadata))) - ] |> ignore - - /// Append category IDs and tags to a post - let appendPostCategoryAndTag (post: Post) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.Parameters.AddWithValue ("@id", string 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 () - return { post with Tags = toList (Map.getString "tag") rdr } + /// Append revisions to a post + let appendPostRevisions (post: Post) = backgroundTask { + log.LogTrace "Post.appendPostRevisions" + let! revisions = Revisions.findByEntityId conn Table.PostRevision Table.Post post.Id + 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", string post.Id) |> ignore - - 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 to retrieve posts with a web log ID parameter + let postByWebLog = $"{Query.selectFromTable Table.Post} WHERE {Query.whereByWebLog}" - /// The SELECT statement for a post that will include episode data, if it exists - let selectPost = "SELECT p.* FROM post p" + /// The SELECT statement to retrieve published posts with a web log ID parameter + let publishedPostByWebLog = $"{postByWebLog} AND {statField} = '{string Published}'" - /// Shorthand for mapping a data reader to a post - let toPost = - Map.toPost ser - - /// Find just-the-post by its ID for the given web log (excludes category, tag, meta, revisions, and permalinks) - let findPostById (postId: PostId) webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- $"{selectPost} WHERE p.id = @id" - cmd.Parameters.AddWithValue ("@id", string postId) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return verifyWebLog webLogId (_.WebLogId) toPost rdr - } - - /// Return a post with no revisions, prior permalinks, or text - let postWithoutText rdr = - { toPost rdr with Text = "" } - - /// Update a post's assigned categories - let updatePostCategories (postId: PostId) oldCats newCats = backgroundTask { - let toDelete, toAdd = Utils.diffLists oldCats newCats string - if List.isEmpty toDelete && List.isEmpty toAdd then - return () - else - use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", string postId) - cmd.Parameters.Add ("@categoryId", SqliteType.Text) - ] |> ignore - let runCmd (catId: CategoryId) = backgroundTask { - cmd.Parameters["@categoryId"].Value <- string 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: PostId) (oldTags: string list) newTags = backgroundTask { - let toDelete, toAdd = Utils.diffLists oldTags newTags id - if List.isEmpty toDelete && List.isEmpty toAdd then - return () - else - use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", string 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 a post's prior permalinks - let updatePostPermalinks (postId: PostId) oldLinks newLinks = backgroundTask { - let toDelete, toAdd = Utils.diffPermalinks oldLinks newLinks - if List.isEmpty toDelete && List.isEmpty toAdd then - return () - else - use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", string postId) - cmd.Parameters.Add ("@link", SqliteType.Text) - ] |> ignore - let runCmd (link: Permalink) = backgroundTask { - cmd.Parameters["@link"].Value <- string 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 - } + /// Remove the text from a post + let withoutText (post: Post) = + { post with Text = "" } /// Update a post's revisions - let updatePostRevisions (postId: PostId) oldRevs newRevs = backgroundTask { - let toDelete, toAdd = Utils.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", string postId) - cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) - ] |> ignore - if withText then cmd.Parameters.AddWithValue ("@text", string 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 conn Table.PostRevision Table.Post postId oldRevs newRevs // 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, - episode, meta_items - ) VALUES ( - @id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, @template, @text, - @episode, @metaItems - )" - addPostParameters cmd post - do! write cmd - do! updatePostCategories post.Id [] post.CategoryIds - do! updatePostTags post.Id [] post.Tags - do! updatePostPermalinks post.Id [] post.PriorPermalinks - do! updatePostRevisions post.Id [] post.Revisions + let add (post: Post) = backgroundTask { + log.LogTrace "Post.add" + do! Document.insert conn ser 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 = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT COUNT(id) FROM post WHERE web_log_id = @webLogId AND status = @status" + log.LogTrace "Post.countByStatus" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.countByWebLog Table.Post} AND {statField} = @status" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@status", string status) |> ignore + addParam cmd "@status" (string status) return! count cmd } /// Find a post by its ID for the given web log (excluding revisions and prior permalinks - let findById postId webLogId = backgroundTask { - match! findPostById postId webLogId with - | Some post -> - let! post = appendPostCategoryAndTag post - return Some post - | None -> return None - } + let findById postId webLogId = + log.LogTrace "Post.findById" + Document.findByIdAndWebLog conn ser Table.Post postId webLogId /// Find a post by its permalink for the given web log (excluding revisions and prior permalinks) let findByPermalink (permalink: Permalink) webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- $"{selectPost} WHERE p.web_log_id = @webLogId AND p.permalink = @link" + log.LogTrace "Post.findByPermalink" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.selectFromTable Table.Post} WHERE {Query.whereByWebLog} AND {linkField} = @link" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@link", string permalink) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - if rdr.Read () then - let! post = appendPostCategoryAndTag (toPost rdr) - return Some post - else - return None + addParam cmd "@link" (string permalink) + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.fromDoc ser rdr) else None } /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { + log.LogTrace "Post.findFullById" match! findById postId webLogId 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", string postId) |> ignore - cmd.CommandText <- - "DELETE FROM post_revision WHERE post_id = @id; - DELETE FROM post_permalink WHERE post_id = @id; - DELETE FROM post_tag WHERE post_id = @id; - DELETE FROM post_category WHERE post_id = @id; - DELETE FROM post_comment WHERE post_id = @id; - DELETE FROM post WHERE id = @id" + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + DELETE FROM {Table.PostRevision} WHERE post_id = @id; + DELETE FROM {Table.PostComment} WHERE data ->> '{nameof Comment.Empty.PostId}' = @id; + DELETE FROM {Table.Post} WHERE {Query.whereById}" + addDocId cmd postId do! write cmd return true | None -> return false @@ -268,198 +108,130 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer) = /// Find the current permalink from a list of potential prior permalinks for the given web log let findCurrentPermalink (permalinks: Permalink list) webLogId = backgroundTask { - use cmd = conn.CreateCommand () - let linkSql, linkParams = inClause "AND pp.permalink" "link" string permalinks - 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 - {linkSql}" + log.LogTrace "Post.findCurrentPermalink" + let linkSql, linkParams = inJsonArray Table.Post (nameof Post.Empty.PriorPermalinks) "link" permalinks + use cmd = conn.CreateCommand() + cmd.CommandText <- + $"SELECT {linkField} AS permalink FROM {Table.Post} WHERE {Query.whereByWebLog} AND {linkSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange linkParams - use! rdr = cmd.ExecuteReaderAsync () - return if rdr.Read () then Some (Map.toPermalink rdr) else None + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.toPermalink rdr) else None } /// 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 toPost rdr - |> List.map (fun post -> backgroundTask { - let! post = appendPostCategoryAndTag post - return! appendPostRevisionsAndPermalinks post - }) + log.LogTrace "Post.findFullByWebLog" + let! posts = Document.findByWebLog conn ser Table.Post webLogId + let! withRevs = + posts + |> List.map (fun post -> backgroundTask { return! appendPostRevisions post }) |> Task.WhenAll - return List.ofArray posts + return List.ofArray withRevs } - /// Get a page of categorized posts for the given web log (excludes revisions and prior permalinks) - let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = backgroundTask { + /// 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 use cmd = conn.CreateCommand () - let catSql, catParams = inClause "AND pc.category_id" "catId" string categoryIds cmd.CommandText <- $" - {selectPost} - INNER JOIN post_category pc ON pc.post_id = p.id - WHERE p.web_log_id = @webLogId - AND p.status = @status - {catSql} - ORDER BY published_on DESC + {publishedPostByWebLog} AND {catSql} + ORDER BY {publishField} DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@status", string Published) |> ignore cmd.Parameters.AddRange catParams - use! rdr = cmd.ExecuteReaderAsync () - let! posts = - toList toPost rdr - |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post }) - |> Task.WhenAll - return List.ofArray posts - } + cmdToList cmd ser - /// Get a page of posts for the given web log (excludes text, revisions, and prior permalinks) + /// Get a page of posts for the given web log (excludes revisions) let findPageOfPosts webLogId pageNbr postsPerPage = backgroundTask { - use cmd = conn.CreateCommand () + log.LogTrace "Post.findPageOfPosts" + use cmd = conn.CreateCommand() cmd.CommandText <- $" - {selectPost} - WHERE p.web_log_id = @webLogId - ORDER BY p.published_on DESC NULLS FIRST, p.updated_on + {postByWebLog} + ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}' 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! appendPostCategoryAndTag post }) - |> Task.WhenAll - return List.ofArray posts + let! posts = cmdToList cmd ser + return posts |> List.map withoutText } - /// 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 () + /// Get a page of published posts for the given web log (excludes revisions) + let findPageOfPublishedPosts webLogId pageNbr postsPerPage = + log.LogTrace "Post.findPageOfPublishedPosts" + use cmd = conn.CreateCommand() cmd.CommandText <- $" - {selectPost} - WHERE p.web_log_id = @webLogId - AND p.status = @status + {publishedPostByWebLog} + ORDER BY {publishField} DESC + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" + addWebLogId cmd webLogId + cmdToList cmd ser + + /// 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 ] + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + {publishedPostByWebLog} AND {tagSql} ORDER BY p.published_on DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@status", string Published) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - let! posts = - toList toPost rdr - |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post }) - |> Task.WhenAll - return List.ofArray posts - } - - /// 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", string Published) - cmd.Parameters.AddWithValue ("@tag", tag) - ] |> ignore - use! rdr = cmd.ExecuteReaderAsync () - let! posts = - toList toPost rdr - |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post }) - |> Task.WhenAll - return List.ofArray posts - } + cmd.Parameters.AddRange tagParams + cmdToList cmd ser /// 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" 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", string Published) - cmd.Parameters.AddWithValue ("@publishedOn", instantParam publishedOn) - ] |> ignore - use! rdr = cmd.ExecuteReaderAsync () - let! older = backgroundTask { - if rdr.Read () then - let! post = appendPostCategoryAndTag (postWithoutText rdr) - return Some post - else - return None - } + addParam cmd "@publishedOn" (instantParam publishedOn) + + cmd.CommandText <- + $"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1" + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + let older = if isFound then Some (Map.fromDoc ser rdr) else 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" + + cmd.CommandText <- + $"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1" use! rdr = cmd.ExecuteReaderAsync () - let! newer = backgroundTask { - if rdr.Read () then - let! post = appendPostCategoryAndTag (postWithoutText rdr) - return Some post - else - return None - } + let! isFound = rdr.ReadAsync() + let newer = if isFound then Some (Map.fromDoc ser rdr) else None + return older, newer } /// Restore posts from a backup let restore posts = backgroundTask { + log.LogTrace "Post.restore" for post in posts do do! add post } /// Update a post - let update (post : Post) = backgroundTask { + let update (post: Post) = backgroundTask { 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, - episode = @episode, - meta_items = @metaItems - 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! updatePostPermalinks post.Id oldPost.PriorPermalinks post.PriorPermalinks - do! updatePostRevisions post.Id oldPost.Revisions post.Revisions + do! Document.update conn ser Table.Post post.Id { post with Revisions = [] } + do! updatePostRevisions post.Id oldPost.Revisions post.Revisions | None -> return () } /// 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 _ -> + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + UPDATE {Table.Post} + SET data = json_set(data, '$.{nameof Post.Empty.PriorPermalinks}', json(@links)) + WHERE {Query.whereById}" + addDocId cmd postId + addParam cmd "@links" (Utils.serialize ser permalinks) + do! write cmd return true | None -> return false } diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index d17d203..64440ac 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -1,95 +1,70 @@ namespace MyWebLog.Data.SQLite open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data +open Newtonsoft.Json -/// SQLite myWebLog tag mapping data implementation -type SQLiteTagMapData (conn : SqliteConnection) = +/// SQLite myWebLog tag mapping data implementation +type SQLiteTagMapData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = /// Find a tag mapping by its ID for the given web log - let findById (tagMapId: TagMapId) webLogId = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- "SELECT * FROM tag_map WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", string tagMapId) |> ignore - use! rdr = cmd.ExecuteReaderAsync() - return verifyWebLog webLogId (_.WebLogId) Map.toTagMap rdr - } + let findById tagMapId webLogId = + log.LogTrace "TagMap.findById" + Document.findByIdAndWebLog conn ser Table.TagMap tagMapId webLogId /// 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", string tagMapId) |> ignore - do! write cmd + do! Document.delete conn 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" + let findByUrlValue (urlValue: string) webLogId = backgroundTask { + log.LogTrace "TagMap.findByUrlValue" + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + {Query.selectFromTable Table.TagMap} + WHERE {Query.whereByWebLog} + AND data ->> '{nameof TagMap.Empty.UrlValue}' = @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 + addParam cmd "@urlValue" urlValue + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.fromDoc ser rdr) else None } /// 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 conn ser Table.TagMap webLogId /// Find any tag mappings in a list of tags for the given web log - let findMappingForTags (tags : string list) webLogId = backgroundTask { + let findMappingForTags (tags: string list) webLogId = + log.LogTrace "TagMap.findMappingForTags" use cmd = conn.CreateCommand () - let mapSql, mapParams = inClause "AND tag" "tag" id tags - cmd.CommandText <- $" - SELECT * - FROM tag_map - WHERE web_log_id = @webLogId - {mapSql}" + let mapSql, mapParams = inClause $"AND data ->> '{nameof TagMap.Empty.Tag}'" "tag" id tags + cmd.CommandText <- $"{Query.selectFromTable Table.TagMap} WHERE {Query.whereByWebLog} {mapSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange mapParams - use! rdr = cmd.ExecuteReaderAsync () - return toList Map.toTagMap rdr - } + cmdToList cmd ser /// Save a tag mapping - let save (tagMap : TagMap) = backgroundTask { - use cmd = conn.CreateCommand () + let save (tagMap: TagMap) = backgroundTask { + log.LogTrace "TagMap.save" 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", string tagMap.Id) - cmd.Parameters.AddWithValue ("@tag", tagMap.Tag) - cmd.Parameters.AddWithValue ("@urlValue", tagMap.UrlValue) - ] |> ignore - do! write cmd + | Some _ -> do! Document.update conn ser Table.TagMap tagMap.Id tagMap + | None -> do! Document.insert conn ser Table.TagMap tagMap } /// Restore tag mappings from a backup let restore tagMaps = backgroundTask { + log.LogTrace "TagMap.restore" for tagMap in tagMaps do do! save tagMap } diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index edb44ff..af84359 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -29,7 +29,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria let jsonTable table = $"CREATE TABLE {table} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{table}_key ON {table} (data ->> 'Id')" + CREATE UNIQUE INDEX idx_{table}_key ON {table} ((data ->> 'Id'))" seq { // Theme tables @@ -48,18 +48,20 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria // Category table if needsTable Table.Category then $"{jsonTable Table.Category}; - CREATE INDEX idx_{Table.Category}_web_log ON {Table.Category} (data ->> 'WebLogId')" + CREATE INDEX idx_{Table.Category}_web_log ON {Table.Category} ((data ->> 'WebLogId'))" // Web log user table if needsTable Table.WebLogUser then $"{jsonTable Table.WebLogUser}; - CREATE INDEX idx_{Table.WebLogUser}_email ON {Table.WebLogUser} (data ->> 'WebLogId', data ->> 'Email')" + CREATE INDEX idx_{Table.WebLogUser}_email + ON {Table.WebLogUser} ((data ->> 'WebLogId'), (data ->> 'Email'))" // Page tables if needsTable Table.Page then $"{jsonTable Table.Page}; - CREATE INDEX idx_{Table.Page}_author ON {Table.Page} (data ->> 'AuthorId'); - CREATE INDEX idx_{Table.Page}_permalink ON {Table.Page} (data ->> 'WebLogId', data ->> 'Permalink')" + CREATE INDEX idx_{Table.Page}_author ON {Table.Page} ((data ->> 'AuthorId')); + CREATE INDEX idx_{Table.Page}_permalink + ON {Table.Page} ((data ->> 'WebLogId'), (data ->> 'Permalink'))" if needsTable Table.PageRevision then "CREATE TABLE page_revision ( page_id TEXT NOT NULL, @@ -70,9 +72,11 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria // Post tables if needsTable Table.Post then $"{jsonTable Table.Post}; - CREATE INDEX idx_{Table.Post}_author ON {Table.Post} (data ->> 'AuthorId'); - CREATE INDEX idx_{Table.Post}_status ON {Table.Post} (data ->> 'WebLogId', data ->> 'Status', data ->> 'UpdatedOn'); - CREATE INDEX idx_{Table.Post}_permalink ON {Table.Post} (data ->> 'WebLogId', data ->> 'Permalink')" + CREATE INDEX idx_{Table.Post}_author ON {Table.Post} ((data ->> 'AuthorId')); + CREATE INDEX idx_{Table.Post}_status + ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Status'), (data ->> 'UpdatedOn')); + CREATE INDEX idx_{Table.Post}_permalink + ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Permalink'))" // TODO: index categories by post? if needsTable Table.PostRevision then $"CREATE TABLE {Table.PostRevision} ( @@ -82,12 +86,12 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria PRIMARY KEY (post_id, as_of))" if needsTable Table.PostComment then $"{jsonTable Table.PostComment}; - CREATE INDEX idx_{Table.PostComment}_post ON {Table.PostComment} (data ->> 'PostId')" + CREATE INDEX idx_{Table.PostComment}_post ON {Table.PostComment} ((data ->> 'PostId'))" // Tag map table if needsTable Table.TagMap then $"{jsonTable Table.TagMap}; - CREATE INDEX idx_{Table.TagMap}_tag ON {Table.TagMap} (data ->> 'WebLogId', data ->> 'UrlValue')"; + CREATE INDEX idx_{Table.TagMap}_tag ON {Table.TagMap} ((data ->> 'WebLogId'), (data ->> 'UrlValue'))" // Uploaded file table if needsTable Table.Upload then @@ -451,7 +455,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" do! setDbVersion Utils.currentDbVersion } - + /// The connection for this instance member _.Conn = conn @@ -466,10 +470,10 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria interface IData with - member _.Category = SQLiteCategoryData (conn, ser) - member _.Page = SQLitePageData (conn, ser) - member _.Post = SQLitePostData (conn, ser) - member _.TagMap = SQLiteTagMapData conn + member _.Category = SQLiteCategoryData (conn, ser, log) + member _.Page = SQLitePageData (conn, ser, log) + member _.Post = SQLitePostData (conn, ser, log) + member _.TagMap = SQLiteTagMapData (conn, ser, log) member _.Theme = SQLiteThemeData conn member _.ThemeAsset = SQLiteThemeAssetData conn member _.Upload = SQLiteUploadData conn @@ -481,8 +485,9 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria member _.StartUp () = backgroundTask { do! ensureTables () - use cmd = conn.CreateCommand () + use cmd = conn.CreateCommand() cmd.CommandText <- $"SELECT id FROM {Table.DbVersion}" - use! rdr = cmd.ExecuteReaderAsync () - do! migrate (if rdr.Read () then Some (Map.getString "id" rdr) else None) + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + do! migrate (if isFound then Some (Map.getString "id" rdr) else None) } -- 2.45.1 From e04c8b58e9d824bb708d6f54a41505387075528c Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 17 Dec 2023 23:00:57 -0500 Subject: [PATCH 023/123] First cut of SQLite JSON doc complete - Still needs testing - Add revision deletes to PG web log delete --- .../Postgres/PostgresWebLogData.fs | 8 +- src/MyWebLog.Data/SQLite/Helpers.fs | 112 ++----- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 9 +- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 9 +- src/MyWebLog.Data/SQLite/SQLiteThemeData.fs | 230 ++++++--------- src/MyWebLog.Data/SQLite/SQLiteUploadData.fs | 84 +++--- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 277 +++--------------- .../SQLite/SQLiteWebLogUserData.fs | 121 ++++---- src/MyWebLog.Data/SQLiteData.fs | 10 +- 9 files changed, 260 insertions(+), 600 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index 5c8eb0e..60ed13c 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -23,8 +23,12 @@ type PostgresWebLogData(log: ILogger) = log.LogTrace "WebLog.delete" Custom.nonQuery $"""DELETE FROM {Table.PostComment} - WHERE data ->> '{nameof Comment.Empty.PostId}' IN - (SELECT id FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"}); + WHERE data ->> '{nameof Comment.Empty.PostId}' + IN (SELECT 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}; diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 9ebabeb..e5357bd 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -168,16 +168,6 @@ module Map = /// Get a string value from a data reader let getString col (rdr: SqliteDataReader) = rdr.GetString(rdr.GetOrdinal col) - /// Parse a Duration from the given value - let parseDuration value = - match DurationPattern.Roundtrip.Parse value with - | it when it.Success -> it.Value - | it -> raise it.Exception - - /// Get a Duration value from a data reader - let getDuration col rdr = - getString col rdr |> parseDuration - /// Parse an Instant from the given value let parseInstant value = match InstantPattern.General.Parse value with @@ -211,29 +201,10 @@ module Map = let tryString col (rdr: SqliteDataReader) = if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getString col rdr) - /// Get a possibly null Duration value from a data reader - let tryDuration col rdr = - tryString col rdr |> Option.map parseDuration - - /// Get a possibly null Instant value from a data reader - let tryInstant col rdr = - tryString col rdr |> Option.map parseInstant - /// 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 custom feed from the current row in the given data reader - let toCustomFeed ser rdr : CustomFeed = - { Id = getString "id" rdr |> CustomFeedId - Source = getString "source" rdr |> CustomFeedSource.Parse - Path = getString "path" rdr |> Permalink - Podcast = tryString "podcast" rdr |> Option.map (Utils.deserialize ser) - } - /// Create a permalink from the current row in the given data reader let toPermalink rdr = getString "permalink" rdr |> Permalink @@ -242,22 +213,6 @@ module Map = { AsOf = getInstant "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 = @@ -272,12 +227,6 @@ module Map = UpdatedOn = getInstant "updated_on" rdr Data = assetData } - /// Create a theme template from the current row in the given data reader - let toThemeTemplate includeText rdr : ThemeTemplate = - { Name = getString "name" rdr - Text = if includeText then getString "template" rdr else "" - } - /// Create an uploaded file from the current row in the given data reader let toUpload includeData rdr : Upload = let data = @@ -294,46 +243,6 @@ module Map = UpdatedOn = getInstant "updated_on" rdr Data = data } - /// Create a web log from the current row in the given data reader - let toWebLog ser 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 = [] - } - RedirectRules = getString "redirect_rules" rdr |> Utils.deserialize ser - } - - /// 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 - Url = tryString "url" rdr - AccessLevel = getString "access_level" rdr |> AccessLevel.Parse - CreatedOn = getInstant "created_on" rdr - LastSeenOn = tryInstant "last_seen_on" rdr - } - /// Map from a document to a domain type, specifying the field name for the document let fromData<'T> ser rdr fieldName : 'T = Utils.deserialize<'T> ser (getString fieldName rdr) @@ -409,6 +318,16 @@ module Document = return! count cmd } + /// Find a document by its ID + let findById<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.selectFromTable table} WHERE {Query.whereById}" + addDocId cmd key + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.fromDoc<'TDoc> ser rdr) else None + } + /// Find a document by its ID and web log ID let findByIdAndWebLog<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) webLogId = backgroundTask { use cmd = conn.CreateCommand() @@ -444,6 +363,17 @@ module Document = do! write cmd } + /// Update a field in a document by its ID + let updateField<'TKey, 'TValue> (conn: SqliteConnection) ser table (key: 'TKey) jsonField + (value: 'TValue) = backgroundTask { + use cmd = conn.CreateCommand() + cmd.CommandText <- + $"UPDATE %s{table} SET data = json_set(data, '$.{jsonField}', json(@it)) WHERE {Query.whereById}" + addDocId cmd key + addParam cmd "@it" (Utils.serialize ser value) + do! write cmd + } + /// Delete a document by its ID let delete<'TKey> (conn: SqliteConnection) table (key: 'TKey) = backgroundTask { use cmd = conn.CreateCommand() diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index 277e53f..a97c362 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -186,14 +186,7 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = log.LogTrace "Page.updatePriorPermalinks" match! findById pageId webLogId with | Some _ -> - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - UPDATE {Table.Page} - SET data = json_set(data, '$.{nameof Page.Empty.PriorPermalinks}', json(@links)) - WHERE {Query.whereById}" - addDocId cmd pageId - addParam cmd "@links" (Utils.serialize ser permalinks) - do! write cmd + do! Document.updateField conn ser Table.Page pageId (nameof Page.Empty.PriorPermalinks) permalinks return true | None -> return false } diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index dc26393..b6f82a7 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -224,14 +224,7 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = let updatePriorPermalinks postId webLogId (permalinks: Permalink list) = backgroundTask { match! findById postId webLogId with | Some _ -> - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - UPDATE {Table.Post} - SET data = json_set(data, '$.{nameof Post.Empty.PriorPermalinks}', json(@links)) - WHERE {Query.whereById}" - addDocId cmd postId - addParam cmd "@links" (Utils.serialize ser permalinks) - do! write cmd + do! Document.updateField conn ser Table.Post postId (nameof Post.Empty.PriorPermalinks) permalinks return true | None -> return false } diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index ff5403b..5d78177 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -1,77 +1,62 @@ namespace MyWebLog.Data.SQLite -open System.Threading.Tasks open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data +open Newtonsoft.Json -/// SQLite myWebLog theme data implementation -type SQLiteThemeData (conn : SqliteConnection) = +/// SQLite myWebLog theme data implementation +type SQLiteThemeData(conn : SqliteConnection, ser: JsonSerializer, log: ILogger) = + + /// The JSON field for the theme ID + let idField = $"data ->> '{nameof Theme.Empty.Id}'" + + /// 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 () = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM theme WHERE id <> 'admin' ORDER BY id" - use! rdr = cmd.ExecuteReaderAsync () - let themes = toList Map.toTheme rdr - do! rdr.CloseAsync () - cmd.CommandText <- "SELECT name, theme_id FROM theme_template WHERE theme_id <> 'admin' ORDER BY name" - use! rdr = cmd.ExecuteReaderAsync () - let templates = - seq { while rdr.Read () do ThemeId (Map.getString "theme_id" rdr), Map.toThemeTemplate false rdr } - |> List.ofSeq - return - themes - |> List.map (fun t -> - { t with Templates = templates |> List.filter (fun (themeId, _) -> themeId = t.Id) |> List.map snd }) + log.LogTrace "Theme.all" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"{Query.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}" + let! themes = cmdToList cmd ser + return themes |> List.map withoutTemplateText } /// Does a given theme exist? let exists (themeId: ThemeId) = backgroundTask { + log.LogTrace "Theme.exists" use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT COUNT(id) FROM theme WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", string themeId) |> ignore + cmd.CommandText <- $"SELECT COUNT(*) FROM {Table.Theme} WHERE {idField} = @id" + addDocId cmd themeId let! count = count cmd return count > 0 } /// Find a theme by its ID - let findById (themeId: ThemeId) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM theme WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", string 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 true) templateRdr } - else - return None - } + let findById themeId = + log.LogTrace "Theme.findById" + Document.findById conn ser 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 + log.LogTrace "Theme.findByIdWithoutText" + let! theme = findById themeId + return theme |> Option.map withoutTemplateText } /// Delete a theme by its ID let delete themeId = backgroundTask { + log.LogTrace "Theme.delete" match! findByIdWithoutText themeId with | Some _ -> - use cmd = conn.CreateCommand () - cmd.CommandText <- - "DELETE FROM theme_asset WHERE theme_id = @id; - DELETE FROM theme_template WHERE theme_id = @id; - DELETE FROM theme WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", string themeId) |> ignore + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; + DELETE FROM {Table.Theme} WHERE {Query.whereById}" + addDocId cmd themeId do! write cmd return true | None -> return false @@ -79,62 +64,14 @@ type SQLiteThemeData (conn : SqliteConnection) = /// 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", string theme.Id) - cmd.Parameters.AddWithValue ("@name", theme.Name) - cmd.Parameters.AddWithValue ("@version", theme.Version) - ] |> ignore - do! write cmd - - let toDelete, toAdd = - Utils.diffLists (oldTheme |> Option.map _.Templates |> Option.defaultValue []) theme.Templates _.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", string 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 + log.LogTrace "Theme.save" + match! findById theme.Id with + | Some _ -> do! Document.update conn ser Table.Theme theme.Id theme + | None -> do! Document.insert conn ser Table.Theme theme } interface IThemeData with - member _.All () = all () + member _.All() = all () member _.Delete themeId = delete themeId member _.Exists themeId = exists themeId member _.FindById themeId = findById themeId @@ -144,97 +81,100 @@ type SQLiteThemeData (conn : SqliteConnection) = open System.IO -/// SQLite myWebLog theme data implementation -type SQLiteThemeAssetData (conn : SqliteConnection) = +/// SQLite myWebLog theme data implementation +type SQLiteThemeAssetData(conn : SqliteConnection, log: ILogger) = /// 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 () + log.LogTrace "ThemeAsset.all" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset}" + use! rdr = cmd.ExecuteReaderAsync() return toList (Map.toThemeAsset false) rdr } /// Delete all assets for the given theme let deleteByTheme (themeId: ThemeId) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "DELETE FROM theme_asset WHERE theme_id = @themeId" - cmd.Parameters.AddWithValue ("@themeId", string themeId) |> ignore + log.LogTrace "ThemeAsset.deleteByTheme" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @themeId" + addParam cmd "@themeId" (string themeId) do! write cmd } /// Find a theme asset by its ID let findById assetId = backgroundTask { + log.LogTrace "ThemeAsset.findById" use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT *, ROWID FROM theme_asset WHERE theme_id = @themeId AND path = @path" + cmd.CommandText <- $"SELECT *, ROWID FROM {Table.ThemeAsset} 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 + addParam cmd "@themeId" themeId + addParam cmd "@path" path + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.toThemeAsset true rdr) else None } /// Get theme assets for the given theme (excludes data) let findByTheme (themeId: 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", string themeId) |> ignore - use! rdr = cmd.ExecuteReaderAsync () + log.LogTrace "ThemeAsset.findByTheme" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @themeId" + addParam cmd "@themeId" (string themeId) + use! rdr = cmd.ExecuteReaderAsync() return toList (Map.toThemeAsset false) rdr } /// Get theme assets for the given theme let findByThemeWithData (themeId: ThemeId) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT *, ROWID FROM theme_asset WHERE theme_id = @themeId" - cmd.Parameters.AddWithValue ("@themeId", string themeId) |> ignore + log.LogTrace "ThemeAsset.findByThemeWithData" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @themeId" + addParam cmd "@themeId" (string themeId) use! rdr = cmd.ExecuteReaderAsync () return toList (Map.toThemeAsset true) rdr } /// 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 save (asset: ThemeAsset) = backgroundTask { + log.LogTrace "ThemeAsset.save" + use sideCmd = conn.CreateCommand() + sideCmd.CommandText <- $"SELECT COUNT(*) FROM {Table.ThemeAsset} 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 + addParam sideCmd "@themeId" themeId + addParam sideCmd "@path" path 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" + $"UPDATE {Table.ThemeAsset} + SET updated_on = @updatedOn, + data = ZEROBLOB(@dataLength) + WHERE theme_id = @themeId + AND path = @path" else - "INSERT INTO theme_asset ( + $"INSERT INTO {Table.ThemeAsset} ( theme_id, path, updated_on, data - ) VALUES ( + ) VALUES ( @themeId, @path, @updatedOn, ZEROBLOB(@dataLength) - )" - [ cmd.Parameters.AddWithValue ("@themeId", themeId) - cmd.Parameters.AddWithValue ("@path", path) - cmd.Parameters.AddWithValue ("@updatedOn", instantParam asset.UpdatedOn) - cmd.Parameters.AddWithValue ("@dataLength", asset.Data.Length) - ] |> ignore + )" + addParam cmd "@themeId" themeId + addParam cmd "@path" path + addParam cmd "@updatedOn" (instantParam asset.UpdatedOn) + addParam cmd "@dataLength" asset.Data.Length do! write cmd - sideCmd.CommandText <- "SELECT ROWID FROM theme_asset WHERE theme_id = @themeId AND path = @path" - let! rowId = sideCmd.ExecuteScalarAsync () + sideCmd.CommandText <- $"SELECT ROWID FROM {Table.ThemeAsset} WHERE theme_id = @themeId AND path = @path" + let! rowId = sideCmd.ExecuteScalarAsync() - use dataStream = new MemoryStream (asset.Data) - use blobStream = new SqliteBlob (conn, "theme_asset", "data", rowId :?> int64) + use dataStream = new MemoryStream(asset.Data) + use blobStream = new SqliteBlob(conn, Table.ThemeAsset, "data", rowId :?> int64) do! dataStream.CopyToAsync blobStream } interface IThemeAssetData with - member _.All () = all () + member _.All() = all () member _.DeleteByTheme themeId = deleteByTheme themeId member _.FindById assetId = findById assetId member _.FindByTheme themeId = findByTheme themeId diff --git a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs index cf915ae..9a7cd82 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs @@ -2,92 +2,100 @@ namespace MyWebLog.Data.SQLite open System.IO open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data /// SQLite myWebLog web log data implementation -type SQLiteUploadData(conn: SqliteConnection) = +type SQLiteUploadData(conn: SqliteConnection, log: ILogger) = /// Add parameters for uploaded file INSERT and UPDATE statements let addUploadParameters (cmd: SqliteCommand) (upload: Upload) = - [ cmd.Parameters.AddWithValue ("@id", string upload.Id) - cmd.Parameters.AddWithValue ("@webLogId", string upload.WebLogId) - cmd.Parameters.AddWithValue ("@path", string upload.Path) - cmd.Parameters.AddWithValue ("@updatedOn", instantParam upload.UpdatedOn) - cmd.Parameters.AddWithValue ("@dataLength", upload.Data.Length) - ] |> ignore + addParam cmd "@id" (string upload.Id) + addParam cmd "@webLogId" (string upload.WebLogId) + addParam cmd "@path" (string upload.Path) + addParam cmd "@updatedOn" (instantParam upload.UpdatedOn) + addParam cmd "@dataLength" upload.Data.Length /// Save an uploaded file let add upload = backgroundTask { - use cmd = conn.CreateCommand () + log.LogTrace "Upload.add" + use cmd = conn.CreateCommand() cmd.CommandText <- - "INSERT INTO upload ( + $"INSERT INTO {Table.Upload} ( id, web_log_id, path, updated_on, data - ) VALUES ( + ) 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 () + cmd.CommandText <- $"SELECT ROWID FROM {Table.Upload} WHERE id = @id" + let! rowId = cmd.ExecuteScalarAsync() - use dataStream = new MemoryStream (upload.Data) - use blobStream = new SqliteBlob (conn, "upload", "data", rowId :?> int64) + use dataStream = new MemoryStream(upload.Data) + use blobStream = new SqliteBlob(conn, Table.Upload, "data", rowId :?> int64) do! dataStream.CopyToAsync blobStream } /// Delete an uploaded file by its ID - let delete uploadId webLogId = backgroundTask { - use cmd = conn.CreateCommand () + let delete (uploadId: UploadId) webLogId = backgroundTask { + log.LogTrace "Upload.delete" + use cmd = conn.CreateCommand() cmd.CommandText <- - "SELECT id, web_log_id, path, updated_on - FROM upload - WHERE id = @id - AND web_log_id = @webLogId" + $"SELECT id, web_log_id, path, updated_on + FROM {Table.Upload} + WHERE id = @id + AND web_log_id = @webLogId" addWebLogId cmd webLogId - cmd.Parameters.AddWithValue ("@id", string uploadId) |> ignore - let! rdr = cmd.ExecuteReaderAsync () - if (rdr.Read ()) then + addDocId cmd uploadId + let! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + if isFound then let upload = Map.toUpload false rdr - do! rdr.CloseAsync () - cmd.CommandText <- "DELETE FROM upload WHERE id = @id AND web_log_id = @webLogId" + do! rdr.CloseAsync() + cmd.CommandText <- $"DELETE FROM {Table.Upload} WHERE id = @id AND web_log_id = @webLogId" do! write cmd return Ok (string upload.Path) else - return Error $"""Upload ID {cmd.Parameters["@id"]} not found""" + return Error $"""Upload ID {cmd.Parameters["@id"].Value} 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" + let findByPath (path: string) webLogId = backgroundTask { + log.LogTrace "Upload.findByPath" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT *, ROWID FROM {Table.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 + addParam cmd "@path" path + let! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.toUpload true rdr) else None } /// 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" + log.LogTrace "Upload.findByWebLog" + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT id, web_log_id, path, updated_on FROM {Table.Upload} WHERE web_log_id = @webLogId" addWebLogId cmd webLogId - let! rdr = cmd.ExecuteReaderAsync () + let! rdr = cmd.ExecuteReaderAsync() return toList (Map.toUpload false) rdr } /// Find all uploaded files for the given web log let findByWebLogWithData webLogId = backgroundTask { + log.LogTrace "Upload.findByWebLogWithData" use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT *, ROWID FROM upload WHERE web_log_id = @webLogId" + cmd.CommandText <- $"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId" addWebLogId cmd webLogId - let! rdr = cmd.ExecuteReaderAsync () + let! rdr = cmd.ExecuteReaderAsync() return toList (Map.toUpload true) rdr } /// Restore uploads from a backup let restore uploads = backgroundTask { + log.LogTrace "Upload.restore" for upload in uploads do do! add upload } diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index ea2b4ea..ebd7925 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -2,263 +2,78 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data open Newtonsoft.Json -// 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, ser: JsonSerializer) = - - // 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", string 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", string webLog.ThemeId) - cmd.Parameters.AddWithValue ("@urlBase", webLog.UrlBase) - cmd.Parameters.AddWithValue ("@timeZone", webLog.TimeZone) - cmd.Parameters.AddWithValue ("@autoHtmx", webLog.AutoHtmx) - cmd.Parameters.AddWithValue ("@uploads", string webLog.Uploads) - cmd.Parameters.AddWithValue ("@redirectRules", Utils.serialize ser webLog.RedirectRules) - ] |> ignore - addWebLogRssParameters cmd webLog - - /// Add parameters for custom feed INSERT or UPDATE statements - let addCustomFeedParameters (cmd: SqliteCommand) (webLogId: WebLogId) (feed: CustomFeed) = - [ cmd.Parameters.AddWithValue ("@id", string feed.Id) - cmd.Parameters.AddWithValue ("@webLogId", string webLogId) - cmd.Parameters.AddWithValue ("@source", string feed.Source) - cmd.Parameters.AddWithValue ("@path", string feed.Path) - cmd.Parameters.AddWithValue ("@podcast", maybe (if Option.isSome feed.Podcast then - Some (Utils.serialize ser feed.Podcast) - else None)) - ] |> ignore - - /// Shorthand to map a data reader to a custom feed - let toCustomFeed = - Map.toCustomFeed ser - - /// Get the current custom feeds for a web log - let getCustomFeeds (webLog : WebLog) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM web_log_feed WHERE web_log_id = @webLogId" - addWebLogId cmd webLog.Id - use! rdr = cmd.ExecuteReaderAsync () - return toList 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 } } - } - - /// Update the custom feeds for a web log - let updateCustomFeeds (webLog : WebLog) = backgroundTask { - let! feeds = getCustomFeeds webLog - let toDelete, toAdd = Utils.diffLists feeds webLog.Rss.CustomFeeds string - 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 WHERE id = @id" - cmd.Parameters["@id"].Value <- string 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, podcast - ) VALUES ( - @id, @webLogId, @source, @path, @podcast - )" - cmd.Parameters.Clear () - addCustomFeedParameters cmd webLog.Id it - do! write cmd - }) - |> Task.WhenAll - |> ignore - toUpdate - |> List.map (fun it -> backgroundTask { - cmd.CommandText <- - "UPDATE web_log_feed - SET source = @source, - path = @path, - podcast = @podcast - WHERE id = @id - AND web_log_id = @webLogId" - cmd.Parameters.Clear () - addCustomFeedParameters cmd webLog.Id it - do! write cmd - }) - |> Task.WhenAll - |> ignore - } - - // IMPLEMENTATION FUNCTIONS +type SQLiteWebLogData(conn: SqliteConnection, ser: JsonSerializer, 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, - redirect_rules - ) VALUES ( - @id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx, - @uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright, - @redirectRules - )" - addWebLogParameters cmd webLog - do! write cmd - do! updateCustomFeeds webLog - } + let add webLog = + log.LogTrace "WebLog.add" + Document.insert conn ser 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 ser) rdr - |> List.map (fun webLog -> backgroundTask { return! appendCustomFeeds webLog }) - |> Task.WhenAll - return List.ofArray webLogs - } + let all () = + log.LogTrace "WebLog.all" + use cmd = conn.CreateCommand() + cmd.CommandText <- Query.selectFromTable Table.WebLog + cmdToList cmd ser /// 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" + log.LogTrace "WebLog.delete" + let idField = "data ->> 'WebLogId'" + let subQuery table = $"(SELECT data ->> 'Id' FROM {table} WHERE {idField} = @webLogId)" + use cmd = conn.CreateCommand() 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_tag WHERE post_id IN {postSubQuery}; - DELETE FROM post_category 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 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 WHERE web_log_id = @webLogId; - DELETE FROM web_log WHERE id = @webLogId" + 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 {idField} = @webLogId; + DELETE FROM {Table.Page} WHERE {idField} = @webLogId; + DELETE FROM {Table.Category} WHERE {idField} = @webLogId; + DELETE FROM {Table.TagMap} WHERE {idField} = @webLogId; + DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId; + DELETE FROM {Table.WebLogUser} WHERE {idField} = @webLogId; + DELETE FROM {Table.WebLog} WHERE id = @webLogId" + addWebLogId cmd webLogId do! write cmd } /// 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 ser rdr) - return Some webLog - else - return None + let findByHost (url: string) = backgroundTask { + log.LogTrace "WebLog.findByHost" + use cmd = conn.CreateCommand() + cmd.CommandText <- + $"{Query.selectFromTable Table.WebLog} WHERE data ->> '{nameof WebLog.Empty.UrlBase}' = @urlBase" + addParam cmd "@urlBase" url + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.fromDoc ser rdr) else None } /// 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 ser rdr) - return Some webLog - else - return None - } + let findById webLogId = + log.LogTrace "WebLog.findById" + Document.findById conn ser Table.WebLog webLogId /// Update redirect rules for a web log - let updateRedirectRules webLog = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "UPDATE web_log SET redirect_rules = @redirectRules WHERE id = @id" - cmd.Parameters.AddWithValue ("@redirectRules", Utils.serialize ser webLog.RedirectRules) |> ignore - cmd.Parameters.AddWithValue ("@id", string webLog.Id) |> ignore - do! write cmd - } + let updateRedirectRules (webLog: WebLog) = + log.LogTrace "WebLog.updateRedirectRules" + Document.updateField conn ser Table.WebLog webLog.Id (nameof WebLog.Empty.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 - cmd.Parameters.AddWithValue ("@id", string webLog.Id) |> ignore - do! write cmd - do! updateCustomFeeds webLog - } + let updateRssOptions (webLog: WebLog) = + log.LogTrace "WebLog.updateRssOptions" + Document.updateField conn ser Table.WebLog webLog.Id (nameof WebLog.Empty.Rss) webLog.Rss /// 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, - redirect_rules = @redirectRules - WHERE id = @id" - addWebLogParameters cmd webLog - do! write cmd - } + let updateSettings (webLog: WebLog) = + log.LogTrace "WebLog.updateSettings" + Document.update conn ser Table.WebLog webLog.Id webLog interface IWebLogData with member _.Add webLog = add webLog diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 7c0f242..f37de25 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -1,11 +1,13 @@ namespace MyWebLog.Data.SQLite open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data +open Newtonsoft.Json /// SQLite myWebLog user data implementation -type SQLiteWebLogUserData(conn: SqliteConnection) = +type SQLiteWebLogUserData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = // SUPPORT FUNCTIONS @@ -27,119 +29,94 @@ type SQLiteWebLogUserData(conn: SqliteConnection) = // IMPLEMENTATION FUNCTIONS /// 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, url, access_level, - created_on, last_seen_on - ) VALUES ( - @id, @webLogId, @email, @firstName, @lastName, @preferredName, @passwordHash, @url, @accessLevel, - @createdOn, @lastSeenOn - )" - addWebLogUserParameters cmd user - do! write cmd - } + let add user = + log.LogTrace "WebLogUser.add" + Document.insert conn ser Table.WebLogUser user /// Find a user by their ID for the given web log - let findById (userId: WebLogUserId) webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", string userId) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return verifyWebLog webLogId (_.WebLogId) Map.toWebLogUser rdr - } + let findById userId webLogId = + log.LogTrace "WebLogUser.findById" + Document.findByIdAndWebLog conn ser 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 _ -> - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT COUNT(id) FROM page WHERE author_id = @userId" - cmd.Parameters.AddWithValue ("@userId", string userId) |> ignore + use cmd = conn.CreateCommand() + cmd.CommandText <- $"SELECT COUNT(*) FROM {Table.Page} WHERE data ->> 'AuthorId' = @id" + addDocId cmd userId let! pageCount = count cmd - cmd.CommandText <- "SELECT COUNT(id) FROM post WHERE author_id = @userId" + cmd.CommandText <- cmd.CommandText.Replace($"FROM {Table.Page}", $"FROM {Table.Post}") let! postCount = count cmd 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! Document.delete conn 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" + let findByEmail (email: string) webLogId = backgroundTask { + log.LogTrace "WebLogUser.findByEmail" + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + {Query.selectFromTable Table.WebLogUser} + WHERE {Query.whereByWebLog} + AND data ->> '{nameof WebLogUser.Empty.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 + addParam cmd "@email" email + use! rdr = cmd.ExecuteReaderAsync() + let! isFound = rdr.ReadAsync() + return if isFound then Some (Map.fromDoc ser rdr) else None } /// 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 conn ser Table.WebLogUser webLogId + return users |> List.sortBy _.PreferredName.ToLowerInvariant() } /// Find the names of users by their IDs for the given web log let findNames webLogId (userIds: WebLogUserId list) = backgroundTask { - use cmd = conn.CreateCommand () - let nameSql, nameParams = inClause "AND id" "id" string userIds - cmd.CommandText <- $"SELECT * FROM web_log_user WHERE web_log_id = @webLogId {nameSql}" + log.LogTrace "WebLogUser.findNames" + use cmd = conn.CreateCommand() + let nameSql, nameParams = inClause "AND data ->> 'Id'" "id" string userIds + cmd.CommandText <- $"{Query.selectFromTable Table.WebLogUser} WHERE {Query.whereByWebLog} {nameSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange nameParams - use! rdr = cmd.ExecuteReaderAsync () - return toList Map.toWebLogUser rdr |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) + let! users = cmdToList cmd ser + return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) } /// Restore users from a backup let restore users = backgroundTask { + 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: WebLogUserId) 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" + log.LogTrace "WebLogUser.setLastSeen" + use cmd = conn.CreateCommand() + cmd.CommandText <- $" + UPDATE {Table.WebLogUser} + SET data = json_set(data, '$.{nameof WebLogUser.Empty.LastSeenOn}', @lastSeenOn) + WHERE {Query.whereById} + AND {Query.whereByWebLog}" + addDocId cmd userId addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@id", string userId) - cmd.Parameters.AddWithValue ("@lastSeenOn", instantParam (Noda.now ())) - ] |> ignore - let! _ = cmd.ExecuteNonQueryAsync () - () + addParam cmd "@lastSeenOn" (instantParam (Noda.now ())) + do! write cmd } /// 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, - 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" + Document.update conn ser Table.WebLogUser user.Id user interface IWebLogUserData with member _.Add user = add user diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index af84359..7bb2616 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -474,11 +474,11 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria member _.Page = SQLitePageData (conn, ser, log) member _.Post = SQLitePostData (conn, ser, log) member _.TagMap = SQLiteTagMapData (conn, ser, log) - member _.Theme = SQLiteThemeData conn - member _.ThemeAsset = SQLiteThemeAssetData conn - member _.Upload = SQLiteUploadData conn - member _.WebLog = SQLiteWebLogData (conn, ser) - member _.WebLogUser = SQLiteWebLogUserData conn + member _.Theme = SQLiteThemeData (conn, ser, log) + member _.ThemeAsset = SQLiteThemeAssetData (conn, log) + member _.Upload = SQLiteUploadData (conn, log) + member _.WebLog = SQLiteWebLogData (conn, ser, log) + member _.WebLogUser = SQLiteWebLogUserData (conn, ser, log) member _.Serializer = ser -- 2.45.1 From d330c97d9f58d9b3e374ce98bea45d9cb853929d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 19 Dec 2023 09:23:34 -0500 Subject: [PATCH 024/123] WIP on SQLite doc library --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 4 + src/MyWebLog.Data/SQLiteData.fs | 201 +++++++++++-------------- src/MyWebLog/Program.fs | 23 +-- 3 files changed, 108 insertions(+), 120 deletions(-) diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 442d62f..ee61d16 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -4,6 +4,10 @@ + + + + diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 7bb2616..ec631bb 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -1,5 +1,7 @@ namespace MyWebLog.Data +open System.Threading.Tasks +open BitBadger.Sqlite.FSharp.Documents open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -12,108 +14,98 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria let ensureTables () = backgroundTask { - use cmd = conn.CreateCommand() - - let! tables = backgroundTask { - cmd.CommandText <- "SELECT name FROM sqlite_master WHERE type = 'table'" - let! rdr = cmd.ExecuteReaderAsync() - let mutable tableList = [] - while! rdr.ReadAsync() do - tableList <- Map.getString "name" rdr :: tableList - do! rdr.CloseAsync() - return tableList - } + let! tables = Custom.list "SELECT name FROM sqlite_master WHERE type = 'table'" None _.GetString(0) let needsTable table = not (List.contains table tables) let jsonTable table = - $"CREATE TABLE {table} (data TEXT NOT NULL); - CREATE UNIQUE INDEX idx_{table}_key ON {table} ((data ->> 'Id'))" + $"{Definition.createTable table}; {Definition.createKey table}" - 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}; - CREATE INDEX idx_{Table.Category}_web_log ON {Table.Category} ((data ->> 'WebLogId'))" - - // Web log user table - if needsTable Table.WebLogUser then - $"{jsonTable Table.WebLogUser}; - CREATE INDEX idx_{Table.WebLogUser}_email - ON {Table.WebLogUser} ((data ->> 'WebLogId'), (data ->> 'Email'))" - - // Page tables - if needsTable Table.Page then - $"{jsonTable Table.Page}; - CREATE INDEX idx_{Table.Page}_author ON {Table.Page} ((data ->> 'AuthorId')); - CREATE INDEX idx_{Table.Page}_permalink - ON {Table.Page} ((data ->> 'WebLogId'), (data ->> 'Permalink'))" - if needsTable Table.PageRevision then - "CREATE TABLE page_revision ( - 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}; - CREATE INDEX idx_{Table.Post}_author ON {Table.Post} ((data ->> 'AuthorId')); - CREATE INDEX idx_{Table.Post}_status - ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Status'), (data ->> 'UpdatedOn')); - CREATE INDEX idx_{Table.Post}_permalink - ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Permalink'))" - // 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}; - CREATE INDEX idx_{Table.PostComment}_post ON {Table.PostComment} ((data ->> 'PostId'))" - - // Tag map table - if needsTable Table.TagMap then - $"{jsonTable Table.TagMap}; - CREATE INDEX idx_{Table.TagMap}_tag ON {Table.TagMap} ((data ->> 'WebLogId'), (data ->> '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 ('v2.1')" - } - |> Seq.map (fun sql -> - log.LogInformation $"Creating {(sql.Split ' ')[2]} table..." - cmd.CommandText <- sql - write cmd |> Async.AwaitTask |> Async.RunSynchronously) - |> List.ofSeq - |> ignore + 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}; + CREATE INDEX idx_{Table.Category}_web_log ON {Table.Category} ((data ->> 'WebLogId'))" + + // Web log user table + if needsTable Table.WebLogUser then + $"{jsonTable Table.WebLogUser}; + CREATE INDEX idx_{Table.WebLogUser}_email + ON {Table.WebLogUser} ((data ->> 'WebLogId'), (data ->> 'Email'))" + + // Page tables + if needsTable Table.Page then + $"{jsonTable Table.Page}; + CREATE INDEX idx_{Table.Page}_author ON {Table.Page} ((data ->> 'AuthorId')); + CREATE INDEX idx_{Table.Page}_permalink + ON {Table.Page} ((data ->> 'WebLogId'), (data ->> '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}; + CREATE INDEX idx_{Table.Post}_author ON {Table.Post} ((data ->> 'AuthorId')); + CREATE INDEX idx_{Table.Post}_status + ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Status'), (data ->> 'UpdatedOn')); + CREATE INDEX idx_{Table.Post}_permalink + ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Permalink'))" + // 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}; + CREATE INDEX idx_{Table.PostComment}_post ON {Table.PostComment} ((data ->> 'PostId'))" + + // Tag map table + if needsTable Table.TagMap then + $"{jsonTable Table.TagMap}; + CREATE INDEX idx_{Table.TagMap}_tag ON {Table.TagMap} ((data ->> 'WebLogId'), (data ->> '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 ('v2.1')" + } + |> Seq.map (fun sql -> + log.LogInformation $"""Creating {(sql.Replace("IF NOT EXISTS ", "").Split ' ')[2]} table...""" + Custom.nonQuery sql None) + + let! _ = Task.WhenAll tasks + () } /// Set the database version to the specified version @@ -459,15 +451,6 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria /// 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, ser, log) @@ -484,10 +467,6 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria member _.StartUp () = backgroundTask { do! ensureTables () - - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT id FROM {Table.DbVersion}" - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - do! migrate (if isFound then Some (Map.getString "id" rdr) else None) + let! version = Custom.single $"SELECT id FROM {Table.DbVersion}" None _.GetString(0) + do! migrate version } diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index c86cf62..5de9065 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -50,25 +50,30 @@ type RedirectRuleMiddleware(next: RequestDelegate, log: ILogger it.AddConsole () |> ignore)) - (builder.Build >> Configuration.useDataSource) () + (builder.Build >> Postgres.Configuration.useDataSource) () /// Get the configured data implementation let get (sp: IServiceProvider) : IData = @@ -77,10 +82,10 @@ module DataImplementation = let connStr name = config.GetConnectionString name let hasConnStr name = (connStr >> isNull >> not) name let createSQLite connStr : IData = + Sqlite.Configuration.useConnectionString connStr let log = sp.GetRequiredService>() let conn = new SqliteConnection(connStr) log.LogInformation $"Using SQLite database {conn.DataSource}" - await (SQLiteData.setUpConnection conn) SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault())) if hasConnStr "SQLite" then @@ -93,7 +98,7 @@ module DataImplementation = RethinkDbData(conn, rethinkCfg, log) elif hasConnStr "PostgreSQL" then createNpgsqlDataSource config - use conn = Configuration.dataSource().CreateConnection() + use conn = Postgres.Configuration.dataSource().CreateConnection() let log = sp.GetRequiredService>() log.LogInformation $"Using PostgreSQL database {conn.Database}" PostgresData(log, Json.configure (JsonSerializer.CreateDefault())) @@ -170,13 +175,13 @@ let main args = opts.TableName <- "Session" opts.Connection <- rethink.Conn) () - | :? SQLiteData as sql -> + | :? SQLiteData -> // ADO.NET connections are designed to work as per-request instantiation let cfg = sp.GetRequiredService() let _ = builder.Services.AddScoped(fun sp -> - let conn = new SqliteConnection(sql.Conn.ConnectionString) - SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously + let conn = Sqlite.Configuration.dbConn () + conn.OpenAsync() |> Async.AwaitTask |> Async.RunSynchronously conn) let _ = builder.Services.AddScoped() // Use SQLite for caching as well @@ -185,7 +190,7 @@ let main args = () | :? PostgresData as postgres -> // ADO.NET Data Sources are designed to work as singletons - let _ = builder.Services.AddSingleton(Configuration.dataSource ()) + let _ = builder.Services.AddSingleton(Postgres.Configuration.dataSource ()) let _ = builder.Services.AddSingleton postgres let _ = builder.Services.AddSingleton(fun _ -> -- 2.45.1 From bb4252f3c188e1273b6143a6dba3699a01b9dd81 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 19 Dec 2023 18:30:34 -0500 Subject: [PATCH 025/123] WIP on SQLite doc library --- src/MyWebLog.Data/SQLite/Helpers.fs | 135 +++++------ .../SQLite/SQLiteCategoryData.fs | 125 ++++------ src/MyWebLog.Data/SQLite/SQLitePageData.fs | 167 ++++++------- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 226 ++++++++---------- src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs | 6 +- src/MyWebLog.Data/SQLite/SQLiteThemeData.fs | 4 +- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 4 +- .../SQLite/SQLiteWebLogUserData.fs | 10 +- src/MyWebLog.Data/SQLiteData.fs | 22 +- 9 files changed, 303 insertions(+), 396 deletions(-) diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index e5357bd..7ee8090 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -76,13 +76,6 @@ 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() @@ -90,7 +83,7 @@ let write (cmd: SqliteCommand) = backgroundTask { } /// 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 +let maybe<'T> (it: 'T option) : obj = match it with Some x -> x :> obj | None -> DBNull.Value /// Create a value for a Duration let durationParam = @@ -261,7 +254,8 @@ let cmdToList<'TDoc> (cmd: SqliteCommand) ser = backgroundTask { } /// Queries to assist with document manipulation -module Query = +[] +module QueryOld = /// Fragment to add an ID condition to a WHERE clause (parameter @id) let whereById = @@ -292,6 +286,14 @@ module Query = $"DELETE FROM %s{table} WHERE {whereById}" +/// Create a document ID parameter +let idParam (key: 'TKey) = + SqliteParameter("@id", string key) + +/// Create a web log ID parameter +let webLogParam (webLogId: WebLogId) = + SqliteParameter("@webLogId", string webLogId) + let addParam (cmd: SqliteCommand) name (value: obj) = cmd.Parameters.AddWithValue(name, value) |> ignore @@ -307,18 +309,39 @@ let addDocParam<'TDoc> (cmd: SqliteCommand) (doc: 'TDoc) ser = let addWebLogId (cmd: SqliteCommand) (webLogId: WebLogId) = addParam cmd "@webLogId" (string webLogId) +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.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.whereFieldEquals "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.byFieldEquals 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 (conn: SqliteConnection) table webLogId = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- Query.countByWebLog table - addWebLogId cmd webLogId - return! count cmd + let countByWebLog table (webLogId: WebLogId) conn = backgroundTask { + let! count = Count.byFieldEquals table "WebLogId" webLogId conn + return int count } /// Find a document by its ID + [] let findById<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) = backgroundTask { use cmd = conn.CreateCommand() cmd.CommandText <- $"{Query.selectFromTable table} WHERE {Query.whereById}" @@ -329,55 +352,49 @@ module Document = } /// Find a document by its ID and web log ID - let findByIdAndWebLog<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) webLogId = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.selectFromTable table} WHERE {Query.whereById} AND {Query.whereByWebLog}" - addDocId cmd key - addWebLogId cmd webLogId - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.fromDoc<'TDoc> ser rdr) else None - } + 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> (conn: SqliteConnection) ser table webLogId = - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.selectFromTable table} WHERE {Query.whereByWebLog}" - addWebLogId cmd webLogId - cmdToList<'TDoc> cmd ser + let findByWebLog<'TDoc> table (webLogId: WebLogId) conn = + Find.byFieldEquals<'TDoc> table "WebLogId" webLogId conn /// Insert a document + [] let insert<'TDoc> (conn: SqliteConnection) ser table (doc: 'TDoc) = backgroundTask { use cmd = conn.CreateCommand() - cmd.CommandText <- Query.insert table + cmd.CommandText <- QueryOld.insert table addDocParam<'TDoc> cmd doc ser do! write cmd } /// Update (replace) a document by its ID + [] let update<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) (doc: 'TDoc) = backgroundTask { use cmd = conn.CreateCommand() - cmd.CommandText <- Query.updateById table + cmd.CommandText <- QueryOld.updateById table addDocId cmd key addDocParam<'TDoc> cmd doc ser do! write cmd } /// Update a field in a document by its ID + [] let updateField<'TKey, 'TValue> (conn: SqliteConnection) ser table (key: 'TKey) jsonField (value: 'TValue) = backgroundTask { use cmd = conn.CreateCommand() cmd.CommandText <- - $"UPDATE %s{table} SET data = json_set(data, '$.{jsonField}', json(@it)) WHERE {Query.whereById}" + $"UPDATE %s{table} SET data = json_set(data, '$.{jsonField}', json(@it)) WHERE {QueryOld.whereById}" addDocId cmd key addParam cmd "@it" (Utils.serialize ser value) do! write cmd } /// Delete a document by its ID + [] let delete<'TKey> (conn: SqliteConnection) table (key: 'TKey) = backgroundTask { use cmd = conn.CreateCommand() - cmd.CommandText <- Query.deleteById table + cmd.CommandText <- QueryOld.deleteById table addDocId cmd key do! write cmd } @@ -386,29 +403,24 @@ module Document = module Revisions = /// Find all revisions for the given entity - let findByEntityId<'TKey> (conn: SqliteConnection) revTable entityTable (key: 'TKey) = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- + 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" - addDocId cmd key - use! rdr = cmd.ExecuteReaderAsync() - return toList Map.toRevision rdr - } + [ idParam key ] + Map.toRevision + conn /// Find all revisions for all posts for the given web log - let findByWebLog<'TKey> (conn: SqliteConnection) revTable entityTable (keyFunc: string -> 'TKey) - webLogId = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- + 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.{Query.whereByWebLog} + WHERE p.{Document.Query.whereByWebLog} ORDER BY as_of DESC" - addWebLogId cmd webLogId - use! rdr = cmd.ExecuteReaderAsync() - return toList (fun rdr -> keyFunc (Map.getString $"{entityTable}_id" rdr), Map.toRevision rdr) rdr - } + [ webLogParam webLogId ] + (fun rdr -> keyFunc (Map.getString $"{entityTable}_id" rdr), Map.toRevision rdr) + conn /// Parameters for a revision INSERT statement let revParams<'TKey> (key: 'TKey) rev = @@ -416,26 +428,15 @@ module Revisions = SqliteParameter("@id", string key) SqliteParameter("@text", rev.Text) ] - /// The SQL statement to insert a revision - let insertSql table = - $"INSERT INTO %s{table} VALUES (@id, @asOf, @text)" - /// Update a page or post's revisions - let update<'TKey> (conn: SqliteConnection) revTable entityTable (key: 'TKey) oldRevs newRevs = backgroundTask { + let update<'TKey> revTable entityTable (key: 'TKey) oldRevs newRevs conn = backgroundTask { let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs if not (List.isEmpty toDelete) || not (List.isEmpty toAdd) then - use cmd = conn.CreateCommand() - if not (List.isEmpty toDelete) then - cmd.CommandText <- $"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf" - for delRev in toDelete do - cmd.Parameters.Clear() - addDocId cmd key - addParam cmd "@asOf" delRev.AsOf - do! write cmd - if not (List.isEmpty toAdd) then - cmd.CommandText <- insertSql revTable - for addRev in toAdd do - cmd.Parameters.Clear() - cmd.Parameters.AddRange(revParams key addRev) - do! write cmd + for delRev in toDelete do + do! Custom.nonQuery + $"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf" + [ idParam key; SqliteParameter("@asOf", instantParam delRev.AsOf) ] + conn + for addRev in toAdd do + do! Custom.nonQuery $"INSERT INTO {revTable} VALUES (@id, @asOf, @text)" (revParams key addRev) conn } diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 3e892c2..33bf01b 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -1,6 +1,8 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -13,29 +15,24 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge /// The name of the parent ID field let parentIdField = nameof Category.Empty.ParentId - /// Add a category - let add (cat: Category) = - log.LogTrace "Category.add" - Document.insert conn ser Table.Category cat - /// Count all categories for the given web log let countAll webLogId = log.LogTrace "Category.countAll" - Document.countByWebLog conn Table.Category webLogId + Document.countByWebLog Table.Category webLogId conn /// Count all top-level categories for the given web log - let countTopLevel webLogId = backgroundTask { + let countTopLevel webLogId = log.LogTrace "Category.countTopLevel" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.countByWebLog} AND data ->> '{parentIdField}' IS NULL" - addWebLogId cmd webLogId - return! count cmd - } + Custom.scalar + $"{Document.Query.countByWebLog} AND data ->> '{parentIdField}' IS NULL" + [ webLogParam webLogId ] + (fun rdr -> int (rdr.GetInt64(0))) + conn /// Find all categories for the given web log let findByWebLog webLogId = log.LogTrace "Category.findByWebLog" - Document.findByWebLog conn ser Table.Category webLogId + Document.findByWebLog Table.Category webLogId conn /// Retrieve all categories for the given web log in a DotLiquid-friendly format let findAllForView webLogId = backgroundTask { @@ -53,104 +50,74 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge |> Seq.append (Seq.singleton it.Id) |> List.ofSeq |> inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" + let query = $""" SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') FROM {Table.Post} - WHERE {Query.whereByWebLog} - AND data ->> '{nameof Post.Empty.Status}' = '{string Published}' - AND {catSql}" - addWebLogId cmd webLogId - cmd.Parameters.AddRange catParams - let! postCount = count cmd - return it.Id, postCount + WHERE {Document.Query.whereByWebLog} + AND {Query.whereFieldEquals (nameof Post.Empty.Status) $"'{string Published}'"} + AND {catSql}""" + let! postCount = Custom.scalar query (webLogParam webLogId :: catParams) (_.GetInt64(0)) conn + 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 = log.LogTrace "Category.findById" - Document.findByIdAndWebLog conn ser Table.Category catId webLogId + Document.findByIdAndWebLog Table.Category catId webLogId conn /// Delete a category let delete catId webLogId = backgroundTask { log.LogTrace "Category.delete" match! findById catId webLogId with | Some cat -> - use cmd = conn.CreateCommand() // Reassign any children to the category's parent category - cmd.CommandText <- $"SELECT COUNT(*) FROM {Table.Category} WHERE data ->> '{parentIdField}' = @parentId" - addParam cmd "@parentId" (string catId) - let! children = count cmd + let! children = Count.byFieldEquals Table.Category parentIdField catId conn if children > 0 then - cmd.CommandText <- $" - UPDATE {Table.Category} - SET data = json_set(data, '$.{parentIdField}', @newParentId) - WHERE data ->> '{parentIdField}' = @parentId" - addParam cmd "@newParentId" (maybe (cat.ParentId |> Option.map string)) - do! write cmd + do! Update.partialByFieldEquals Table.Category parentIdField catId {| ParentId = cat.ParentId |} conn // Delete the category off all posts where it is assigned, and the category itself let catIdField = Post.Empty.CategoryIds - cmd.CommandText <- $" - SELECT data ->> '{Post.Empty.Id}' AS id, data -> '{catIdField}' AS cat_ids - FROM {Table.Post} - WHERE {Query.whereByWebLog} - AND EXISTS - (SELECT 1 FROM json_each({Table.Post}.data -> '{catIdField}') WHERE json_each.value = @id)" - cmd.Parameters.Clear() - addDocId cmd catId - addWebLogId cmd webLogId - use! postRdr = cmd.ExecuteReaderAsync() - if postRdr.HasRows then - let postIdAndCats = - toList - (fun rdr -> - Map.getString "id" rdr, Utils.deserialize ser (Map.getString "cat_ids" rdr)) - postRdr - do! postRdr.CloseAsync() - for postId, cats in postIdAndCats do - cmd.CommandText <- $" - UPDATE {Table.Post} - SET data = json_set(data, '$.{catIdField}', json(@catIds)) - WHERE {Query.whereById}" - cmd.Parameters.Clear() - addDocId cmd postId - addParam cmd "@catIds" (cats |> List.filter (fun it -> it <> string catId) |> Utils.serialize ser) - do! write cmd + let! posts = + Custom.list + $"SELECT data ->> '{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 ser (rdr.GetString(1))) + conn + for postId, cats in posts do + do! Update.partialById + Table.Post postId {| CategoryIds = cats |> List.filter (fun it -> it <> string catId) |} conn do! Document.delete conn Table.Category catId - return if children = 0 then CategoryDeleted else ReassignedChildCategories + return if children = 0L then CategoryDeleted else ReassignedChildCategories | None -> return CategoryNotFound } + /// Save a category + let save cat = + log.LogTrace "Category.save" + save Table.Category cat conn + /// Restore categories from a backup let restore cats = backgroundTask { - for cat in cats do - do! add cat - } - - /// Update a category - let update (cat: Category) = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.updateById} AND {Query.whereByWebLog}" - addDocId cmd cat.Id - addDocParam cmd cat ser - addWebLogId cmd cat.WebLogId - 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 @@ -158,4 +125,4 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge 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 diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index a97c362..ba62ea0 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -1,20 +1,21 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open Newtonsoft.Json /// SQLite myWebLog page data implementation -type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = +type SQLitePageData(conn: SqliteConnection, log: ILogger) = - /// The JSON field for the permalink - let linkField = $"data ->> '{nameof Page.Empty.Permalink}'" + /// The JSON field name for the permalink + let linkName = nameof Page.Empty.Permalink - /// The JSON field for the "is in page list" flag - let pgListField = $"data ->> '{nameof Page.Empty.IsInPageList}'" + /// 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}'" @@ -24,57 +25,44 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = /// Append revisions to a page let appendPageRevisions (page : Page) = backgroundTask { log.LogTrace "Page.appendPageRevisions" - let! revisions = Revisions.findByEntityId conn Table.PageRevision Table.Page page.Id + let! revisions = Revisions.findByEntityId Table.PageRevision Table.Page page.Id conn return { page with Revisions = revisions } } - /// Return a page with no text - let withoutText (page: Page) = - { page with Text = "" } - /// Update a page's revisions let updatePageRevisions (pageId: PageId) oldRevs newRevs = log.LogTrace "Page.updatePageRevisions" - Revisions.update conn Table.PageRevision Table.Page pageId oldRevs newRevs + Revisions.update Table.PageRevision Table.Page pageId oldRevs newRevs conn // IMPLEMENTATION FUNCTIONS - /// Add a page - let add page = backgroundTask { - log.LogTrace "Page.add" - do! Document.insert conn ser Table.Page { page with Revisions = [] } - do! updatePageRevisions page.Id [] page.Revisions - } - /// Get all pages for a web log (without text or revisions) - let all webLogId = backgroundTask { + let all webLogId = log.LogTrace "Page.all" - use cmd = conn.CreateCommand() - cmd.CommandText <- - $"{Query.selectFromTable Table.Page} WHERE {Query.whereByWebLog} ORDER BY LOWER({titleField})" - addWebLogId cmd webLogId - let! pages = cmdToList cmd ser - return pages |> List.map withoutText - } + Custom.list + $"{Query.selectFromTable Table.Page} WHERE {Document.Query.whereByWebLog} ORDER BY LOWER({titleField})" + [ webLogParam webLogId ] + (fun rdr -> { fromData rdr with Text = "" }) + conn /// Count all pages for the given web log let countAll webLogId = log.LogTrace "Page.countAll" - Document.countByWebLog conn Table.Page webLogId + Document.countByWebLog Table.Page webLogId conn /// Count all pages shown in the page list for the given web log - let countListed webLogId = backgroundTask { + let countListed webLogId = log.LogTrace "Page.countListed" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.countByWebLog} AND {pgListField} = 'true'" - addWebLogId cmd webLogId - return! count cmd - } + Custom.scalar + $"""{Document.Query.countByWebLog} AND {Query.whereFieldEquals pgListName "'true'"}""" + [ webLogParam webLogId ] + (fun rdr -> int (rdr.GetInt64(0))) + conn /// Find a page by its ID (without revisions) let findById pageId webLogId = log.LogTrace "Page.findById" - Document.findByIdAndWebLog conn ser Table.Page pageId webLogId + Document.findByIdAndWebLog Table.Page pageId webLogId conn /// Find a complete page by its ID let findFullById pageId webLogId = backgroundTask { @@ -92,93 +80,74 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = log.LogTrace "Page.delete" match! findById pageId webLogId with | Some _ -> - use cmd = conn.CreateCommand() - cmd.CommandText <- $"DELETE FROM {Table.PageRevision} WHERE page_id = @id; {Query.deleteById}" - addDocId cmd pageId - do! write cmd + do! Custom.nonQuery + $"DELETE FROM {Table.PageRevision} WHERE page_id = @id; {Query.Delete.byId Table.Page}" + [ idParam pageId ] + conn return true | None -> return false } /// Find a page by its permalink for the given web log - let findByPermalink (permalink: Permalink) webLogId = backgroundTask { + let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Page.findByPermalink" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" {Query.selectFromTable Table.Page} WHERE {Query.whereByWebLog} AND {linkField} = @link" - addWebLogId cmd webLogId - addParam cmd "@link" (string permalink) - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.fromDoc ser rdr) else None - } + Custom.single + $"""{Document.Query.selectByWebLog} AND {Query.whereFieldEquals linkName "@link"}""" + [ webLogParam webLogId; SqliteParameter("@link", string permalink) ] + fromData + conn /// Find the current permalink within a set of potential prior permalinks for the given web log - let findCurrentPermalink (permalinks: Permalink list) webLogId = backgroundTask { + let findCurrentPermalink (permalinks: Permalink list) webLogId = log.LogTrace "Page.findCurrentPermalink" let linkSql, linkParams = inJsonArray Table.Page (nameof Page.Empty.PriorPermalinks) "link" permalinks - use cmd = conn.CreateCommand() - cmd.CommandText <- - $"SELECT {linkField} AS permalink FROM {Table.Page} WHERE {Query.whereByWebLog} AND {linkSql}" - addWebLogId cmd webLogId - cmd.Parameters.AddRange linkParams - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.toPermalink rdr) else None - } + Custom.single + $"SELECT data ->> '{linkName}' AS permalink + FROM {Table.Page} + WHERE {Document.Query.whereByWebLog} AND {linkSql}" + (webLogParam webLogId :: linkParams) + Map.toPermalink + conn /// Get all complete pages for the given web log let findFullByWebLog webLogId = backgroundTask { log.LogTrace "Page.findFullByWebLog" - let! pages = Document.findByWebLog conn ser Table.Page webLogId - let! withRevs = - pages - |> List.map (fun page -> backgroundTask { return! appendPageRevisions page }) - |> Task.WhenAll + let! pages = Document.findByWebLog 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 or text) - let findListed webLogId = backgroundTask { + let findListed webLogId = log.LogTrace "Page.findListed" - use cmd = conn.CreateCommand () - cmd.CommandText <- $" - {Query.selectFromTable Table.Page} - WHERE {Query.whereByWebLog} - AND {pgListField} = 'true' - ORDER BY LOWER({titleField})" - addWebLogId cmd webLogId - let! pages = cmdToList cmd ser - return pages |> List.map withoutText - } + Custom.list + $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereFieldEquals pgListName "'true'"} + ORDER BY LOWER({titleField})""" + [ webLogParam webLogId ] + (fun rdr -> { fromData rdr with Text = "" }) + conn /// Get a page of pages for the given web log (without revisions) let findPageOfPages webLogId pageNbr = log.LogTrace "Page.findPageOfPages" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - {Query.selectFromTable Table.Page} WHERE {Query.whereByWebLog} - ORDER BY LOWER({titleField}) - LIMIT @pageSize OFFSET @toSkip" - addWebLogId cmd webLogId - addParam cmd "@pageSize" 26 - addParam cmd "@toSkip" ((pageNbr - 1) * 25) - cmdToList cmd ser + Custom.list + $"{Document.Query.selectByWebLog Table.Page} ORDER BY LOWER({titleField}) LIMIT @pageSize OFFSET @toSkip" + [ webLogParam webLogId; SqliteParameter("@pageSize", 26); SqliteParameter("@toSkip", (pageNbr - 1) * 25) ] + fromData + conn + + /// Save a page + let save (page: Page) = backgroundTask { + log.LogTrace "Page.update" + let! oldPage = findFullById page.Id page.WebLogId + do! save Table.Page { page with Revisions = [] } conn + do! updatePageRevisions page.Id (match oldPage with Some p -> p.Revisions | None -> []) page.Revisions + } /// Restore pages from a backup let restore pages = backgroundTask { log.LogTrace "Page.restore" - for page in pages do - do! add page - } - - /// Update a page - let update (page: Page) = backgroundTask { - log.LogTrace "Page.update" - match! findFullById page.Id page.WebLogId with - | Some oldPage -> - do! Document.update conn ser Table.Page page.Id { page with Revisions = [] } - do! updatePageRevisions page.Id oldPage.Revisions page.Revisions - | None -> () + for page in pages do do! save page } /// Update a page's prior permalinks @@ -186,13 +155,13 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = log.LogTrace "Page.updatePriorPermalinks" match! findById pageId webLogId with | Some _ -> - do! Document.updateField conn ser Table.Page pageId (nameof Page.Empty.PriorPermalinks) permalinks + do! Update.partialById Table.Page pageId {| PriorPermalinks = permalinks |} conn return true - | None -> return false + | None -> return false } interface IPageData with - member _.Add page = add page + member _.Add page = save page member _.All webLogId = all webLogId member _.CountAll webLogId = countAll webLogId member _.CountListed webLogId = countListed webLogId @@ -205,5 +174,5 @@ type SQLitePageData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = member _.FindListed webLogId = findListed webLogId member _.FindPageOfPages webLogId pageNbr = findPageOfPages webLogId pageNbr member _.Restore pages = restore pages - member _.Update page = update page + member _.Update page = save page member _.UpdatePriorPermalinks pageId webLogId permalinks = updatePriorPermalinks pageId webLogId permalinks diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index b6f82a7..0792fdf 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -1,84 +1,70 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open Newtonsoft.Json open NodaTime /// SQLite myWebLog post data implementation -type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = +type SQLitePostData(conn: SqliteConnection, log: ILogger) = - /// The JSON field for the post's permalink - let linkField = $"data ->> '{nameof Post.Empty.Permalink}'" + /// 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 JSON field for post status - let statField = $"data ->> '{nameof Post.Empty.Status}'" + /// The name of the JSON field for the post's status + let statName = nameof Post.Empty.Status // SUPPORT FUNCTIONS /// Append revisions to a post let appendPostRevisions (post: Post) = backgroundTask { log.LogTrace "Post.appendPostRevisions" - let! revisions = Revisions.findByEntityId conn Table.PostRevision Table.Post post.Id + let! revisions = Revisions.findByEntityId Table.PostRevision Table.Post post.Id conn return { post with Revisions = revisions } } /// The SELECT statement to retrieve posts with a web log ID parameter - let postByWebLog = $"{Query.selectFromTable Table.Post} WHERE {Query.whereByWebLog}" + let postByWebLog = Document.Query.selectByWebLog Table.Post /// The SELECT statement to retrieve published posts with a web log ID parameter - let publishedPostByWebLog = $"{postByWebLog} AND {statField} = '{string Published}'" - - /// Remove the text from a post - let withoutText (post: Post) = - { post with Text = "" } + let publishedPostByWebLog = $"""{postByWebLog} AND {Query.whereFieldEquals statName $"'{string Published}'"}""" /// Update a post's revisions let updatePostRevisions (postId: PostId) oldRevs newRevs = log.LogTrace "Post.updatePostRevisions" - Revisions.update conn Table.PostRevision Table.Post postId oldRevs newRevs + Revisions.update Table.PostRevision Table.Post postId oldRevs newRevs conn // IMPLEMENTATION FUNCTIONS - /// Add a post - let add (post: Post) = backgroundTask { - log.LogTrace "Post.add" - do! Document.insert conn ser 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 = backgroundTask { + let countByStatus (status: PostStatus) webLogId = log.LogTrace "Post.countByStatus" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.countByWebLog Table.Post} AND {statField} = @status" - addWebLogId cmd webLogId - addParam cmd "@status" (string status) - return! count cmd - } + Custom.scalar + $"""{Document.Query.countByWebLog} AND {Query.whereFieldEquals statName "@status"}""" + [ webLogParam webLogId; SqliteParameter("@status", string status) ] + (fun rdr -> int (rdr.GetInt64(0))) + conn - /// 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 = log.LogTrace "Post.findById" - Document.findByIdAndWebLog conn ser Table.Post postId webLogId + Document.findByIdAndWebLog Table.Post postId webLogId conn - /// Find a post by its permalink for the given web log (excluding revisions and prior permalinks) - let findByPermalink (permalink: Permalink) webLogId = backgroundTask { + /// Find a post by its permalink for the given web log (excluding revisions) + let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Post.findByPermalink" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.selectFromTable Table.Post} WHERE {Query.whereByWebLog} AND {linkField} = @link" - addWebLogId cmd webLogId - addParam cmd "@link" (string permalink) - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.fromDoc ser rdr) else None - } + Custom.single + $"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereFieldEquals linkName "@link"}""" + [ webLogParam webLogId; SqliteParameter("@link", string permalink) ] + fromData + conn /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { @@ -95,39 +81,34 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = log.LogTrace "Post.delete" match! findById postId webLogId with | Some _ -> - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - DELETE FROM {Table.PostRevision} WHERE post_id = @id; - DELETE FROM {Table.PostComment} WHERE data ->> '{nameof Comment.Empty.PostId}' = @id; - DELETE FROM {Table.Post} WHERE {Query.whereById}" - addDocId cmd postId - do! write cmd + do! Custom.nonQuery + $"""DELETE FROM {Table.PostRevision} WHERE post_id = @id; + DELETE FROM {Table.PostComment} + WHERE {Query.whereFieldEquals (nameof Comment.Empty.PostId) "@id"}; + {Query.Delete.byId Table.Post}""" + [ idParam postId ] + conn return true | None -> 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 { + let findCurrentPermalink (permalinks: Permalink list) webLogId = log.LogTrace "Post.findCurrentPermalink" let linkSql, linkParams = inJsonArray Table.Post (nameof Post.Empty.PriorPermalinks) "link" permalinks - use cmd = conn.CreateCommand() - cmd.CommandText <- - $"SELECT {linkField} AS permalink FROM {Table.Post} WHERE {Query.whereByWebLog} AND {linkSql}" - addWebLogId cmd webLogId - cmd.Parameters.AddRange linkParams - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.toPermalink rdr) else None - } + Custom.single + $"SELECT data ->> '{linkName}' + FROM {Table.Post} + WHERE {Document.Query.whereByWebLog} AND {linkSql}" + (webLogParam webLogId :: linkParams) + Map.toPermalink + conn /// Get all complete posts for the given web log let findFullByWebLog webLogId = backgroundTask { log.LogTrace "Post.findFullByWebLog" - let! posts = Document.findByWebLog conn ser Table.Post webLogId - let! withRevs = - posts - |> List.map (fun post -> backgroundTask { return! appendPostRevisions post }) - |> Task.WhenAll + let! posts = Document.findByWebLog Table.Post webLogId conn + let! withRevs = posts |> List.map appendPostRevisions |> Task.WhenAll return List.ofArray withRevs } @@ -135,102 +116,91 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = log.LogTrace "Post.findPageOfCategorizedPosts" let catSql, catParams = inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId" categoryIds - use cmd = conn.CreateCommand () - cmd.CommandText <- $" - {publishedPostByWebLog} AND {catSql} - ORDER BY {publishField} DESC - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - addWebLogId cmd webLogId - cmd.Parameters.AddRange catParams - cmdToList cmd ser + Custom.list + $"{publishedPostByWebLog} AND {catSql} + ORDER BY {publishField} DESC + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" + (webLogParam webLogId :: catParams) + fromData + conn - /// Get a page of posts for the given web log (excludes revisions) - let findPageOfPosts webLogId pageNbr postsPerPage = backgroundTask { + /// Get a page of posts for the given web log (excludes text and revisions) + let findPageOfPosts webLogId pageNbr postsPerPage = log.LogTrace "Post.findPageOfPosts" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - {postByWebLog} - ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}' - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - addWebLogId cmd webLogId - let! posts = cmdToList cmd ser - return posts |> List.map withoutText - } + Custom.list + $"{postByWebLog} + ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}' + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" + [ webLogParam webLogId ] + (fun rdr -> { fromData rdr with Text = "" }) + conn /// Get a page of published posts for the given web log (excludes revisions) let findPageOfPublishedPosts webLogId pageNbr postsPerPage = log.LogTrace "Post.findPageOfPublishedPosts" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - {publishedPostByWebLog} - ORDER BY {publishField} DESC - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - addWebLogId cmd webLogId - cmdToList cmd ser + Custom.list + $"{publishedPostByWebLog} + ORDER BY {publishField} DESC + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" + [ webLogParam webLogId ] + fromData + conn /// 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 ] - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - {publishedPostByWebLog} AND {tagSql} - ORDER BY p.published_on DESC - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - addWebLogId cmd webLogId - cmd.Parameters.AddRange tagParams - cmdToList cmd ser + Custom.list + $"{publishedPostByWebLog} AND {tagSql} + ORDER BY p.published_on DESC + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" + (webLogParam webLogId :: tagParams) + fromData + conn /// 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" - use cmd = conn.CreateCommand () - addWebLogId cmd webLogId - addParam cmd "@publishedOn" (instantParam publishedOn) - - cmd.CommandText <- - $"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1" - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - let older = if isFound then Some (Map.fromDoc ser rdr) else None - do! rdr.CloseAsync () - - cmd.CommandText <- - $"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1" - use! rdr = cmd.ExecuteReaderAsync () - let! isFound = rdr.ReadAsync() - let newer = if isFound then Some (Map.fromDoc ser rdr) else None - + let! older = + Custom.single + $"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1" + [ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ] + fromData + conn + let! newer = + Custom.single + $"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1" + [ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ] + fromData + conn return older, newer } + /// Save a post + let save (post: Post) = backgroundTask { + log.LogTrace "Post.save" + let! oldPost = findFullById post.Id post.WebLogId + do! save Table.Post { post with Revisions = [] } conn + do! updatePostRevisions post.Id (match oldPost with Some p -> p.Revisions | None -> []) post.Revisions + } + /// Restore posts from a backup let restore posts = backgroundTask { log.LogTrace "Post.restore" - for post in posts do - do! add post - } - - /// Update a post - let update (post: Post) = backgroundTask { - match! findFullById post.Id post.WebLogId with - | Some oldPost -> - do! Document.update conn ser Table.Post post.Id { post with Revisions = [] } - do! updatePostRevisions post.Id oldPost.Revisions post.Revisions - | None -> return () + for post in posts do do! save post } /// Update prior permalinks for a post let updatePriorPermalinks postId webLogId (permalinks: Permalink list) = backgroundTask { match! findById postId webLogId with | Some _ -> - do! Document.updateField conn ser Table.Post postId (nameof Post.Empty.PriorPermalinks) permalinks + do! Update.partialById Table.Post postId {| PriorPermalinks = permalinks |} conn return true - | None -> return false + | None -> return false } interface IPostData with - member _.Add post = add post + member _.Add post = save post member _.CountByStatus status webLogId = countByStatus status webLogId member _.Delete postId webLogId = delete postId webLogId member _.FindById postId webLogId = findById postId webLogId @@ -247,5 +217,5 @@ type SQLitePostData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = findPageOfTaggedPosts webLogId tag pageNbr postsPerPage member _.FindSurroundingPosts webLogId publishedOn = findSurroundingPosts webLogId publishedOn member _.Restore posts = restore posts - member _.Update post = update post + member _.Update post = save post member _.UpdatePriorPermalinks postId webLogId permalinks = updatePriorPermalinks postId webLogId permalinks diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index 64440ac..9bc3616 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -29,8 +29,8 @@ type SQLiteTagMapData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) log.LogTrace "TagMap.findByUrlValue" use cmd = conn.CreateCommand() cmd.CommandText <- $" - {Query.selectFromTable Table.TagMap} - WHERE {Query.whereByWebLog} + {QueryOld.selectFromTable Table.TagMap} + WHERE {QueryOld.whereByWebLog} AND data ->> '{nameof TagMap.Empty.UrlValue}' = @urlValue" addWebLogId cmd webLogId addParam cmd "@urlValue" urlValue @@ -49,7 +49,7 @@ type SQLiteTagMapData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) log.LogTrace "TagMap.findMappingForTags" use cmd = conn.CreateCommand () let mapSql, mapParams = inClause $"AND data ->> '{nameof TagMap.Empty.Tag}'" "tag" id tags - cmd.CommandText <- $"{Query.selectFromTable Table.TagMap} WHERE {Query.whereByWebLog} {mapSql}" + cmd.CommandText <- $"{QueryOld.selectFromTable Table.TagMap} WHERE {QueryOld.whereByWebLog} {mapSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange mapParams cmdToList cmd ser diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index 5d78177..151496e 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -20,7 +20,7 @@ type SQLiteThemeData(conn : SqliteConnection, ser: JsonSerializer, log: ILogger) let all () = backgroundTask { log.LogTrace "Theme.all" use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}" + cmd.CommandText <- $"{QueryOld.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}" let! themes = cmdToList cmd ser return themes |> List.map withoutTemplateText } @@ -55,7 +55,7 @@ type SQLiteThemeData(conn : SqliteConnection, ser: JsonSerializer, log: ILogger) use cmd = conn.CreateCommand() cmd.CommandText <- $" DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; - DELETE FROM {Table.Theme} WHERE {Query.whereById}" + DELETE FROM {Table.Theme} WHERE {QueryOld.whereById}" addDocId cmd themeId do! write cmd return true diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index ebd7925..7cec1a7 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -19,7 +19,7 @@ type SQLiteWebLogData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) let all () = log.LogTrace "WebLog.all" use cmd = conn.CreateCommand() - cmd.CommandText <- Query.selectFromTable Table.WebLog + cmd.CommandText <- QueryOld.selectFromTable Table.WebLog cmdToList cmd ser /// Delete a web log by its ID @@ -48,7 +48,7 @@ type SQLiteWebLogData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) log.LogTrace "WebLog.findByHost" use cmd = conn.CreateCommand() cmd.CommandText <- - $"{Query.selectFromTable Table.WebLog} WHERE data ->> '{nameof WebLog.Empty.UrlBase}' = @urlBase" + $"{QueryOld.selectFromTable Table.WebLog} WHERE data ->> '{nameof WebLog.Empty.UrlBase}' = @urlBase" addParam cmd "@urlBase" url use! rdr = cmd.ExecuteReaderAsync() let! isFound = rdr.ReadAsync() diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index f37de25..5029f98 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -62,8 +62,8 @@ type SQLiteWebLogUserData(conn: SqliteConnection, ser: JsonSerializer, log: ILog log.LogTrace "WebLogUser.findByEmail" use cmd = conn.CreateCommand() cmd.CommandText <- $" - {Query.selectFromTable Table.WebLogUser} - WHERE {Query.whereByWebLog} + {QueryOld.selectFromTable Table.WebLogUser} + WHERE {QueryOld.whereByWebLog} AND data ->> '{nameof WebLogUser.Empty.Email}' = @email" addWebLogId cmd webLogId addParam cmd "@email" email @@ -84,7 +84,7 @@ type SQLiteWebLogUserData(conn: SqliteConnection, ser: JsonSerializer, log: ILog log.LogTrace "WebLogUser.findNames" use cmd = conn.CreateCommand() let nameSql, nameParams = inClause "AND data ->> 'Id'" "id" string userIds - cmd.CommandText <- $"{Query.selectFromTable Table.WebLogUser} WHERE {Query.whereByWebLog} {nameSql}" + cmd.CommandText <- $"{QueryOld.selectFromTable Table.WebLogUser} WHERE {QueryOld.whereByWebLog} {nameSql}" addWebLogId cmd webLogId cmd.Parameters.AddRange nameParams let! users = cmdToList cmd ser @@ -105,8 +105,8 @@ type SQLiteWebLogUserData(conn: SqliteConnection, ser: JsonSerializer, log: ILog cmd.CommandText <- $" UPDATE {Table.WebLogUser} SET data = json_set(data, '$.{nameof WebLogUser.Empty.LastSeenOn}', @lastSeenOn) - WHERE {Query.whereById} - AND {Query.whereByWebLog}" + WHERE {QueryOld.whereById} + AND {QueryOld.whereByWebLog}" addDocId cmd userId addWebLogId cmd webLogId addParam cmd "@lastSeenOn" (instantParam (Noda.now ())) diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index ec631bb..b5a85ff 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -2,6 +2,7 @@ namespace MyWebLog.Data open System.Threading.Tasks open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -12,9 +13,10 @@ open NodaTime /// SQLite myWebLog data implementation type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSerializer) = + /// Create tables (and their associated indexes) if they do not exist let ensureTables () = backgroundTask { - let! tables = Custom.list "SELECT name FROM sqlite_master WHERE type = 'table'" None _.GetString(0) + let! tables = Custom.list "SELECT name FROM sqlite_master WHERE type = 'table'" [] (_.GetString(0)) conn let needsTable table = not (List.contains table tables) @@ -102,19 +104,16 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria } |> Seq.map (fun sql -> log.LogInformation $"""Creating {(sql.Replace("IF NOT EXISTS ", "").Split ' ')[2]} table...""" - Custom.nonQuery sql None) + Custom.nonQuery sql [] conn) let! _ = Task.WhenAll tasks () } /// Set the database version to the specified version - let setDbVersion version = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- $"DELETE FROM {Table.DbVersion}; INSERT INTO {Table.DbVersion} VALUES ('%s{version}')" - do! write cmd - } - + let setDbVersion version = + Custom.nonQuery $"DELETE FROM {Table.DbVersion}; INSERT INTO {Table.DbVersion} VALUES ('%s{version}')" [] conn + /// Implement the changes between v2-rc1 and v2-rc2 let migrateV2Rc1ToV2Rc2 () = backgroundTask { let logStep = Utils.logMigrationStep log "v2-rc1 to v2-rc2" @@ -418,6 +417,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria /// Migrate from v2 to v2.1 let migrateV2ToV2point1 () = backgroundTask { + // FIXME: This will be a backup/restore scenario, as we're changing to documents for most tables Utils.logMigrationStep log "v2 to v2.1" "Adding redirect rules to web_log table" use cmd = conn.CreateCommand() cmd.CommandText <- "ALTER TABLE web_log ADD COLUMN redirect_rules TEXT NOT NULL DEFAULT '[]'" @@ -454,8 +454,8 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria interface IData with member _.Category = SQLiteCategoryData (conn, ser, log) - member _.Page = SQLitePageData (conn, ser, log) - member _.Post = SQLitePostData (conn, ser, log) + member _.Page = SQLitePageData (conn, log) + member _.Post = SQLitePostData (conn, log) member _.TagMap = SQLiteTagMapData (conn, ser, log) member _.Theme = SQLiteThemeData (conn, ser, log) member _.ThemeAsset = SQLiteThemeAssetData (conn, log) @@ -467,6 +467,6 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria member _.StartUp () = backgroundTask { do! ensureTables () - let! version = Custom.single $"SELECT id FROM {Table.DbVersion}" None _.GetString(0) + let! version = Custom.single $"SELECT id FROM {Table.DbVersion}" [] (_.GetString(0)) conn do! migrate version } -- 2.45.1 From f461b10ebc8d49721993cbff0ae78a3015091e49 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 19 Dec 2023 21:24:13 -0500 Subject: [PATCH 026/123] First cut of SQLite doc library --- .../Postgres/PostgresTagMapData.fs | 1 + src/MyWebLog.Data/SQLite/Helpers.fs | 166 ++---------------- .../SQLite/SQLiteCategoryData.fs | 2 +- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 2 +- src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs | 50 +++--- src/MyWebLog.Data/SQLite/SQLiteThemeData.fs | 162 +++++++---------- src/MyWebLog.Data/SQLite/SQLiteUploadData.fs | 110 +++++------- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 65 +++---- .../SQLite/SQLiteWebLogUserData.fs | 110 ++++-------- src/MyWebLog.Data/SQLiteData.fs | 8 +- 10 files changed, 221 insertions(+), 455 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs index 04e33c9..1a43b74 100644 --- a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -48,6 +48,7 @@ type PostgresTagMapData(log: ILogger) = /// Save a tag mapping let save (tagMap: TagMap) = + log.LogTrace "TagMap.save" save Table.TagMap tagMap /// Restore tag mappings from a backup diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 7ee8090..cd6c2b6 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -65,17 +65,6 @@ open MyWebLog open MyWebLog.Data open NodaTime.Text -/// Run a command that returns a count -let count (cmd: SqliteCommand) = backgroundTask { - let! it = cmd.ExecuteScalarAsync() - return int (it :?> int64) -} - -/// 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 - /// Execute a command that returns no data let write (cmd: SqliteCommand) = backgroundTask { let! _ = cmd.ExecuteNonQueryAsync() @@ -85,18 +74,10 @@ let write (cmd: SqliteCommand) = backgroundTask { /// 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 a Duration -let durationParam = - DurationPattern.Roundtrip.Format - /// Create a value for an Instant let instantParam = InstantPattern.General.Format -/// Create an optional value for a Duration -let maybeDuration = - Option.map durationParam >> maybe - /// Create an optional value for an Instant let maybeInstant = Option.map instantParam >> maybe @@ -224,7 +205,7 @@ module Map = let toUpload includeData rdr : Upload = let data = if includeData then - use dataStream = new MemoryStream () + use dataStream = new MemoryStream() use blobStream = getStream "data" rdr blobStream.CopyTo dataStream dataStream.ToArray () @@ -235,79 +216,20 @@ module Map = Path = getString "path" rdr |> Permalink UpdatedOn = getInstant "updated_on" rdr Data = data } - - /// Map from a document to a domain type, specifying the field name for the document - let fromData<'T> ser rdr fieldName : 'T = - Utils.deserialize<'T> ser (getString fieldName rdr) - - /// Map from a document to a domain type - let fromDoc<'T> ser rdr : 'T = - fromData<'T> ser rdr "data" -/// Create a list of items for the results of the given command -let cmdToList<'TDoc> (cmd: SqliteCommand) ser = backgroundTask { - use! rdr = cmd.ExecuteReaderAsync() - let mutable it: 'TDoc list = [] - while! rdr.ReadAsync() do - it <- Map.fromDoc ser rdr :: it - return List.rev it -} -/// Queries to assist with document manipulation -[] -module QueryOld = +/// Create a named parameter +let sqlParam name (value: obj) = + SqliteParameter(name, value) - /// Fragment to add an ID condition to a WHERE clause (parameter @id) - let whereById = - "data ->> 'Id' = @id" - - /// Fragment to add a web log ID condition to a WHERE clause (parameter @webLogId) - let whereByWebLog = - "data ->> 'WebLogId' = @webLogId" - - /// A SELECT/FROM pair for the given table - let selectFromTable table = - $"SELECT data FROM %s{table}" - - /// An INSERT statement for a document (parameter @data) - let insert table = - $"INSERT INTO %s{table} VALUES (@data)" - - /// A SELECT query to count documents for a given web log ID - let countByWebLog table = - $"SELECT COUNT(*) FROM %s{table} WHERE {whereByWebLog}" - - /// An UPDATE query to update a full document by its ID (parameters @data and @id) - let updateById table = - $"UPDATE %s{table} SET data = @data WHERE {whereById}" - - /// A DELETE query to delete a document by its ID (parameter @id) - let deleteById table = - $"DELETE FROM %s{table} WHERE {whereById}" - - /// Create a document ID parameter let idParam (key: 'TKey) = - SqliteParameter("@id", string key) + sqlParam "@id" (string key) /// Create a web log ID parameter let webLogParam (webLogId: WebLogId) = - SqliteParameter("@webLogId", string webLogId) + sqlParam "@webLogId" (string webLogId) -let addParam (cmd: SqliteCommand) name (value: obj) = - cmd.Parameters.AddWithValue(name, value) |> ignore - -/// Add an ID parameter for a document -let addDocId<'TKey> (cmd: SqliteCommand) (id: 'TKey) = - addParam cmd "@id" (string id) - -/// Add a document parameter -let addDocParam<'TDoc> (cmd: SqliteCommand) (doc: 'TDoc) ser = - addParam cmd "@data" (Utils.serialize ser doc) - -/// Add a web log ID parameter -let addWebLogId (cmd: SqliteCommand) (webLogId: WebLogId) = - addParam cmd "@webLogId" (string webLogId) open BitBadger.Sqlite.FSharp.Documents open BitBadger.Sqlite.FSharp.Documents.WithConn @@ -340,17 +262,6 @@ module Document = return int count } - /// Find a document by its ID - [] - let findById<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{Query.selectFromTable table} WHERE {Query.whereById}" - addDocId cmd key - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.fromDoc<'TDoc> ser rdr) else None - } - /// 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 @@ -358,46 +269,7 @@ module Document = /// Find documents for the given web log let findByWebLog<'TDoc> table (webLogId: WebLogId) conn = Find.byFieldEquals<'TDoc> table "WebLogId" webLogId conn - - /// Insert a document - [] - let insert<'TDoc> (conn: SqliteConnection) ser table (doc: 'TDoc) = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- QueryOld.insert table - addDocParam<'TDoc> cmd doc ser - do! write cmd - } - - /// Update (replace) a document by its ID - [] - let update<'TKey, 'TDoc> (conn: SqliteConnection) ser table (key: 'TKey) (doc: 'TDoc) = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- QueryOld.updateById table - addDocId cmd key - addDocParam<'TDoc> cmd doc ser - do! write cmd - } - - /// Update a field in a document by its ID - [] - let updateField<'TKey, 'TValue> (conn: SqliteConnection) ser table (key: 'TKey) jsonField - (value: 'TValue) = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- - $"UPDATE %s{table} SET data = json_set(data, '$.{jsonField}', json(@it)) WHERE {QueryOld.whereById}" - addDocId cmd key - addParam cmd "@it" (Utils.serialize ser value) - do! write cmd - } - - /// Delete a document by its ID - [] - let delete<'TKey> (conn: SqliteConnection) table (key: 'TKey) = backgroundTask { - use cmd = conn.CreateCommand() - cmd.CommandText <- QueryOld.deleteById table - addDocId cmd key - do! write cmd - } + /// Functions to support revisions module Revisions = @@ -422,21 +294,17 @@ module Revisions = (fun rdr -> keyFunc (Map.getString $"{entityTable}_id" rdr), Map.toRevision rdr) conn - /// Parameters for a revision INSERT statement - let revParams<'TKey> (key: 'TKey) rev = - [ SqliteParameter("asOf", rev.AsOf) - SqliteParameter("@id", string key) - SqliteParameter("@text", rev.Text) ] - /// 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 - if not (List.isEmpty toDelete) || not (List.isEmpty toAdd) then - for delRev in toDelete do - do! Custom.nonQuery - $"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf" - [ idParam key; SqliteParameter("@asOf", instantParam delRev.AsOf) ] - conn - for addRev in toAdd do - do! Custom.nonQuery $"INSERT INTO {revTable} VALUES (@id, @asOf, @text)" (revParams key addRev) conn + 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" addRev.Text ] + conn } diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 33bf01b..7ab5dbc 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -100,7 +100,7 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge for postId, cats in posts do do! Update.partialById Table.Post postId {| CategoryIds = cats |> List.filter (fun it -> it <> string catId) |} conn - do! Document.delete conn Table.Category catId + do! Delete.byId Table.Category catId conn return if children = 0L then CategoryDeleted else ReassignedChildCategories | None -> return CategoryNotFound } diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 0792fdf..5ada20c 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -97,7 +97,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = log.LogTrace "Post.findCurrentPermalink" let linkSql, linkParams = inJsonArray Table.Post (nameof Post.Empty.PriorPermalinks) "link" permalinks Custom.single - $"SELECT data ->> '{linkName}' + $"SELECT data ->> '{linkName}' AS permalink FROM {Table.Post} WHERE {Document.Query.whereByWebLog} AND {linkSql}" (webLogParam webLogId :: linkParams) diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index 9bc3616..0303034 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -1,72 +1,64 @@ namespace MyWebLog.Data.SQLite +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open Newtonsoft.Json /// SQLite myWebLog tag mapping data implementation -type SQLiteTagMapData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = +type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) = /// Find a tag mapping by its ID for the given web log let findById tagMapId webLogId = log.LogTrace "TagMap.findById" - Document.findByIdAndWebLog conn ser Table.TagMap tagMapId webLogId + Document.findByIdAndWebLog 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 _ -> - do! Document.delete conn Table.TagMap tagMapId + do! Delete.byId Table.TagMap tagMapId conn return true | None -> return false } /// Find a tag mapping by its URL value for the given web log - let findByUrlValue (urlValue: string) webLogId = backgroundTask { + let findByUrlValue (urlValue: string) webLogId = log.LogTrace "TagMap.findByUrlValue" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - {QueryOld.selectFromTable Table.TagMap} - WHERE {QueryOld.whereByWebLog} - AND data ->> '{nameof TagMap.Empty.UrlValue}' = @urlValue" - addWebLogId cmd webLogId - addParam cmd "@urlValue" urlValue - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.fromDoc ser rdr) else None - } + Custom.single + $"""{Document.Query.selectByWebLog Table.TagMap} + AND {Query.whereFieldEquals (nameof TagMap.Empty.UrlValue) "@urlValue"}""" + [ webLogParam webLogId; SqliteParameter("@urlValue", urlValue) ] + fromData + conn /// Get all tag mappings for the given web log let findByWebLog webLogId = log.LogTrace "TagMap.findByWebLog" - Document.findByWebLog conn ser Table.TagMap webLogId + Document.findByWebLog Table.TagMap webLogId conn /// Find any tag mappings in a list of tags for the given web log let findMappingForTags (tags: string list) webLogId = log.LogTrace "TagMap.findMappingForTags" - use cmd = conn.CreateCommand () let mapSql, mapParams = inClause $"AND data ->> '{nameof TagMap.Empty.Tag}'" "tag" id tags - cmd.CommandText <- $"{QueryOld.selectFromTable Table.TagMap} WHERE {QueryOld.whereByWebLog} {mapSql}" - addWebLogId cmd webLogId - cmd.Parameters.AddRange mapParams - cmdToList cmd ser + Custom.list + $"{Document.Query.selectByWebLog Table.TagMap} {mapSql}" + (webLogParam webLogId :: mapParams) + fromData + conn /// Save a tag mapping - let save (tagMap: TagMap) = backgroundTask { + let save (tagMap: TagMap) = log.LogTrace "TagMap.save" - match! findById tagMap.Id tagMap.WebLogId with - | Some _ -> do! Document.update conn ser Table.TagMap tagMap.Id tagMap - | None -> do! Document.insert conn ser Table.TagMap tagMap - } + save Table.TagMap tagMap conn /// Restore tag mappings from a backup let restore tagMaps = backgroundTask { log.LogTrace "TagMap.restore" - for tagMap in tagMaps do - do! save tagMap + for tagMap in tagMaps do do! save tagMap } interface ITagMapData with diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index 151496e..f5d50a1 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -1,74 +1,68 @@ namespace MyWebLog.Data.SQLite +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open Newtonsoft.Json /// SQLite myWebLog theme data implementation -type SQLiteThemeData(conn : SqliteConnection, ser: JsonSerializer, log: ILogger) = +type SQLiteThemeData(conn : SqliteConnection, log: ILogger) = /// 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 rdr + { theme with Templates = theme.Templates |> List.map (fun t -> { t with Text = "" })} + /// Remove the template text from a theme - let withoutTemplateText (it: 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 () = backgroundTask { + let all () = log.LogTrace "Theme.all" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"{QueryOld.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}" - let! themes = cmdToList cmd ser - return themes |> List.map withoutTemplateText - } + Custom.list + $"{Query.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}" + [] + withoutTemplateText + conn /// Does a given theme exist? - let exists (themeId: ThemeId) = backgroundTask { + let exists (themeId: ThemeId) = log.LogTrace "Theme.exists" - use cmd = conn.CreateCommand () - cmd.CommandText <- $"SELECT COUNT(*) FROM {Table.Theme} WHERE {idField} = @id" - addDocId cmd themeId - let! count = count cmd - return count > 0 - } + Exists.byId Table.Theme themeId conn /// Find a theme by its ID let findById themeId = log.LogTrace "Theme.findById" - Document.findById conn ser Table.Theme themeId + Find.byId Table.Theme themeId conn /// Find a theme by its ID (excludes the text of templates) - let findByIdWithoutText themeId = backgroundTask { + let findByIdWithoutText (themeId: ThemeId) = log.LogTrace "Theme.findByIdWithoutText" - let! theme = findById themeId - return theme |> Option.map withoutTemplateText - } + Custom.single (Query.Find.byId Table.Theme) [ idParam themeId ] withoutTemplateText conn /// Delete a theme by its ID let delete themeId = backgroundTask { log.LogTrace "Theme.delete" match! findByIdWithoutText themeId with | Some _ -> - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; - DELETE FROM {Table.Theme} WHERE {QueryOld.whereById}" - addDocId cmd themeId - do! write cmd + do! Custom.nonQuery + $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; {Query.Delete.byId Table.Theme}" + [ idParam themeId ] + conn return true | None -> return false } /// Save a theme - let save (theme: Theme) = backgroundTask { + let save (theme: Theme) = log.LogTrace "Theme.save" - match! findById theme.Id with - | Some _ -> do! Document.update conn ser Table.Theme theme.Id theme - | None -> do! Document.insert conn ser Table.Theme theme - } + save Table.Theme theme conn interface IThemeData with member _.All() = all () @@ -84,92 +78,72 @@ open System.IO /// SQLite myWebLog theme data implementation 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 { + let all () = log.LogTrace "ThemeAsset.all" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset}" - use! rdr = cmd.ExecuteReaderAsync() - return toList (Map.toThemeAsset false) rdr - } + Custom.list $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset}" [] (Map.toThemeAsset false) conn /// Delete all assets for the given theme - let deleteByTheme (themeId: ThemeId) = backgroundTask { + let deleteByTheme (themeId: ThemeId) = log.LogTrace "ThemeAsset.deleteByTheme" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @themeId" - addParam cmd "@themeId" (string themeId) - do! write cmd - } + Custom.nonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ] conn /// Find a theme asset by its ID - let findById assetId = backgroundTask { + let findById assetId = log.LogTrace "ThemeAsset.findById" - use cmd = conn.CreateCommand () - cmd.CommandText <- $"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @themeId AND path = @path" - let (ThemeAssetId (ThemeId themeId, path)) = assetId - addParam cmd "@themeId" themeId - addParam cmd "@path" path - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.toThemeAsset true rdr) else None - } + Custom.single + $"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id AND path = @path" + (assetIdParams assetId) + (Map.toThemeAsset true) + conn /// Get theme assets for the given theme (excludes data) - let findByTheme (themeId: ThemeId) = backgroundTask { + let findByTheme (themeId: ThemeId) = log.LogTrace "ThemeAsset.findByTheme" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @themeId" - addParam cmd "@themeId" (string themeId) - use! rdr = cmd.ExecuteReaderAsync() - return toList (Map.toThemeAsset false) rdr - } + Custom.list + $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @id" + [ idParam themeId ] + (Map.toThemeAsset false) + conn /// Get theme assets for the given theme - let findByThemeWithData (themeId: ThemeId) = backgroundTask { + let findByThemeWithData (themeId: ThemeId) = log.LogTrace "ThemeAsset.findByThemeWithData" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @themeId" - addParam cmd "@themeId" (string themeId) - use! rdr = cmd.ExecuteReaderAsync () - return toList (Map.toThemeAsset true) rdr - } + Custom.list + $"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id" + [ idParam themeId ] + (Map.toThemeAsset true) + conn /// Save a theme asset let save (asset: ThemeAsset) = backgroundTask { log.LogTrace "ThemeAsset.save" - use sideCmd = conn.CreateCommand() - sideCmd.CommandText <- $"SELECT COUNT(*) FROM {Table.ThemeAsset} WHERE theme_id = @themeId AND path = @path" - let (ThemeAssetId (ThemeId themeId, path)) = asset.Id - addParam sideCmd "@themeId" themeId - addParam sideCmd "@path" path - let! exists = count sideCmd - - use cmd = conn.CreateCommand () - cmd.CommandText <- - if exists = 1 then - $"UPDATE {Table.ThemeAsset} - SET updated_on = @updatedOn, - data = ZEROBLOB(@dataLength) - WHERE theme_id = @themeId - AND path = @path" - else + do! Custom.nonQuery $"INSERT INTO {Table.ThemeAsset} ( theme_id, path, updated_on, data ) VALUES ( @themeId, @path, @updatedOn, ZEROBLOB(@dataLength) - )" - addParam cmd "@themeId" themeId - addParam cmd "@path" path - addParam cmd "@updatedOn" (instantParam asset.UpdatedOn) - addParam cmd "@dataLength" asset.Data.Length - do! write cmd - - sideCmd.CommandText <- $"SELECT ROWID FROM {Table.ThemeAsset} WHERE theme_id = @themeId AND path = @path" - let! rowId = sideCmd.ExecuteScalarAsync() + ) 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) ] + conn + let! rowId = + Custom.scalar + $"SELECT ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id AND path = @path" + (assetIdParams asset.Id) + (_.GetInt64(0)) + conn use dataStream = new MemoryStream(asset.Data) - use blobStream = new SqliteBlob(conn, Table.ThemeAsset, "data", rowId :?> int64) + use blobStream = new SqliteBlob(conn, Table.ThemeAsset, "data", rowId) do! dataStream.CopyToAsync blobStream } diff --git a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs index 9a7cd82..e6bc5e0 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.SQLite open System.IO +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -9,89 +10,70 @@ open MyWebLog.Data /// SQLite myWebLog web log data implementation type SQLiteUploadData(conn: SqliteConnection, log: ILogger) = - /// Add parameters for uploaded file INSERT and UPDATE statements - let addUploadParameters (cmd: SqliteCommand) (upload: Upload) = - addParam cmd "@id" (string upload.Id) - addParam cmd "@webLogId" (string upload.WebLogId) - addParam cmd "@path" (string upload.Path) - addParam cmd "@updatedOn" (instantParam upload.UpdatedOn) - addParam cmd "@dataLength" upload.Data.Length - /// Save an uploaded file - let add upload = backgroundTask { + let add (upload: Upload) = backgroundTask { log.LogTrace "Upload.add" - use cmd = conn.CreateCommand() - cmd.CommandText <- - $"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 {Table.Upload} WHERE id = @id" - let! rowId = cmd.ExecuteScalarAsync() - + do! Custom.nonQuery + $"INSERT INTO {Table.Upload} ( + id, web_log_id, path, updated_on, data + ) VALUES ( + @id, @webLogId, @path, @updatedOn, ZEROBLOB(@dataLength) + )" + [ idParam upload.Id + webLogParam upload.WebLogId + sqlParam "@path" (string upload.Path) + sqlParam "@updatedOn" (instantParam upload.UpdatedOn) + sqlParam "@dataLength" upload.Data.Length ] + conn + let! rowId = + Custom.scalar $"SELECT ROWID FROM {Table.Upload} WHERE id = @id" [ idParam upload.Id ] (_.GetInt64(0)) conn use dataStream = new MemoryStream(upload.Data) - use blobStream = new SqliteBlob(conn, Table.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: UploadId) webLogId = backgroundTask { log.LogTrace "Upload.delete" - use cmd = conn.CreateCommand() - cmd.CommandText <- - $"SELECT id, web_log_id, path, updated_on - FROM {Table.Upload} - WHERE id = @id - AND web_log_id = @webLogId" - addWebLogId cmd webLogId - addDocId cmd uploadId - let! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - if isFound then - let upload = Map.toUpload false rdr - do! rdr.CloseAsync() - cmd.CommandText <- $"DELETE FROM {Table.Upload} WHERE id = @id AND web_log_id = @webLogId" - do! write cmd - return Ok (string upload.Path) - else - return Error $"""Upload ID {cmd.Parameters["@id"].Value} not found""" + let! upload = + Custom.single + $"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) + conn + match upload with + | Some up -> + do! Custom.nonQuery $"DELETE FROM {Table.Upload} WHERE id = @id" [ idParam up.Id ] conn + 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 { + let findByPath (path: string) webLogId = log.LogTrace "Upload.findByPath" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId AND path = @path" - addWebLogId cmd webLogId - addParam cmd "@path" path - let! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.toUpload true rdr) else None - } + Custom.single + $"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId AND path = @path" + [ webLogParam webLogId; sqlParam "@path" path ] + (Map.toUpload true) + conn /// Find all uploaded files for the given web log (excludes data) - let findByWebLog webLogId = backgroundTask { + let findByWebLog webLogId = log.LogTrace "Upload.findByWebLog" - use cmd = conn.CreateCommand() - cmd.CommandText <- $"SELECT id, web_log_id, path, updated_on FROM {Table.Upload} WHERE web_log_id = @webLogId" - addWebLogId cmd webLogId - let! rdr = cmd.ExecuteReaderAsync() - return toList (Map.toUpload false) rdr - } + Custom.list + $"SELECT id, web_log_id, path, updated_on FROM {Table.Upload} WHERE web_log_id = @webLogId" + [ webLogParam webLogId ] + (Map.toUpload false) + conn /// Find all uploaded files for the given web log - let findByWebLogWithData webLogId = backgroundTask { + let findByWebLogWithData webLogId = log.LogTrace "Upload.findByWebLogWithData" - use cmd = conn.CreateCommand () - cmd.CommandText <- $"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId" - addWebLogId cmd webLogId - let! rdr = cmd.ExecuteReaderAsync() - return toList (Map.toUpload true) rdr - } + Custom.list + $"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId" + [ webLogParam webLogId ] + (Map.toUpload true) + conn /// Restore uploads from a backup let restore uploads = backgroundTask { diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index 7cec1a7..e308e94 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -1,79 +1,68 @@ namespace MyWebLog.Data.SQLite -open System.Threading.Tasks +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open Newtonsoft.Json /// SQLite myWebLog web log data implementation -type SQLiteWebLogData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = +type SQLiteWebLogData(conn: SqliteConnection, log: ILogger) = /// Add a web log let add webLog = log.LogTrace "WebLog.add" - Document.insert conn ser Table.WebLog webLog + insert Table.WebLog webLog conn /// Retrieve all web logs let all () = log.LogTrace "WebLog.all" - use cmd = conn.CreateCommand() - cmd.CommandText <- QueryOld.selectFromTable Table.WebLog - cmdToList cmd ser + Find.all Table.WebLog conn /// Delete a web log by its ID - let delete webLogId = backgroundTask { + let delete webLogId = log.LogTrace "WebLog.delete" - let idField = "data ->> 'WebLogId'" - let subQuery table = $"(SELECT data ->> 'Id' FROM {table} WHERE {idField} = @webLogId)" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - 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 {idField} = @webLogId; - DELETE FROM {Table.Page} WHERE {idField} = @webLogId; - DELETE FROM {Table.Category} WHERE {idField} = @webLogId; - DELETE FROM {Table.TagMap} WHERE {idField} = @webLogId; - DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId; - DELETE FROM {Table.WebLogUser} WHERE {idField} = @webLogId; - DELETE FROM {Table.WebLog} WHERE id = @webLogId" - addWebLogId cmd webLogId - do! write cmd - } + let subQuery table = + $"""(SELECT data ->> 'Id' FROM {table} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}""" + 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 {Query.whereFieldEquals "WebLogId" "@webLogId"}; + DELETE FROM {Table.Page} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; + DELETE FROM {Table.Category} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; + DELETE FROM {Table.TagMap} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; + DELETE FROM {Table.Upload} WHERE web_log_id = @id; + DELETE FROM {Table.WebLogUser} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; + DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}""" + [ webLogParam webLogId ] + conn /// Find a web log by its host (URL base) - let findByHost (url: string) = backgroundTask { + let findByHost (url: string) = log.LogTrace "WebLog.findByHost" - use cmd = conn.CreateCommand() - cmd.CommandText <- - $"{QueryOld.selectFromTable Table.WebLog} WHERE data ->> '{nameof WebLog.Empty.UrlBase}' = @urlBase" - addParam cmd "@urlBase" url - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.fromDoc ser rdr) else None - } + Find.firstByFieldEquals Table.WebLog (nameof WebLog.Empty.UrlBase) url conn /// Find a web log by its ID let findById webLogId = log.LogTrace "WebLog.findById" - Document.findById conn ser Table.WebLog webLogId + Find.byId Table.WebLog webLogId conn /// Update redirect rules for a web log let updateRedirectRules (webLog: WebLog) = log.LogTrace "WebLog.updateRedirectRules" - Document.updateField conn ser Table.WebLog webLog.Id (nameof WebLog.Empty.RedirectRules) webLog.RedirectRules + Update.partialById Table.WebLog webLog.Id {| RedirectRules = webLog.RedirectRules |} conn /// Update RSS options for a web log let updateRssOptions (webLog: WebLog) = log.LogTrace "WebLog.updateRssOptions" - Document.updateField conn ser Table.WebLog webLog.Id (nameof WebLog.Empty.Rss) webLog.Rss + Update.partialById Table.WebLog webLog.Id {| Rss = webLog.Rss |} conn /// Update settings for a web log let updateSettings (webLog: WebLog) = log.LogTrace "WebLog.updateSettings" - Document.update conn ser Table.WebLog webLog.Id webLog + Update.full Table.WebLog webLog.Id webLog conn interface IWebLogData with member _.Add webLog = add webLog diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 5029f98..35771e7 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -1,125 +1,85 @@ namespace MyWebLog.Data.SQLite +open BitBadger.Sqlite.FSharp.Documents +open BitBadger.Sqlite.FSharp.Documents.WithConn open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open Newtonsoft.Json /// SQLite myWebLog user data implementation -type SQLiteWebLogUserData(conn: SqliteConnection, ser: JsonSerializer, log: ILogger) = - - // SUPPORT FUNCTIONS - - /// Add parameters for web log user INSERT or UPDATE statements - let addWebLogUserParameters (cmd: SqliteCommand) (user: WebLogUser) = - [ cmd.Parameters.AddWithValue ("@id", string user.Id) - cmd.Parameters.AddWithValue ("@webLogId", string 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 ("@url", maybe user.Url) - cmd.Parameters.AddWithValue ("@accessLevel", string user.AccessLevel) - cmd.Parameters.AddWithValue ("@createdOn", instantParam user.CreatedOn) - cmd.Parameters.AddWithValue ("@lastSeenOn", maybeInstant user.LastSeenOn) - ] |> ignore - - // IMPLEMENTATION FUNCTIONS - - /// Add a user - let add user = - log.LogTrace "WebLogUser.add" - Document.insert conn ser Table.WebLogUser user +type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = /// Find a user by their ID for the given web log let findById userId webLogId = log.LogTrace "WebLogUser.findById" - Document.findByIdAndWebLog conn ser Table.WebLogUser userId webLogId + Document.findByIdAndWebLog 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(*) FROM {Table.Page} WHERE data ->> 'AuthorId' = @id" - addDocId cmd userId - let! pageCount = count cmd - cmd.CommandText <- cmd.CommandText.Replace($"FROM {Table.Page}", $"FROM {Table.Post}") - let! postCount = count cmd + let! pageCount = Count.byFieldEquals Table.Page (nameof Page.Empty.AuthorId) (string userId) conn + let! postCount = Count.byFieldEquals Table.Post (nameof Post.Empty.AuthorId) (string userId) conn if pageCount + postCount > 0 then return Error "User has pages or posts; cannot delete" else - do! Document.delete conn Table.WebLogUser userId + do! Delete.byId Table.WebLogUser userId conn 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 { + let findByEmail (email: string) webLogId = log.LogTrace "WebLogUser.findByEmail" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - {QueryOld.selectFromTable Table.WebLogUser} - WHERE {QueryOld.whereByWebLog} - AND data ->> '{nameof WebLogUser.Empty.Email}' = @email" - addWebLogId cmd webLogId - addParam cmd "@email" email - use! rdr = cmd.ExecuteReaderAsync() - let! isFound = rdr.ReadAsync() - return if isFound then Some (Map.fromDoc ser rdr) else None - } + Custom.single + $"""{Document.Query.selectByWebLog Table.WebLogUser} + AND {Query.whereFieldEquals (nameof WebLogUser.Empty.Email) "@email"}""" + [ webLogParam webLogId; sqlParam "@email" email ] + fromData + conn /// Get all users for the given web log let findByWebLog webLogId = backgroundTask { log.LogTrace "WebLogUser.findByWebLog" - let! users = Document.findByWebLog conn ser Table.WebLogUser webLogId + let! users = Document.findByWebLog 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: WebLogUserId list) = backgroundTask { + let findNames webLogId (userIds: WebLogUserId list) = log.LogTrace "WebLogUser.findNames" - use cmd = conn.CreateCommand() let nameSql, nameParams = inClause "AND data ->> 'Id'" "id" string userIds - cmd.CommandText <- $"{QueryOld.selectFromTable Table.WebLogUser} WHERE {QueryOld.whereByWebLog} {nameSql}" - addWebLogId cmd webLogId - cmd.Parameters.AddRange nameParams - let! users = cmdToList cmd ser - return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName }) - } + Custom.list + $"{Document.Query.selectByWebLog Table.WebLogUser} {nameSql}" + (webLogParam webLogId :: nameParams) + (fun rdr -> + let user = fromData rdr + { Name = string user.Id; Value = user.DisplayName }) + conn + + /// Save a user + let save user = + log.LogTrace "WebLogUser.update" + save Table.WebLogUser user conn /// Restore users from a backup let restore users = backgroundTask { log.LogTrace "WebLogUser.restore" - for user in users do - do! add user + for user in users do do! save user } /// Set a user's last seen date/time to now - let setLastSeen (userId: WebLogUserId) webLogId = backgroundTask { + let setLastSeen userId webLogId = backgroundTask { log.LogTrace "WebLogUser.setLastSeen" - use cmd = conn.CreateCommand() - cmd.CommandText <- $" - UPDATE {Table.WebLogUser} - SET data = json_set(data, '$.{nameof WebLogUser.Empty.LastSeenOn}', @lastSeenOn) - WHERE {QueryOld.whereById} - AND {QueryOld.whereByWebLog}" - addDocId cmd userId - addWebLogId cmd webLogId - addParam cmd "@lastSeenOn" (instantParam (Noda.now ())) - do! write cmd + match! findById userId webLogId with + | Some _ -> do! Update.partialById Table.WebLogUser userId {| LastSeenOn = Noda.now () |} conn + | None -> () } - /// Update a user - let update (user: WebLogUser) = - log.LogTrace "WebLogUser.update" - Document.update conn ser Table.WebLogUser user.Id user - interface IWebLogUserData with - member _.Add user = add user + member _.Add user = save user member _.Delete userId webLogId = delete userId webLogId member _.FindByEmail email webLogId = findByEmail email webLogId member _.FindById userId webLogId = findById userId webLogId @@ -127,4 +87,4 @@ type SQLiteWebLogUserData(conn: SqliteConnection, ser: JsonSerializer, log: ILog member _.FindNames webLogId userIds = findNames webLogId userIds member _.Restore users = restore users member _.SetLastSeen userId webLogId = setLastSeen userId webLogId - member _.Update user = update user + member _.Update user = save user diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index b5a85ff..4386d09 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -456,12 +456,12 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria member _.Category = SQLiteCategoryData (conn, ser, log) member _.Page = SQLitePageData (conn, log) member _.Post = SQLitePostData (conn, log) - member _.TagMap = SQLiteTagMapData (conn, ser, log) - member _.Theme = SQLiteThemeData (conn, ser, 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, ser, log) - member _.WebLogUser = SQLiteWebLogUserData (conn, ser, log) + member _.WebLog = SQLiteWebLogData (conn, log) + member _.WebLogUser = SQLiteWebLogUserData (conn, log) member _.Serializer = ser -- 2.45.1 From 7fb68d5583c2ab7a6a509361b93f0eab748c75bc Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 19 Dec 2023 21:26:06 -0500 Subject: [PATCH 027/123] Rename SQLite helper file --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 2 +- src/MyWebLog.Data/SQLite/{Helpers.fs => SQLiteHelpers.fs} | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) rename src/MyWebLog.Data/SQLite/{Helpers.fs => SQLiteHelpers.fs} (99%) diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index ee61d16..6b5d0a8 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -25,7 +25,7 @@ - + diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs similarity index 99% rename from src/MyWebLog.Data/SQLite/Helpers.fs rename to src/MyWebLog.Data/SQLite/SQLiteHelpers.fs index cd6c2b6..d11cd7a 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs @@ -1,6 +1,6 @@ /// Helper functions for the SQLite data implementation [] -module MyWebLog.Data.SQLite.Helpers +module MyWebLog.Data.SQLite.SQLiteHelpers /// The table names used in the SQLite implementation [] -- 2.45.1 From e8d63793ba69e62425a2ea37d1eed10c8d1a3d70 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 31 Dec 2023 08:36:03 -0500 Subject: [PATCH 028/123] Migrate Postgres data to new library --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 2 +- src/MyWebLog.Data/Postgres/PostgresCache.fs | 10 +-- .../Postgres/PostgresCategoryData.fs | 31 ++++----- src/MyWebLog.Data/Postgres/PostgresHelpers.fs | 23 ++----- .../Postgres/PostgresPageData.fs | 11 +-- .../Postgres/PostgresPostData.fs | 20 +++--- .../Postgres/PostgresTagMapData.fs | 7 +- .../Postgres/PostgresThemeData.fs | 27 ++++---- .../Postgres/PostgresUploadData.fs | 7 +- .../Postgres/PostgresWebLogData.fs | 11 +-- .../Postgres/PostgresWebLogUserData.fs | 16 ++--- src/MyWebLog.Data/PostgresData.fs | 68 +++++++++---------- src/MyWebLog/Program.fs | 4 +- 13 files changed, 111 insertions(+), 126 deletions(-) diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 6b5d0a8..d2e5d31 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -9,7 +9,7 @@ - + diff --git a/src/MyWebLog.Data/Postgres/PostgresCache.fs b/src/MyWebLog.Data/Postgres/PostgresCache.fs index 4f665f5..2a8b9c8 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCache.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCache.fs @@ -2,7 +2,7 @@ namespace MyWebLog.Data.Postgres open System.Threading open System.Threading.Tasks -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Caching.Distributed open NodaTime @@ -48,9 +48,11 @@ type DistributedCache () = task { let! exists = Custom.scalar - $"SELECT EXISTS - (SELECT 1 FROM pg_tables WHERE schemaname = 'public' AND tablename = 'session') - AS {existsName}" [] Map.toExists + "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 ( diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index ce12e88..d127585 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data @@ -41,13 +42,12 @@ type PostgresCategoryData(log: ILogger) = |> arrayContains (nameof Post.Empty.CategoryIds) id let postCount = Custom.scalar - $"""SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') AS {countName} + $"""SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') AS it FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"} AND {catIdSql}""" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} - catIdParams ] - Map.toCount + [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catIdParams ] + toCount |> Async.AwaitTask |> Async.RunSynchronously it.Id, postCount) @@ -85,33 +85,32 @@ type PostgresCategoryData(log: ILogger) = Configuration.dataSource () |> Sql.fromDataSource |> Sql.executeTransactionAsync - [ Query.Update.partialById Table.Category, + [ Query.Patch.byId Table.Category, children |> List.map (fun child -> - [ "@id", Sql.string (string child.Id) - "@data", Query.jsonbDocParam {| ParentId = cat.ParentId |} ]) ] + [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ]) ] () // 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" - [ "@id", Query.jsonbDocParam [| string catId |] ] + [ jsonParam "@id" [| string catId |] ] fromData if not (List.isEmpty posts) then let! _ = Configuration.dataSource () |> Sql.fromDataSource |> Sql.executeTransactionAsync - [ Query.Update.partialById Table.Post, + [ Query.Patch.byId Table.Post, posts |> List.map (fun post -> - [ "@id", Sql.string (string post.Id) - "@data", Query.jsonbDocParam - {| CategoryIds = post.CategoryIds - |> List.filter (fun cat -> cat <> catId) |} ]) ] + [ idParam post.Id + jsonParam + "@data" + {| CategoryIds = post.CategoryIds |> List.filter (fun cat -> cat <> catId) |} ]) ] () // Delete the category itself - do! Delete.byId Table.Category (string catId) + do! Delete.byId Table.Category catId return if hasChildren then ReassignedChildCategories else CategoryDeleted | None -> return CategoryNotFound } @@ -129,7 +128,7 @@ type PostgresCategoryData(log: ILogger) = Configuration.dataSource () |> Sql.fromDataSource |> Sql.executeTransactionAsync [ - Query.insert Table.Category, cats |> List.map (fun c -> [ "@data", Query.jsonbDocParam c ]) + Query.insert Table.Category, cats |> List.map (fun c -> [ jsonParam "@data" c ]) ] () } diff --git a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs index 601b1e8..b9e8bff 100644 --- a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs +++ b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs @@ -61,7 +61,8 @@ module Table = open System open System.Threading.Tasks -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open MyWebLog open MyWebLog.Data open NodaTime @@ -78,13 +79,7 @@ let webLogDoc (webLogId: WebLogId) = /// Create a parameter for a web log document-contains query let webLogContains webLogId = - "@criteria", Query.jsonbDocParam (webLogDoc webLogId) - -/// The name of the field to select to be able to use Map.toCount -let countName = "the_count" - -/// The name of the field to select to be able to use Map.toExists -let existsName = "does_exist" + jsonParam "@criteria" (webLogDoc webLogId) /// A SQL string to select data from a table with the given JSON document contains criteria let selectWithCriteria tableName = @@ -129,14 +124,6 @@ let optParam<'T> name (it: 'T option) = /// Mapping functions for SQL queries module Map = - /// Get a count from a row - let toCount (row: RowReader) = - row.int countName - - /// Get a true/false value as to whether an item exists - let toExists (row: RowReader) = - row.bool existsName - /// Create a permalink from the current row let toPermalink (row: RowReader) = Permalink (row.string "permalink") @@ -168,9 +155,9 @@ module Document = Custom.scalar $"""SELECT EXISTS ( SELECT 1 FROM %s{table} WHERE {Query.whereById "@id"} AND {Query.whereDataContains "@criteria"} - ) AS {existsName}""" + ) AS it""" [ "@id", Sql.string (string key); webLogContains webLogId ] - Map.toExists + toExists /// Find a document by its ID for the given web log let findByIdAndWebLog<'TKey, 'TDoc> table (key: 'TKey) webLogId = diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 364a99f..33fb0e4 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data @@ -76,7 +77,7 @@ type PostgresPageData(log: ILogger) = do! Custom.nonQuery $"""DELETE FROM {Table.PageRevision} WHERE page_id = @id; DELETE FROM {Table.Page} WHERE {Query.whereById "@id"}""" - [ "@id", Sql.string (string pageId) ] + [ idParam pageId ] return true | false -> return false } @@ -119,7 +120,7 @@ type PostgresPageData(log: ILogger) = log.LogTrace "Page.findListed" Custom.list $"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with IsInPageList = true |} ] + [ jsonParam "@criteria" {| webLogDoc webLogId with IsInPageList = true |} ] pageWithoutText /// Get a page of pages for the given web log (without revisions) @@ -141,7 +142,7 @@ type PostgresPageData(log: ILogger) = |> Sql.fromDataSource |> Sql.executeTransactionAsync [ Query.insert Table.Page, - pages |> List.map (fun page -> [ "@data", Query.jsonbDocParam { page with Revisions = [] } ]) + pages |> List.map (fun page -> [ jsonParam "@data" { page with Revisions = [] } ]) Revisions.insertSql Table.PageRevision, revisions |> List.map (fun (pageId, rev) -> Revisions.revParams pageId rev) ] () @@ -161,7 +162,7 @@ type PostgresPageData(log: ILogger) = log.LogTrace "Page.updatePriorPermalinks" match! pageExists pageId webLogId with | true -> - do! Update.partialById Table.Page (string pageId) {| PriorPermalinks = permalinks |} + do! Patch.byId Table.Page pageId {| PriorPermalinks = permalinks |} return true | false -> return false } diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index b33abc6..6f858af 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data @@ -50,7 +51,7 @@ type PostgresPostData(log: ILogger) = log.LogTrace "Post.findByPermalink" Custom.single (selectWithCriteria Table.Post) - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Permalink = permalink |} ] + [ jsonParam "@criteria" {| webLogDoc webLogId with Permalink = permalink |} ] fromData /// Find a complete post by its ID for the given web log @@ -72,7 +73,7 @@ type PostgresPostData(log: ILogger) = $"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"}; DELETE FROM {Table.PostRevision} WHERE post_id = @id; DELETE FROM {Table.Post} WHERE {Query.whereById "@id"}""" - [ "@id", Sql.string (string postId); "@criteria", Query.jsonbDocParam {| PostId = postId |} ] + [ idParam postId; jsonParam "@criteria" {| PostId = postId |} ] return true | false -> return false } @@ -113,7 +114,7 @@ type PostgresPostData(log: ILogger) = AND {catSql} ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |}; catParam ] + [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catParam ] fromData /// Get a page of posts for the given web log (excludes text and revisions) @@ -134,7 +135,7 @@ type PostgresPostData(log: ILogger) = $"{selectWithCriteria Table.Post} ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} ] + [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ] fromData /// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks) @@ -145,15 +146,14 @@ type PostgresPostData(log: ILogger) = AND data['{nameof Post.Empty.Tags}'] @> @tag ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} - "@tag", Query.jsonbDocParam [| tag |] ] + [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; jsonParam "@tag" [| tag |] ] fromData /// Find the next newest and oldest post from a publish date for the given web log let findSurroundingPosts webLogId publishedOn = backgroundTask { log.LogTrace "Post.findSurroundingPosts" let queryParams () = - [ "@criteria", Query.jsonbDocParam {| webLogDoc webLogId with Status = Published |} + [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn)[..19]) ] let pubField = nameof Post.Empty.PublishedOn let! older = @@ -192,7 +192,7 @@ type PostgresPostData(log: ILogger) = |> Sql.fromDataSource |> Sql.executeTransactionAsync [ Query.insert Table.Post, - posts |> List.map (fun post -> [ "@data", Query.jsonbDocParam { post with Revisions = [] } ]) + posts |> List.map (fun post -> [ jsonParam "@data" { post with Revisions = [] } ]) Revisions.insertSql Table.PostRevision, revisions |> List.map (fun (postId, rev) -> Revisions.revParams postId rev) ] () @@ -203,7 +203,7 @@ type PostgresPostData(log: ILogger) = log.LogTrace "Post.updatePriorPermalinks" match! postExists postId webLogId with | true -> - do! Update.partialById Table.Post (string postId) {| PriorPermalinks = permalinks |} + do! Patch.byId Table.Post postId {| PriorPermalinks = permalinks |} return true | false -> return false } diff --git a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs index 1a43b74..2369a6f 100644 --- a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data @@ -19,7 +20,7 @@ type PostgresTagMapData(log: ILogger) = log.LogTrace "TagMap.delete" let! exists = Document.existsByWebLog Table.TagMap tagMapId webLogId if exists then - do! Delete.byId Table.TagMap (string tagMapId) + do! Delete.byId Table.TagMap tagMapId return true else return false } @@ -58,7 +59,7 @@ type PostgresTagMapData(log: ILogger) = |> Sql.fromDataSource |> Sql.executeTransactionAsync [ Query.insert Table.TagMap, - tagMaps |> List.map (fun tagMap -> [ "@data", Query.jsonbDocParam tagMap ]) ] + tagMaps |> List.map (fun tagMap -> [ jsonParam "@data" tagMap ]) ] () } diff --git a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs index 819489f..bb7d67d 100644 --- a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs @@ -1,10 +1,10 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open Npgsql.FSharp /// PostreSQL myWebLog theme data implementation type PostgresThemeData(log: ILogger) = @@ -25,17 +25,17 @@ type PostgresThemeData(log: ILogger) = /// Does a given theme exist? let exists (themeId: ThemeId) = log.LogTrace "Theme.exists" - Exists.byId Table.Theme (string themeId) + Exists.byId Table.Theme themeId /// Find a theme by its ID let findById (themeId: ThemeId) = log.LogTrace "Theme.findById" - Find.byId Table.Theme (string themeId) + Find.byId 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) [ "@id", Sql.string (string themeId) ] withoutTemplateText + Custom.single (Query.Find.byId Table.Theme) [ idParam themeId ] withoutTemplateText /// Delete a theme by its ID let delete themeId = backgroundTask { @@ -45,7 +45,7 @@ type PostgresThemeData(log: ILogger) = do! Custom.nonQuery $"""DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; DELETE FROM {Table.Theme} WHERE {Query.whereById "@id"}""" - [ "@id", Sql.string (string themeId) ] + [ idParam themeId ] return true | false -> return false } @@ -75,32 +75,29 @@ type PostgresThemeAssetData(log: ILogger) = /// Delete all assets for the given theme let deleteByTheme (themeId: ThemeId) = log.LogTrace "ThemeAsset.deleteByTheme" - Custom.nonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ "@id", Sql.string (string themeId) ] + 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 = @themeId AND path = @path" - [ "@themeId", Sql.string themeId; "@path", Sql.string path ] + $"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 = @themeId" - [ "@themeId", Sql.string (string themeId) ] + $"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 = @themeId" - [ "@themeId", Sql.string (string themeId) ] - (Map.toThemeAsset true) + Custom.list $"SELECT * FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ] (Map.toThemeAsset true) /// Save a theme asset let save (asset: ThemeAsset) = diff --git a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs index f78c0f3..bfacbc9 100644 --- a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data @@ -21,7 +22,7 @@ type PostgresUploadData(log: ILogger) = let upParams (upload: Upload) = [ webLogIdParam upload.WebLogId typedParam "updatedOn" upload.UpdatedOn - "@id", Sql.string (string upload.Id) + idParam upload.Id "@path", Sql.string (string upload.Path) "@data", Sql.bytea upload.Data ] @@ -33,7 +34,7 @@ type PostgresUploadData(log: ILogger) = /// Delete an uploaded file by its ID let delete uploadId webLogId = backgroundTask { log.LogTrace "Upload.delete" - let idParam = [ "@id", Sql.string (string uploadId) ] + let idParam = [ idParam uploadId ] let! path = Custom.single $"SELECT path FROM {Table.Upload} WHERE id = @id AND web_log_id = @webLogId" diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index 60ed13c..921fd67 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data @@ -46,13 +47,13 @@ type PostgresWebLogData(log: ILogger) = /// Find a web log by its ID let findById (webLogId: WebLogId) = log.LogTrace "WebLog.findById" - Find.byId Table.WebLog (string webLogId) + Find.byId 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! Update.partialById Table.WebLog (string webLog.Id) {| RedirectRules = webLog.RedirectRules |} + | Some _ -> do! Patch.byId Table.WebLog webLog.Id {| RedirectRules = webLog.RedirectRules |} | None -> () } @@ -60,14 +61,14 @@ type PostgresWebLogData(log: ILogger) = let updateRssOptions (webLog: WebLog) = backgroundTask { log.LogTrace "WebLog.updateRssOptions" match! findById webLog.Id with - | Some _ -> do! Update.partialById Table.WebLog (string webLog.Id) {| Rss = webLog.Rss |} + | 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.full Table.WebLog (string webLog.Id) webLog + Update.byId Table.WebLog webLog.Id webLog interface IWebLogData with member _.Add webLog = add webLog diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs index ed7f08c..d919d12 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -1,6 +1,7 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data @@ -24,13 +25,13 @@ type PostgresWebLogUserData(log: ILogger) = Custom.scalar $" SELECT ( EXISTS (SELECT 1 FROM {Table.Page} WHERE {criteria}) OR EXISTS (SELECT 1 FROM {Table.Post} WHERE {criteria}) - ) AS {existsName}" - [ "@criteria", Query.jsonbDocParam {| AuthorId = userId |} ] - Map.toExists + ) 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 (string userId) + do! Delete.byId Table.WebLogUser userId return Ok true | None -> return Error "User does not exist" } @@ -67,8 +68,7 @@ type PostgresWebLogUserData(log: ILogger) = Configuration.dataSource () |> Sql.fromDataSource |> Sql.executeTransactionAsync - [ Query.insert Table.WebLogUser, - users |> List.map (fun user -> Query.docParameters (string user.Id) user) ] + [ Query.insert Table.WebLogUser, users |> List.map (fun user -> [ jsonParam "@data" user ]) ] () } @@ -76,7 +76,7 @@ type PostgresWebLogUserData(log: ILogger) = let setLastSeen (userId: WebLogUserId) webLogId = backgroundTask { log.LogTrace "WebLogUser.setLastSeen" match! Document.existsByWebLog Table.WebLogUser userId webLogId with - | true -> do! Update.partialById Table.WebLogUser (string userId) {| LastSeenOn = Some (Noda.now ()) |} + | true -> do! Patch.byId Table.WebLogUser userId {| LastSeenOn = Some (Noda.now ()) |} | false -> () } diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 09e4207..b35ec62 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -1,7 +1,7 @@ namespace MyWebLog.Data -open BitBadger.Npgsql.Documents -open BitBadger.Npgsql.FSharp.Documents +open BitBadger.Documents +open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data.Postgres @@ -31,8 +31,8 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = // Theme tables if needsTable Table.Theme then isNew <- true - Definition.createTable Table.Theme - Definition.createKey Table.Theme + Query.Definition.ensureTable Table.Theme + Query.Definition.ensureKey Table.Theme if needsTable Table.ThemeAsset then $"CREATE TABLE {Table.ThemeAsset} ( theme_id TEXT NOT NULL, @@ -43,30 +43,29 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = // Web log table if needsTable Table.WebLog then - Definition.createTable Table.WebLog - Definition.createKey Table.WebLog - Definition.createIndex Table.WebLog Optimized + Query.Definition.ensureTable Table.WebLog + Query.Definition.ensureKey Table.WebLog + Query.Definition.ensureDocumentIndex Table.WebLog Optimized // Category table if needsTable Table.Category then - Definition.createTable Table.Category - Definition.createKey Table.Category - Definition.createIndex Table.Category Optimized + 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 - Definition.createTable Table.WebLogUser - Definition.createKey Table.WebLogUser - Definition.createIndex Table.WebLogUser Optimized + Query.Definition.ensureTable Table.WebLogUser + Query.Definition.ensureKey Table.WebLogUser + Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized // Page tables if needsTable Table.Page then - Definition.createTable Table.Page - Definition.createKey Table.Page - $"CREATE INDEX page_web_log_idx ON {Table.Page} ((data ->> '{nameof Page.Empty.WebLogId}'))" - $"CREATE INDEX page_author_idx ON {Table.Page} ((data ->> '{nameof Page.Empty.AuthorId}'))" - $"CREATE INDEX page_permalink_idx ON {Table.Page} - ((data ->> '{nameof Page.Empty.WebLogId}'), (data ->> '{nameof Page.Empty.Permalink}'))" + 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, @@ -76,15 +75,15 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = // Post tables if needsTable Table.Post then - Definition.createTable Table.Post - Definition.createKey Table.Post - $"CREATE INDEX post_web_log_idx ON {Table.Post} ((data ->> '{nameof Post.Empty.WebLogId}'))" - $"CREATE INDEX post_author_idx ON {Table.Post} ((data ->> '{nameof Post.Empty.AuthorId}'))" - $"CREATE INDEX post_status_idx ON {Table.Post} - ((data ->> '{nameof Post.Empty.WebLogId}'), (data ->> '{nameof Post.Empty.Status}'), - (data ->> '{nameof Post.Empty.UpdatedOn}'))" - $"CREATE INDEX post_permalink_idx ON {Table.Post} - ((data ->> '{nameof Post.Empty.WebLogId}'), (data ->> '{nameof Post.Empty.Permalink}'))" + 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 post_category_idx ON {Table.Post} USING GIN ((data['{nameof Post.Empty.CategoryIds}']))" $"CREATE INDEX post_tag_idx ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))" if needsTable Table.PostRevision then @@ -94,16 +93,15 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = revision_text TEXT NOT NULL, PRIMARY KEY (post_id, as_of))" if needsTable Table.PostComment then - Definition.createTable Table.PostComment - Definition.createKey Table.PostComment - $"CREATE INDEX post_comment_post_idx ON {Table.PostComment} - ((data ->> '{nameof Comment.Empty.PostId}'))" + 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 - Definition.createTable Table.TagMap - Definition.createKey Table.TagMap - Definition.createIndex Table.TagMap Optimized + Query.Definition.ensureTable Table.TagMap + Query.Definition.ensureKey Table.TagMap + Query.Definition.ensureDocumentIndex Table.TagMap Optimized // Uploaded file table if needsTable Table.Upload then diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 5de9065..e8c7380 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -50,14 +50,12 @@ type RedirectRuleMiddleware(next: RequestDelegate, log: ILogger Date: Sun, 31 Dec 2023 13:31:46 -0500 Subject: [PATCH 029/123] Migrate SQLite data to new library --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 5 +- .../SQLite/SQLiteCategoryData.fs | 28 +++++---- src/MyWebLog.Data/SQLite/SQLiteHelpers.fs | 17 +++--- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 37 +++++------- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 48 +++++++--------- src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs | 16 +++--- src/MyWebLog.Data/SQLite/SQLiteThemeData.fs | 39 ++++++------- src/MyWebLog.Data/SQLite/SQLiteUploadData.fs | 21 +++---- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 33 ++++++----- .../SQLite/SQLiteWebLogUserData.fs | 22 ++++--- src/MyWebLog.Data/SQLiteData.fs | 57 ++++++++++--------- src/MyWebLog/Program.fs | 9 +-- 12 files changed, 144 insertions(+), 188 deletions(-) diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index d2e5d31..5c8082d 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -4,12 +4,9 @@ - - - - + diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 7ab5dbc..425bd8c 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -1,8 +1,8 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -23,11 +23,10 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge /// Count all top-level categories for the given web log let countTopLevel webLogId = log.LogTrace "Category.countTopLevel" - Custom.scalar + conn.customScalar $"{Document.Query.countByWebLog} AND data ->> '{parentIdField}' IS NULL" [ webLogParam webLogId ] - (fun rdr -> int (rdr.GetInt64(0))) - conn + (toCount >> int) /// Find all categories for the given web log let findByWebLog webLogId = @@ -54,9 +53,9 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') FROM {Table.Post} WHERE {Document.Query.whereByWebLog} - AND {Query.whereFieldEquals (nameof Post.Empty.Status) $"'{string Published}'"} + AND {Query.whereByField (nameof Post.Empty.Status) EQ $"'{string Published}'"} AND {catSql}""" - let! postCount = Custom.scalar query (webLogParam webLogId :: catParams) (_.GetInt64(0)) conn + let! postCount = conn.customScalar query (webLogParam webLogId :: catParams) toCount return it.Id, int postCount }) |> Task.WhenAll @@ -80,13 +79,13 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge match! findById catId webLogId with | Some cat -> // Reassign any children to the category's parent category - let! children = Count.byFieldEquals Table.Category parentIdField catId conn + let! children = conn.countByField Table.Category parentIdField EQ catId if children > 0 then - do! Update.partialByFieldEquals Table.Category parentIdField catId {| ParentId = cat.ParentId |} conn + do! conn.patchByField Table.Category parentIdField EQ catId {| ParentId = cat.ParentId |} // Delete the category off all posts where it is assigned, and the category itself let catIdField = Post.Empty.CategoryIds let! posts = - Custom.list + conn.customList $"SELECT data ->> '{Post.Empty.Id}', data -> '{catIdField}' FROM {Table.Post} WHERE {Document.Query.whereByWebLog} @@ -96,11 +95,10 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge WHERE json_each.value = @id)" [ idParam catId; webLogParam webLogId ] (fun rdr -> rdr.GetString(0), Utils.deserialize ser (rdr.GetString(1))) - conn for postId, cats in posts do - do! Update.partialById - Table.Post postId {| CategoryIds = cats |> List.filter (fun it -> it <> string catId) |} conn - do! Delete.byId Table.Category catId conn + 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 } @@ -108,7 +106,7 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge /// Save a category let save cat = log.LogTrace "Category.save" - save Table.Category cat conn + conn.save Table.Category cat /// Restore categories from a backup let restore cats = backgroundTask { diff --git a/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs index d11cd7a..b1008d3 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs @@ -222,17 +222,14 @@ module Map = let sqlParam name (value: obj) = SqliteParameter(name, value) -/// Create a document ID parameter -let idParam (key: 'TKey) = - sqlParam "@id" (string key) - /// Create a web log ID parameter let webLogParam (webLogId: WebLogId) = sqlParam "@webLogId" (string webLogId) -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite +open BitBadger.Documents.Sqlite.WithConn /// Functions for manipulating documents module Document = @@ -242,7 +239,7 @@ module Document = /// Fragment to add a web log ID condition to a WHERE clause (parameter @webLogId) let whereByWebLog = - Query.whereFieldEquals "WebLogId" "@webLogId" + Query.whereByField "WebLogId" EQ "@webLogId" /// A SELECT query to count documents for a given web log ID let countByWebLog table = @@ -250,7 +247,7 @@ module Document = /// A query to select from a table by the document's ID and its web log ID let selectByIdAndWebLog table = - $"{Query.Find.byFieldEquals table} AND {whereByWebLog}" + $"{Query.Find.byId table} AND {whereByWebLog}" /// A query to select from a table by its web log ID let selectByWebLog table = @@ -258,7 +255,7 @@ module Document = /// Count documents for the given web log ID let countByWebLog table (webLogId: WebLogId) conn = backgroundTask { - let! count = Count.byFieldEquals table "WebLogId" webLogId conn + let! count = Count.byField table "WebLogId" EQ webLogId conn return int count } @@ -268,7 +265,7 @@ module Document = /// Find documents for the given web log let findByWebLog<'TDoc> table (webLogId: WebLogId) conn = - Find.byFieldEquals<'TDoc> table "WebLogId" webLogId conn + Find.byField<'TDoc> table "WebLogId" EQ webLogId conn /// Functions to support revisions diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index ba62ea0..4427fa8 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -1,8 +1,8 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -39,11 +39,10 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = /// Get all pages for a web log (without text or revisions) let all webLogId = log.LogTrace "Page.all" - Custom.list + conn.customList $"{Query.selectFromTable Table.Page} WHERE {Document.Query.whereByWebLog} ORDER BY LOWER({titleField})" [ webLogParam webLogId ] (fun rdr -> { fromData rdr with Text = "" }) - conn /// Count all pages for the given web log let countAll webLogId = @@ -53,11 +52,10 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = /// Count all pages shown in the page list for the given web log let countListed webLogId = log.LogTrace "Page.countListed" - Custom.scalar - $"""{Document.Query.countByWebLog} AND {Query.whereFieldEquals pgListName "'true'"}""" + conn.customScalar + $"""{Document.Query.countByWebLog} AND {Query.whereByField pgListName EQ "'true'"}""" [ webLogParam webLogId ] - (fun rdr -> int (rdr.GetInt64(0))) - conn + (toCount >> int) /// Find a page by its ID (without revisions) let findById pageId webLogId = @@ -80,10 +78,9 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = log.LogTrace "Page.delete" match! findById pageId webLogId with | Some _ -> - do! Custom.nonQuery + do! conn.customNonQuery $"DELETE FROM {Table.PageRevision} WHERE page_id = @id; {Query.Delete.byId Table.Page}" [ idParam pageId ] - conn return true | None -> return false } @@ -91,23 +88,21 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = /// Find a page by its permalink for the given web log let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Page.findByPermalink" - Custom.single - $"""{Document.Query.selectByWebLog} AND {Query.whereFieldEquals linkName "@link"}""" + conn.customSingle + $"""{Document.Query.selectByWebLog} AND {Query.whereByField linkName EQ "@link"}""" [ webLogParam webLogId; SqliteParameter("@link", string permalink) ] fromData - conn /// Find the current permalink within a set of potential prior permalinks for the given web log let findCurrentPermalink (permalinks: Permalink list) webLogId = log.LogTrace "Page.findCurrentPermalink" let linkSql, linkParams = inJsonArray Table.Page (nameof Page.Empty.PriorPermalinks) "link" permalinks - Custom.single + conn.customSingle $"SELECT data ->> '{linkName}' AS permalink FROM {Table.Page} WHERE {Document.Query.whereByWebLog} AND {linkSql}" (webLogParam webLogId :: linkParams) Map.toPermalink - conn /// Get all complete pages for the given web log let findFullByWebLog webLogId = backgroundTask { @@ -120,27 +115,25 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = /// Get all listed pages for the given web log (without revisions or text) let findListed webLogId = log.LogTrace "Page.findListed" - Custom.list - $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereFieldEquals pgListName "'true'"} + conn.customList + $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField pgListName EQ "'true'"} ORDER BY LOWER({titleField})""" [ webLogParam webLogId ] (fun rdr -> { fromData rdr with Text = "" }) - conn /// Get a page of pages for the given web log (without revisions) let findPageOfPages webLogId pageNbr = log.LogTrace "Page.findPageOfPages" - Custom.list + 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) ] fromData - conn /// Save a page let save (page: Page) = backgroundTask { log.LogTrace "Page.update" let! oldPage = findFullById page.Id page.WebLogId - do! save Table.Page { page with Revisions = [] } conn + do! conn.save Table.Page { page with Revisions = [] } do! updatePageRevisions page.Id (match oldPage with Some p -> p.Revisions | None -> []) page.Revisions } @@ -155,7 +148,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = log.LogTrace "Page.updatePriorPermalinks" match! findById pageId webLogId with | Some _ -> - do! Update.partialById Table.Page pageId {| PriorPermalinks = permalinks |} conn + do! conn.patchById Table.Page pageId {| PriorPermalinks = permalinks |} return true | None -> return false } diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 5ada20c..7990818 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -1,8 +1,8 @@ namespace MyWebLog.Data.SQLite open System.Threading.Tasks -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -34,7 +34,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let postByWebLog = Document.Query.selectByWebLog Table.Post /// The SELECT statement to retrieve published posts with a web log ID parameter - let publishedPostByWebLog = $"""{postByWebLog} AND {Query.whereFieldEquals statName $"'{string Published}'"}""" + let publishedPostByWebLog = $"""{postByWebLog} AND {Query.whereByField statName EQ $"'{string Published}'"}""" /// Update a post's revisions let updatePostRevisions (postId: PostId) oldRevs newRevs = @@ -46,11 +46,10 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = /// Count posts in a status for the given web log let countByStatus (status: PostStatus) webLogId = log.LogTrace "Post.countByStatus" - Custom.scalar - $"""{Document.Query.countByWebLog} AND {Query.whereFieldEquals statName "@status"}""" + conn.customScalar + $"""{Document.Query.countByWebLog} AND {Query.whereByField statName EQ "@status"}""" [ webLogParam webLogId; SqliteParameter("@status", string status) ] - (fun rdr -> int (rdr.GetInt64(0))) - conn + (toCount >> int) /// Find a post by its ID for the given web log (excluding revisions) let findById postId webLogId = @@ -60,11 +59,10 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = /// Find a post by its permalink for the given web log (excluding revisions) let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Post.findByPermalink" - Custom.single - $"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereFieldEquals linkName "@link"}""" + conn.customSingle + $"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkName EQ "@link"}""" [ webLogParam webLogId; SqliteParameter("@link", string permalink) ] fromData - conn /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { @@ -81,13 +79,12 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = log.LogTrace "Post.delete" match! findById postId webLogId with | Some _ -> - do! Custom.nonQuery + do! conn.customNonQuery $"""DELETE FROM {Table.PostRevision} WHERE post_id = @id; DELETE FROM {Table.PostComment} - WHERE {Query.whereFieldEquals (nameof Comment.Empty.PostId) "@id"}; + WHERE {Query.whereByField (nameof Comment.Empty.PostId) EQ "@id"}; {Query.Delete.byId Table.Post}""" [ idParam postId ] - conn return true | None -> return false } @@ -96,13 +93,12 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let findCurrentPermalink (permalinks: Permalink list) webLogId = log.LogTrace "Post.findCurrentPermalink" let linkSql, linkParams = inJsonArray Table.Post (nameof Post.Empty.PriorPermalinks) "link" permalinks - Custom.single + conn.customSingle $"SELECT data ->> '{linkName}' AS permalink FROM {Table.Post} WHERE {Document.Query.whereByWebLog} AND {linkSql}" (webLogParam webLogId :: linkParams) Map.toPermalink - conn /// Get all complete posts for the given web log let findFullByWebLog webLogId = backgroundTask { @@ -116,63 +112,57 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage = log.LogTrace "Post.findPageOfCategorizedPosts" let catSql, catParams = inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId" categoryIds - Custom.list + conn.customList $"{publishedPostByWebLog} AND {catSql} ORDER BY {publishField} DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" (webLogParam webLogId :: catParams) fromData - conn /// 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 + conn.customList $"{postByWebLog} ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}' LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ webLogParam webLogId ] (fun rdr -> { fromData rdr with Text = "" }) - conn /// Get a page of published posts for the given web log (excludes revisions) let findPageOfPublishedPosts webLogId pageNbr postsPerPage = log.LogTrace "Post.findPageOfPublishedPosts" - Custom.list + conn.customList $"{publishedPostByWebLog} ORDER BY {publishField} DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ webLogParam webLogId ] fromData - conn /// 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 ] - Custom.list + conn.customList $"{publishedPostByWebLog} AND {tagSql} ORDER BY p.published_on DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" (webLogParam webLogId :: tagParams) fromData - conn /// Find the next newest and oldest post from a publish date for the given web log let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask { log.LogTrace "Post.findSurroundingPosts" let! older = - Custom.single + conn.customSingle $"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1" [ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ] fromData - conn let! newer = - Custom.single + conn.customSingle $"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1" [ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ] fromData - conn return older, newer } @@ -180,7 +170,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let save (post: Post) = backgroundTask { log.LogTrace "Post.save" let! oldPost = findFullById post.Id post.WebLogId - do! save Table.Post { post with Revisions = [] } conn + do! conn.save Table.Post { post with Revisions = [] } do! updatePostRevisions post.Id (match oldPost with Some p -> p.Revisions | None -> []) post.Revisions } @@ -194,7 +184,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let updatePriorPermalinks postId webLogId (permalinks: Permalink list) = backgroundTask { match! findById postId webLogId with | Some _ -> - do! Update.partialById Table.Post postId {| PriorPermalinks = permalinks |} conn + do! conn.patchById Table.Post postId {| PriorPermalinks = permalinks |} return true | None -> return false } diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index 0303034..50a4b04 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -1,7 +1,7 @@ namespace MyWebLog.Data.SQLite -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -20,7 +20,7 @@ type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) = log.LogTrace "TagMap.delete" match! findById tagMapId webLogId with | Some _ -> - do! Delete.byId Table.TagMap tagMapId conn + do! conn.deleteById Table.TagMap tagMapId return true | None -> return false } @@ -28,12 +28,11 @@ type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) = /// Find a tag mapping by its URL value for the given web log let findByUrlValue (urlValue: string) webLogId = log.LogTrace "TagMap.findByUrlValue" - Custom.single + conn.customSingle $"""{Document.Query.selectByWebLog Table.TagMap} - AND {Query.whereFieldEquals (nameof TagMap.Empty.UrlValue) "@urlValue"}""" + AND {Query.whereByField (nameof TagMap.Empty.UrlValue) EQ "@urlValue"}""" [ webLogParam webLogId; SqliteParameter("@urlValue", urlValue) ] fromData - conn /// Get all tag mappings for the given web log let findByWebLog webLogId = @@ -44,16 +43,15 @@ type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) = let findMappingForTags (tags: string list) webLogId = log.LogTrace "TagMap.findMappingForTags" let mapSql, mapParams = inClause $"AND data ->> '{nameof TagMap.Empty.Tag}'" "tag" id tags - Custom.list + conn.customList $"{Document.Query.selectByWebLog Table.TagMap} {mapSql}" (webLogParam webLogId :: mapParams) fromData - conn /// Save a tag mapping let save (tagMap: TagMap) = log.LogTrace "TagMap.save" - save Table.TagMap tagMap conn + conn.save Table.TagMap tagMap /// Restore tag mappings from a backup let restore tagMaps = backgroundTask { diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index f5d50a1..cb41ddc 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -1,7 +1,7 @@ namespace MyWebLog.Data.SQLite -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -25,36 +25,34 @@ type SQLiteThemeData(conn : SqliteConnection, log: ILogger) = /// Retrieve all themes (except 'admin'; excludes template text) let all () = log.LogTrace "Theme.all" - Custom.list + conn.customList $"{Query.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}" [] withoutTemplateText - conn /// Does a given theme exist? let exists (themeId: ThemeId) = log.LogTrace "Theme.exists" - Exists.byId Table.Theme themeId conn + conn.existsById Table.Theme themeId /// Find a theme by its ID let findById themeId = log.LogTrace "Theme.findById" - Find.byId Table.Theme themeId conn + conn.findById 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 conn + 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! Custom.nonQuery + do! conn.customNonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; {Query.Delete.byId Table.Theme}" [ idParam themeId ] - conn return true | None -> return false } @@ -62,7 +60,7 @@ type SQLiteThemeData(conn : SqliteConnection, log: ILogger) = /// Save a theme let save (theme: Theme) = log.LogTrace "Theme.save" - save Table.Theme theme conn + conn.save Table.Theme theme interface IThemeData with member _.All() = all () @@ -86,44 +84,41 @@ type SQLiteThemeAssetData(conn : SqliteConnection, 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) conn + conn.customList $"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 ] conn + conn.customNonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ] /// Find a theme asset by its ID let findById assetId = log.LogTrace "ThemeAsset.findById" - Custom.single + conn.customSingle $"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id AND path = @path" (assetIdParams assetId) (Map.toThemeAsset true) - conn /// Get theme assets for the given theme (excludes data) let findByTheme (themeId: ThemeId) = log.LogTrace "ThemeAsset.findByTheme" - Custom.list + conn.customList $"SELECT theme_id, path, updated_on FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ] (Map.toThemeAsset false) - conn /// Get theme assets for the given theme let findByThemeWithData (themeId: ThemeId) = log.LogTrace "ThemeAsset.findByThemeWithData" - Custom.list + conn.customList $"SELECT *, ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ] (Map.toThemeAsset true) - conn /// Save a theme asset let save (asset: ThemeAsset) = backgroundTask { log.LogTrace "ThemeAsset.save" - do! Custom.nonQuery + do! conn.customNonQuery $"INSERT INTO {Table.ThemeAsset} ( theme_id, path, updated_on, data ) VALUES ( @@ -134,14 +129,12 @@ type SQLiteThemeAssetData(conn : SqliteConnection, log: ILogger) = [ sqlParam "@updatedOn" (instantParam asset.UpdatedOn) sqlParam "@dataLength" asset.Data.Length yield! (assetIdParams asset.Id) ] - conn let! rowId = - Custom.scalar + conn.customScalar $"SELECT ROWID FROM {Table.ThemeAsset} WHERE theme_id = @id AND path = @path" (assetIdParams asset.Id) - (_.GetInt64(0)) - conn + _.GetInt64(0) use dataStream = new MemoryStream(asset.Data) use blobStream = new SqliteBlob(conn, Table.ThemeAsset, "data", rowId) do! dataStream.CopyToAsync blobStream diff --git a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs index e6bc5e0..fbc2ce9 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs @@ -1,7 +1,7 @@ namespace MyWebLog.Data.SQLite open System.IO -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -13,7 +13,7 @@ type SQLiteUploadData(conn: SqliteConnection, log: ILogger) = /// Save an uploaded file let add (upload: Upload) = backgroundTask { log.LogTrace "Upload.add" - do! Custom.nonQuery + do! conn.customNonQuery $"INSERT INTO {Table.Upload} ( id, web_log_id, path, updated_on, data ) VALUES ( @@ -24,9 +24,8 @@ type SQLiteUploadData(conn: SqliteConnection, log: ILogger) = sqlParam "@path" (string upload.Path) sqlParam "@updatedOn" (instantParam upload.UpdatedOn) sqlParam "@dataLength" upload.Data.Length ] - conn let! rowId = - Custom.scalar $"SELECT ROWID FROM {Table.Upload} WHERE id = @id" [ idParam upload.Id ] (_.GetInt64(0)) conn + 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, Table.Upload, "data", rowId) do! dataStream.CopyToAsync blobStream @@ -36,14 +35,13 @@ type SQLiteUploadData(conn: SqliteConnection, log: ILogger) = let delete (uploadId: UploadId) webLogId = backgroundTask { log.LogTrace "Upload.delete" let! upload = - Custom.single + 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) - conn match upload with | Some up -> - do! Custom.nonQuery $"DELETE FROM {Table.Upload} WHERE id = @id" [ idParam up.Id ] conn + 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" } @@ -51,29 +49,26 @@ type SQLiteUploadData(conn: SqliteConnection, log: ILogger) = /// Find an uploaded file by its path for the given web log let findByPath (path: string) webLogId = log.LogTrace "Upload.findByPath" - Custom.single + conn.customSingle $"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId AND path = @path" [ webLogParam webLogId; sqlParam "@path" path ] (Map.toUpload true) - conn /// Find all uploaded files for the given web log (excludes data) let findByWebLog webLogId = log.LogTrace "Upload.findByWebLog" - Custom.list + conn.customList $"SELECT id, web_log_id, path, updated_on FROM {Table.Upload} WHERE web_log_id = @webLogId" [ webLogParam webLogId ] (Map.toUpload false) - conn /// Find all uploaded files for the given web log let findByWebLogWithData webLogId = log.LogTrace "Upload.findByWebLogWithData" - Custom.list + conn.customList $"SELECT *, ROWID FROM {Table.Upload} WHERE web_log_id = @webLogId" [ webLogParam webLogId ] (Map.toUpload true) - conn /// Restore uploads from a backup let restore uploads = backgroundTask { diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index e308e94..a9d1d17 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -1,7 +1,7 @@ namespace MyWebLog.Data.SQLite -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -13,56 +13,55 @@ type SQLiteWebLogData(conn: SqliteConnection, log: ILogger) = /// Add a web log let add webLog = log.LogTrace "WebLog.add" - insert Table.WebLog webLog conn + conn.insert Table.WebLog webLog /// Retrieve all web logs let all () = log.LogTrace "WebLog.all" - Find.all Table.WebLog conn + conn.findAll Table.WebLog /// Delete a web log by its ID let delete webLogId = log.LogTrace "WebLog.delete" let subQuery table = - $"""(SELECT data ->> 'Id' FROM {table} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}""" + $"""(SELECT data ->> 'Id' FROM {table} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}""" 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 {Query.whereFieldEquals "WebLogId" "@webLogId"}; - DELETE FROM {Table.Page} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; - DELETE FROM {Table.Category} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; - DELETE FROM {Table.TagMap} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; - DELETE FROM {Table.Upload} WHERE web_log_id = @id; - DELETE FROM {Table.WebLogUser} WHERE {Query.whereFieldEquals "WebLogId" "@webLogId"}; + DELETE FROM {Table.Post} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; + DELETE FROM {Table.Page} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; + DELETE FROM {Table.Category} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; + DELETE FROM {Table.TagMap} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; + DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId; + DELETE FROM {Table.WebLogUser} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}""" [ webLogParam webLogId ] - conn /// Find a web log by its host (URL base) let findByHost (url: string) = log.LogTrace "WebLog.findByHost" - Find.firstByFieldEquals Table.WebLog (nameof WebLog.Empty.UrlBase) url conn + conn.findFirstByField Table.WebLog (nameof WebLog.Empty.UrlBase) EQ url /// Find a web log by its ID let findById webLogId = log.LogTrace "WebLog.findById" - Find.byId Table.WebLog webLogId conn + conn.findById Table.WebLog webLogId /// Update redirect rules for a web log let updateRedirectRules (webLog: WebLog) = log.LogTrace "WebLog.updateRedirectRules" - Update.partialById Table.WebLog webLog.Id {| RedirectRules = webLog.RedirectRules |} conn + conn.patchById Table.WebLog webLog.Id {| RedirectRules = webLog.RedirectRules |} /// Update RSS options for a web log let updateRssOptions (webLog: WebLog) = log.LogTrace "WebLog.updateRssOptions" - Update.partialById Table.WebLog webLog.Id {| Rss = webLog.Rss |} conn + conn.patchById Table.WebLog webLog.Id {| Rss = webLog.Rss |} /// Update settings for a web log let updateSettings (webLog: WebLog) = log.LogTrace "WebLog.updateSettings" - Update.full Table.WebLog webLog.Id webLog conn + conn.updateById Table.WebLog webLog.Id webLog interface IWebLogData with member _.Add webLog = add webLog diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 35771e7..61cae3b 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -1,7 +1,7 @@ namespace MyWebLog.Data.SQLite -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -20,12 +20,12 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = log.LogTrace "WebLogUser.delete" match! findById userId webLogId with | Some _ -> - let! pageCount = Count.byFieldEquals Table.Page (nameof Page.Empty.AuthorId) (string userId) conn - let! postCount = Count.byFieldEquals Table.Post (nameof Post.Empty.AuthorId) (string userId) conn + let! pageCount = conn.countByField Table.Page (nameof Page.Empty.AuthorId) EQ (string userId) + let! postCount = conn.countByField Table.Post (nameof Post.Empty.AuthorId) EQ (string userId) if pageCount + postCount > 0 then return Error "User has pages or posts; cannot delete" else - do! Delete.byId Table.WebLogUser userId conn + do! conn.deleteById Table.WebLogUser userId return Ok true | None -> return Error "User does not exist" } @@ -33,12 +33,11 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = /// Find a user by their e-mail address for the given web log let findByEmail (email: string) webLogId = log.LogTrace "WebLogUser.findByEmail" - Custom.single + conn.customSingle $"""{Document.Query.selectByWebLog Table.WebLogUser} - AND {Query.whereFieldEquals (nameof WebLogUser.Empty.Email) "@email"}""" + AND {Query.whereByField (nameof WebLogUser.Empty.Email) EQ "@email"}""" [ webLogParam webLogId; sqlParam "@email" email ] fromData - conn /// Get all users for the given web log let findByWebLog webLogId = backgroundTask { @@ -51,18 +50,17 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = let findNames webLogId (userIds: WebLogUserId list) = log.LogTrace "WebLogUser.findNames" let nameSql, nameParams = inClause "AND data ->> 'Id'" "id" string userIds - Custom.list + conn.customList $"{Document.Query.selectByWebLog Table.WebLogUser} {nameSql}" (webLogParam webLogId :: nameParams) (fun rdr -> let user = fromData rdr { Name = string user.Id; Value = user.DisplayName }) - conn /// Save a user let save user = log.LogTrace "WebLogUser.update" - save Table.WebLogUser user conn + conn.save Table.WebLogUser user /// Restore users from a backup let restore users = backgroundTask { @@ -74,7 +72,7 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = let setLastSeen userId webLogId = backgroundTask { log.LogTrace "WebLogUser.setLastSeen" match! findById userId webLogId with - | Some _ -> do! Update.partialById Table.WebLogUser userId {| LastSeenOn = Noda.now () |} conn + | Some _ -> do! conn.patchById Table.WebLogUser userId {| LastSeenOn = Noda.now () |} | None -> () } diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 4386d09..e312395 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -1,8 +1,8 @@ namespace MyWebLog.Data open System.Threading.Tasks -open BitBadger.Sqlite.FSharp.Documents -open BitBadger.Sqlite.FSharp.Documents.WithConn +open BitBadger.Documents +open BitBadger.Documents.Sqlite open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging open MyWebLog @@ -16,13 +16,13 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria /// Create tables (and their associated indexes) if they do not exist let ensureTables () = backgroundTask { - let! tables = Custom.list "SELECT name FROM sqlite_master WHERE type = 'table'" [] (_.GetString(0)) conn + 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 = - $"{Definition.createTable table}; {Definition.createKey table}" + $"{Query.Definition.ensureTable table}; {Query.Definition.ensureKey table}" let tasks = seq { @@ -41,21 +41,23 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria // Category table if needsTable Table.Category then - $"{jsonTable Table.Category}; - CREATE INDEX idx_{Table.Category}_web_log ON {Table.Category} ((data ->> 'WebLogId'))" + $"""{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}; - CREATE INDEX idx_{Table.WebLogUser}_email - ON {Table.WebLogUser} ((data ->> 'WebLogId'), (data ->> 'Email'))" + $"""{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}; - CREATE INDEX idx_{Table.Page}_author ON {Table.Page} ((data ->> 'AuthorId')); - CREATE INDEX idx_{Table.Page}_permalink - ON {Table.Page} ((data ->> 'WebLogId'), (data ->> 'Permalink'))" + $"""{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, @@ -65,12 +67,14 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria // Post tables if needsTable Table.Post then - $"{jsonTable Table.Post}; - CREATE INDEX idx_{Table.Post}_author ON {Table.Post} ((data ->> 'AuthorId')); - CREATE INDEX idx_{Table.Post}_status - ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Status'), (data ->> 'UpdatedOn')); - CREATE INDEX idx_{Table.Post}_permalink - ON {Table.Post} ((data ->> 'WebLogId'), (data ->> 'Permalink'))" + $"""{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} ( @@ -79,13 +83,14 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria revision_text TEXT NOT NULL, PRIMARY KEY (post_id, as_of))" if needsTable Table.PostComment then - $"{jsonTable Table.PostComment}; - CREATE INDEX idx_{Table.PostComment}_post ON {Table.PostComment} ((data ->> 'PostId'))" + $"""{jsonTable Table.PostComment}; + {Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ]}""" // Tag map table if needsTable Table.TagMap then - $"{jsonTable Table.TagMap}; - CREATE INDEX idx_{Table.TagMap}_tag ON {Table.TagMap} ((data ->> 'WebLogId'), (data ->> 'UrlValue'))" + $"""{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 @@ -104,7 +109,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria } |> Seq.map (fun sql -> log.LogInformation $"""Creating {(sql.Replace("IF NOT EXISTS ", "").Split ' ')[2]} table...""" - Custom.nonQuery sql [] conn) + conn.customNonQuery sql []) let! _ = Task.WhenAll tasks () @@ -112,7 +117,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria /// Set the database version to the specified version let setDbVersion version = - Custom.nonQuery $"DELETE FROM {Table.DbVersion}; INSERT INTO {Table.DbVersion} VALUES ('%s{version}')" [] conn + 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 { @@ -467,6 +472,6 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria member _.StartUp () = backgroundTask { do! ensureTables () - let! version = Custom.single $"SELECT id FROM {Table.DbVersion}" [] (_.GetString(0)) conn + let! version = conn.customSingle $"SELECT id FROM {Table.DbVersion}" [] _.GetString(0) do! migrate version } diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index e8c7380..884fe55 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -56,9 +56,6 @@ open MyWebLog.Data open Newtonsoft.Json open Npgsql -// The SQLite document library -module Sqlite = BitBadger.Sqlite.FSharp.Documents - /// Logic to obtain a data connection and implementation based on configured values module DataImplementation = @@ -176,11 +173,7 @@ let main args = | :? SQLiteData -> // ADO.NET connections are designed to work as per-request instantiation let cfg = sp.GetRequiredService() - let _ = - builder.Services.AddScoped(fun sp -> - let conn = Sqlite.Configuration.dbConn () - conn.OpenAsync() |> Async.AwaitTask |> Async.RunSynchronously - conn) + let _ = builder.Services.AddScoped(fun sp -> Sqlite.Configuration.dbConn ()) let _ = builder.Services.AddScoped() // Use SQLite for caching as well let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" -- 2.45.1 From dee2222eb1e8df64a022e52ff2e4b5284506c730 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 31 Dec 2023 14:08:41 -0500 Subject: [PATCH 030/123] Register serliazer for SQLite --- src/MyWebLog.Data/PostgresData.fs | 6 +----- src/MyWebLog.Data/SQLiteData.fs | 4 +++- src/MyWebLog.Data/Utils.fs | 10 ++++++++++ 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index b35ec62..b332065 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -14,11 +14,7 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = /// Create any needed tables let ensureTables () = backgroundTask { // Set up the PostgreSQL document store - Configuration.useSerializer - { new IDocumentSerializer with - member _.Serialize<'T>(it: 'T) : string = Utils.serialize ser it - member _.Deserialize<'T>(it: string) : 'T = Utils.deserialize ser it - } + Configuration.useSerializer (Utils.createDocumentSerializer ser) let! tables = Custom.list "SELECT tablename FROM pg_tables WHERE schemaname = 'public'" [] diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index e312395..80b1ac4 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -15,7 +15,9 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria /// 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 = diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index f26ff02..228cb97 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -50,6 +50,16 @@ let serialize<'T> ser (item: 'T) = 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 + } + + open Microsoft.Extensions.Logging /// Log a migration step -- 2.45.1 From b69b6c37a4b9ba25419d48b5c1faf1e28de144b4 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 3 Jan 2024 22:29:27 -0500 Subject: [PATCH 031/123] WIP on testing SQLite data store --- src/MyWebLog.Data/PostgresData.fs | 10 +++------- src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs | 10 +++++----- src/MyWebLog.Data/SQLite/SQLiteHelpers.fs | 6 +++--- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 4 ++-- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 2 +- src/MyWebLog.Data/SQLite/SQLiteThemeData.fs | 2 +- src/MyWebLog.Domain/SupportTypes.fs | 2 +- src/MyWebLog/Handlers/Admin.fs | 2 +- src/MyWebLog/Handlers/Routes.fs | 2 +- src/MyWebLog/Program.fs | 2 +- 10 files changed, 19 insertions(+), 23 deletions(-) diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index b332065..6bfce4e 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -17,16 +17,13 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = Configuration.useSerializer (Utils.createDocumentSerializer ser) let! tables = - Custom.list "SELECT tablename FROM pg_tables WHERE schemaname = 'public'" [] - (fun row -> row.string "tablename") + Custom.list + "SELECT tablename FROM pg_tables WHERE schemaname = 'public'" [] (fun row -> row.string "tablename") let needsTable table = not (List.contains table tables) - // Create a document table - let mutable isNew = false let sql = seq { // Theme tables if needsTable Table.Theme then - isNew <- true Query.Definition.ensureTable Table.Theme Query.Definition.ensureKey Table.Theme if needsTable Table.ThemeAsset then @@ -152,8 +149,7 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = " - 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 {url} v2-rc2.{slug}.json") - ] + yield! webLogs |> List.map (fun (url, slug) -> $"./myWebLog backup {url} v2-rc2.{slug}.json") ] |> String.concat "\n" |> log.LogWarning diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 425bd8c..e1fb304 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -24,7 +24,7 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge let countTopLevel webLogId = log.LogTrace "Category.countTopLevel" conn.customScalar - $"{Document.Query.countByWebLog} AND data ->> '{parentIdField}' IS NULL" + $"{Document.Query.countByWebLog Table.Category} AND data ->> '{parentIdField}' IS NULL" [ webLogParam webLogId ] (toCount >> int) @@ -79,11 +79,11 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge match! findById catId webLogId with | Some cat -> // Reassign any children to the category's parent category - let! children = conn.countByField Table.Category parentIdField EQ catId + let! children = conn.countByField Table.Category parentIdField EQ (string catId) if children > 0 then - do! conn.patchByField Table.Category parentIdField EQ catId {| ParentId = cat.ParentId |} + do! conn.patchByField Table.Category parentIdField EQ (string catId) {| ParentId = cat.ParentId |} // Delete the category off all posts where it is assigned, and the category itself - let catIdField = Post.Empty.CategoryIds + let catIdField = nameof Post.Empty.CategoryIds let! posts = conn.customList $"SELECT data ->> '{Post.Empty.Id}', data -> '{catIdField}' @@ -94,7 +94,7 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge FROM json_each({Table.Post}.data -> '{catIdField}') WHERE json_each.value = @id)" [ idParam catId; webLogParam webLogId ] - (fun rdr -> rdr.GetString(0), Utils.deserialize ser (rdr.GetString(1))) + (fun rdr -> rdr.GetString 0, Utils.deserialize 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) |} diff --git a/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs index b1008d3..07e23e7 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs @@ -255,7 +255,7 @@ module Document = /// Count documents for the given web log ID let countByWebLog table (webLogId: WebLogId) conn = backgroundTask { - let! count = Count.byField table "WebLogId" EQ webLogId conn + let! count = Count.byField table "WebLogId" EQ (string webLogId) conn return int count } @@ -265,7 +265,7 @@ module Document = /// Find documents for the given web log let findByWebLog<'TDoc> table (webLogId: WebLogId) conn = - Find.byField<'TDoc> table "WebLogId" EQ webLogId conn + Find.byField<'TDoc> table "WebLogId" EQ (string webLogId) conn /// Functions to support revisions @@ -302,6 +302,6 @@ module Revisions = for addRev in toAdd do do! Custom.nonQuery $"INSERT INTO {revTable} VALUES (@id, @asOf, @text)" - [ idParam key; sqlParam "asOf" (instantParam addRev.AsOf); sqlParam "@text" addRev.Text ] + [ idParam key; sqlParam "asOf" (instantParam addRev.AsOf); sqlParam "@text" (string addRev.Text) ] conn } diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index 4427fa8..fd390de 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -53,7 +53,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = let countListed webLogId = log.LogTrace "Page.countListed" conn.customScalar - $"""{Document.Query.countByWebLog} AND {Query.whereByField pgListName EQ "'true'"}""" + $"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField pgListName EQ "'true'"}""" [ webLogParam webLogId ] (toCount >> int) @@ -89,7 +89,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Page.findByPermalink" conn.customSingle - $"""{Document.Query.selectByWebLog} AND {Query.whereByField linkName EQ "@link"}""" + $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkName EQ "@link"}""" [ webLogParam webLogId; SqliteParameter("@link", string permalink) ] fromData diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 7990818..e5ab713 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -47,7 +47,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let countByStatus (status: PostStatus) webLogId = log.LogTrace "Post.countByStatus" conn.customScalar - $"""{Document.Query.countByWebLog} AND {Query.whereByField statName EQ "@status"}""" + $"""{Document.Query.countByWebLog Table.Post} AND {Query.whereByField statName EQ "@status"}""" [ webLogParam webLogId; SqliteParameter("@status", string status) ] (toCount >> int) diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index cb41ddc..7ff48f3 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -122,7 +122,7 @@ type SQLiteThemeAssetData(conn : SqliteConnection, log: ILogger) = $"INSERT INTO {Table.ThemeAsset} ( theme_id, path, updated_on, data ) VALUES ( - @themeId, @path, @updatedOn, ZEROBLOB(@dataLength) + @id, @path, @updatedOn, ZEROBLOB(@dataLength) ) ON CONFLICT (theme_id, path) DO UPDATE SET updated_on = @updatedOn, data = ZEROBLOB(@dataLength)" diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 8a9c98b..eab1488 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -13,7 +13,7 @@ module private Helpers = /// 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('+', '-')[..22] + Convert.ToBase64String(Guid.NewGuid().ToByteArray()).Replace('/', '_').Replace('+', '-')[..21] /// Pipeline with most extensions enabled let markdownPipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build() diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 136d793..f535f84 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -443,7 +443,7 @@ module Theme = let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace(" ", "-") if themeName.EndsWith "-theme" then if Regex.IsMatch(themeName, """^[a-z0-9\-]+$""") then - Ok(ThemeId(themeName[..themeName.Length - 6])) + Ok(ThemeId(themeName[..themeName.Length - 7])) else Error $"Theme ID {fileName} is invalid" else Error "Theme .zip file name must end in \"-theme.zip\"" diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index d103a00..996553c 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -18,7 +18,7 @@ module CatchAll = let textLink = let extra = webLog.ExtraPath let url = string ctx.Request.Path - (if extra = "" then url else url[..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}") diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 884fe55..382a013 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -79,7 +79,7 @@ module DataImplementation = let createSQLite connStr : IData = Sqlite.Configuration.useConnectionString connStr let log = sp.GetRequiredService>() - let conn = new SqliteConnection(connStr) + let conn = Sqlite.Configuration.dbConn () log.LogInformation $"Using SQLite database {conn.DataSource}" SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault())) -- 2.45.1 From 5a3d9f05f86fe472ae95d78412f7bb0760aa11d3 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 4 Jan 2024 17:33:41 -0500 Subject: [PATCH 032/123] Rework migration; add PG 2.1 changes --- src/MyWebLog.Data/PostgresData.fs | 79 ++++++++++++++++++------------ src/MyWebLog.Data/RethinkDbData.fs | 14 +++--- src/MyWebLog.Data/SQLiteData.fs | 25 ++++------ src/MyWebLog.Data/Utils.fs | 35 ++++++++++--- 4 files changed, 94 insertions(+), 59 deletions(-) diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs index 6bfce4e..43d9bef 100644 --- a/src/MyWebLog.Data/PostgresData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -77,8 +77,8 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = Table.Post "status" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ] - $"CREATE INDEX post_category_idx ON {Table.Post} USING GIN ((data['{nameof Post.Empty.CategoryIds}']))" - $"CREATE INDEX post_tag_idx ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))" + $"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, @@ -104,13 +104,13 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = path TEXT NOT NULL, updated_on TIMESTAMPTZ NOT NULL, data BYTEA NOT NULL)" - $"CREATE INDEX upload_web_log_idx ON {Table.Upload} (web_log_id)" - $"CREATE INDEX upload_path_idx ON {Table.Upload} (web_log_id, path)" + $"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.currentDbVersion}')" + $"INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')" } Configuration.dataSource () @@ -134,35 +134,54 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = /// Migrate from v2-rc2 to v2 (manual migration required) let migrateV2Rc2ToV2 () = backgroundTask { - Utils.logMigrationStep log "v2-rc2 to v2" "Requires user action" - let! webLogs = - Configuration.dataSource () - |> Sql.fromDataSource - |> Sql.query $"SELECT url_base, slug FROM {Table.WebLog}" - |> Sql.executeAsync (fun row -> row.string "url_base", row.string "slug") - - [ "** MANUAL DATABASE UPGRADE REQUIRED **"; "" - "The data structure for PostgreSQL changed significantly between v2-rc2 and v2." - "To migrate your data:" - " - Use a v2-rc2 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 {url} v2-rc2.{slug}.json") ] - |> String.concat "\n" - |> log.LogWarning - - log.LogCritical "myWebLog will now exit" - exit 1 + 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 let migrateV2ToV2point1 () = backgroundTask { - Utils.logMigrationStep log "v2 to v2.1" "Adding empty redirect rule set to all weblogs" + let migration = "v2 to v2.1" + Utils.Migration.logStep log migration "Adding empty redirect rule set to all weblogs" do! Custom.nonQuery $"""UPDATE {Table.WebLog} SET data = data + '{{ "RedirectRules": [] }}'::json""" [] - Utils.logMigrationStep log "v2 to v2.1" "Setting database to version 2.1" + 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 "Dropping old ID columns" + do! Custom.nonQuery (tables |> List.map (sprintf "ALTER TABLE %s DROP COLUMN id") |> String.concat "; ") [] + + Utils.Migration.logStep log migration "Adjusting indexes" + let toDrop = [ "page_web_log_idx"; "post_web_log_idx" ] + do! Custom.nonQuery (toDrop |> List.map (sprintf "DROP INDEX %s") |> String.concat "; ") [] + + let toRename = + [ "idx_category", "idx_category_document" + "idx_tag_map", "idx_tag_map_document" + "idx_web_log", "idx_web_log_document" + "idx_web_log_user", "idx_web_log_user_document" + "page_author_idx", "idx_page_author" + "page_permalink_idx", "idx_page_permalink" + "post_author_idx", "idx_post_author" + "post_status_idx", "idx_post_status" + "post_permalink_idx", "idx_post_permalink" + "post_category_idx", "idx_post_category" + "post_tag_idx", "idx_post_tag" + "post_comment_post_idx", "idx_post_comment_post" + "upload_web_log_idx", "idx_upload_web_log" + "upload_path_idx", "idx_upload_path" ] + do! Custom.nonQuery + (toRename + |> List.map (fun (oldName, newName) -> $"ALTER INDEX {oldName} RENAME TO {newName}") + |> String.concat "; ") + [] + + Utils.Migration.logStep log migration "Setting database to version 2.1" do! setDbVersion "v2.1" } @@ -178,9 +197,9 @@ type PostgresData(log: ILogger, ser: JsonSerializer) = do! migrateV2ToV2point1 () v <- "v2.1" - if v <> "v2.1" then - log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" - do! setDbVersion Utils.currentDbVersion + if v <> Utils.Migration.currentDbVersion then + log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}" + do! setDbVersion Utils.Migration.currentDbVersion } interface IData with diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 59bf934..4ab4294 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -207,7 +207,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger obj ] write; withRetryOnce; ignoreResult conn } - Utils.logMigrationStep log "v2 to v2.1" "Setting database version to v2.1" + Utils.Migration.logStep log "v2 to v2.1" "Setting database version to v2.1" do! setDbVersion "v2.1" } @@ -250,9 +250,9 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger "v2.1" then - log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" - do! setDbVersion Utils.currentDbVersion + 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 diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 80b1ac4..33fb56b 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -18,7 +18,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria Configuration.useSerializer (Utils.createDocumentSerializer ser) - let! tables = conn.customList "SELECT name FROM sqlite_master WHERE type = 'table'" [] _.GetString(0) + let! tables = conn.customList "SELECT name FROM sqlite_master WHERE type = 'table'" [] _.GetString(0) let needsTable table = not (List.contains table tables) @@ -107,7 +107,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria // Database version table if needsTable Table.DbVersion then $"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY); - INSERT INTO {Table.DbVersion} VALUES ('v2.1')" + INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')" } |> Seq.map (fun sql -> log.LogInformation $"""Creating {(sql.Replace("IF NOT EXISTS ", "").Split ' ')[2]} table...""" @@ -123,7 +123,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria /// Implement the changes between v2-rc1 and v2-rc2 let migrateV2Rc1ToV2Rc2 () = backgroundTask { - let logStep = Utils.logMigrationStep log "v2-rc1 to v2-rc2" + 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() logStep "Adding new columns" @@ -418,20 +418,15 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria /// Migrate from v2-rc2 to v2 let migrateV2Rc2ToV2 () = backgroundTask { - Utils.logMigrationStep log "v2-rc2 to v2" "Setting database version; no migration required" + 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 { - // FIXME: This will be a backup/restore scenario, as we're changing to documents for most tables - Utils.logMigrationStep log "v2 to v2.1" "Adding redirect rules to web_log table" - use cmd = conn.CreateCommand() - cmd.CommandText <- "ALTER TABLE web_log ADD COLUMN redirect_rules TEXT NOT NULL DEFAULT '[]'" - do! write cmd - - Utils.logMigrationStep log "v2 to v2.1" "Setting database version to v2.1" - do! setDbVersion "v2.1" + 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 data among versions (up only) @@ -450,9 +445,9 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria do! migrateV2ToV2point1 () v <- "v2.1" - if v <> "v2.1" then - log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" - do! setDbVersion Utils.currentDbVersion + 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 diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index 228cb97..eb87162 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -5,9 +5,6 @@ module internal MyWebLog.Data.Utils open MyWebLog open MyWebLog.ViewModels -/// The current database version -let currentDbVersion = "v2.1" - /// Create a category hierarchy from the given list of categories let rec orderByHierarchy (cats: Category list) parentId slugBase parentNames = seq { for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do @@ -59,9 +56,33 @@ let createDocumentSerializer ser = member _.Deserialize<'T>(it: string) : 'T = deserialize ser it } +/// Data migration utilities +module Migration = + + open Microsoft.Extensions.Logging -open Microsoft.Extensions.Logging + /// The current database version + let currentDbVersion = "v2.1" -/// Log a migration step -let logMigrationStep<'T> (log: ILogger<'T>) migration message = - log.LogInformation $"Migrating %s{migration}: %s{message}" + /// 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 + \ No newline at end of file -- 2.45.1 From 3226f882a3e44497edb60fd629b58d0905c4f917 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 5 Jan 2024 17:32:38 -0500 Subject: [PATCH 033/123] Implement /data and /themes directories (#38) This will allow volumes to be mounted for persistent data/themes --- .gitignore | 2 +- src/Dockerfile | 9 +++++---- src/MyWebLog/Handlers/Admin.fs | 4 ++-- src/MyWebLog/Program.fs | 13 ++++++++----- src/sqlite.Dockerfile | 9 +++++---- 5 files changed, 21 insertions(+), 16 deletions(-) diff --git a/.gitignore b/.gitignore index 4a0e7bf..1f86ad5 100644 --- a/.gitignore +++ b/.gitignore @@ -265,4 +265,4 @@ src/MyWebLog/wwwroot/img/bit-badger src/MyWebLog/appsettings.Production.json # SQLite database files -src/MyWebLog/*.db* +src/MyWebLog/data/*.db* diff --git a/src/Dockerfile b/src/Dockerfile index d05e417..48fd7e8 100644 --- a/src/Dockerfile +++ b/src/Dockerfile @@ -1,4 +1,4 @@ -FROM mcr.microsoft.com/dotnet/sdk:7.0-alpine AS build +FROM mcr.microsoft.com/dotnet/sdk:8.0-alpine AS build WORKDIR /mwl COPY ./MyWebLog.sln ./ COPY ./Directory.Build.props ./ @@ -9,7 +9,7 @@ RUN dotnet restore COPY . ./ WORKDIR /mwl/MyWebLog -RUN dotnet publish -f net7.0 -c Release -r linux-x64 --no-self-contained -p:PublishSingleFile=false +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 @@ -19,12 +19,13 @@ RUN zip default-theme.zip ./default-theme/* COPY ./admin-theme ./admin-theme/ RUN zip admin-theme.zip ./admin-theme/* -FROM mcr.microsoft.com/dotnet/aspnet:7.0-alpine as final +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/net7.0/linux-x64/publish/ ./ +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" ] diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index f535f84..91904fd 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -482,7 +482,7 @@ module Theme = do! ThemeAssetCache.refreshTheme themeId data TemplateCache.invalidateTheme themeId // Save the .zip file - use file = new FileStream($"{themeId}-theme.zip", FileMode.Create) + use file = new FileStream($"./themes/{themeId}-theme.zip", FileMode.Create) do! themeFile.CopyToAsync file do! addMessage ctx { UserMessage.Success with @@ -517,7 +517,7 @@ module Theme = | _ -> match! data.Theme.Delete (ThemeId themeId) with | true -> - let zippedTheme = $"{themeId}-theme.zip" + let zippedTheme = $"./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 diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 382a013..d9918f1 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -98,7 +98,7 @@ module DataImplementation = log.LogInformation $"Using PostgreSQL database {conn.Database}" PostgresData(log, Json.configure (JsonSerializer.CreateDefault())) else - createSQLite "Data Source=./myweblog.db;Cache=Shared" + createSQLite "Data Source=./data/myweblog.db;Cache=Shared" open System.Threading.Tasks @@ -176,7 +176,7 @@ let main args = let _ = builder.Services.AddScoped(fun sp -> Sqlite.Configuration.dbConn ()) let _ = builder.Services.AddScoped() // Use SQLite for caching as well - let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" + let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./data/session.db" let _ = builder.Services.AddSqliteCache(fun o -> o.CachePath <- cachePath) () | :? PostgresData as postgres -> @@ -214,9 +214,12 @@ let main args = printfn $"""Unrecognized command "{it}" - valid commands are:""" showHelp () | None -> task { - // Load all themes in the application directory - for themeFile in Directory.EnumerateFiles(".", "*-theme.zip") do - do! Maintenance.loadTheme [| ""; themeFile |] app.Services + // 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 + if Directory.Exists "./themes" then + for themeFile in Directory.EnumerateFiles("./themes", "*-theme.zip") do + do! Maintenance.loadTheme [| ""; themeFile |] app.Services let _ = app.UseForwardedHeaders() diff --git a/src/sqlite.Dockerfile b/src/sqlite.Dockerfile index cf71ceb..68b895f 100644 --- a/src/sqlite.Dockerfile +++ b/src/sqlite.Dockerfile @@ -1,4 +1,4 @@ -FROM mcr.microsoft.com/dotnet/sdk:7.0 AS build +FROM mcr.microsoft.com/dotnet/sdk:8.0 AS build WORKDIR /mwl COPY ./MyWebLog.sln ./ COPY ./Directory.Build.props ./ @@ -9,7 +9,7 @@ RUN dotnet restore COPY . ./ WORKDIR /mwl/MyWebLog -RUN dotnet publish -f net7.0 -c Release -r linux-x64 +RUN dotnet publish -f net8.0 -c Release -r linux-x64 FROM alpine AS theme RUN apk add --no-cache zip @@ -19,10 +19,11 @@ RUN zip default-theme.zip ./default-theme/* COPY ./admin-theme ./admin-theme/ RUN zip admin-theme.zip ./admin-theme/* -FROM mcr.microsoft.com/dotnet/aspnet:7.0 as final +FROM mcr.microsoft.com/dotnet/aspnet:8.0 as final WORKDIR /app -COPY --from=build /mwl/MyWebLog/bin/Release/net7.0/linux-x64/publish/ ./ +COPY --from=build /mwl/MyWebLog/bin/Release/net8.0/linux-x64/publish/ ./ COPY --from=theme /themes/*.zip /app/ +RUN mkdir data themes EXPOSE 80 CMD [ "/app/MyWebLog" ] -- 2.45.1 From 75e13a5999e86e0512164322ff49e7c1be4ebb91 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 5 Jan 2024 18:57:06 -0500 Subject: [PATCH 034/123] Add chapters waypoint flag (#6) --- src/MyWebLog.Domain/SupportTypes.fs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index eab1488..c424dad 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -227,6 +227,9 @@ type Episode = { /// 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 @@ -264,6 +267,7 @@ type Episode = { Chapters = None ChapterFile = None ChapterType = None + ChapterWaypoints = None TranscriptUrl = None TranscriptType = None TranscriptLang = None -- 2.45.1 From 2c052c18139433afb1c09652706180324c43716c Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 6 Jan 2024 17:04:05 -0500 Subject: [PATCH 035/123] Add test project - Create /data directory if necessary (#38) --- src/MyWebLog.Data/SQLiteData.fs | 1 + src/MyWebLog.Domain/ViewModels.fs | 5 + src/MyWebLog.Tests/Domain.fs | 119 +++++++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 20 ++++ src/MyWebLog.Tests/Program.fs | 9 ++ src/MyWebLog.sln | 6 ++ src/MyWebLog/Program.fs | 3 +- 7 files changed, 162 insertions(+), 1 deletion(-) create mode 100644 src/MyWebLog.Tests/Domain.fs create mode 100644 src/MyWebLog.Tests/MyWebLog.Tests.fsproj create mode 100644 src/MyWebLog.Tests/Program.fs diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 33fb56b..52f6de2 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -214,6 +214,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria |> Option.map (Utils.deserialize 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 diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index db7f8d8..3b8a761 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -656,6 +656,9 @@ type EditPostModel = { /// The type of the chapter file (optional; defaults to application/json+chapters if chapterFile is provided) ChapterType: string + /// Whether the chapter file (or chapters) contains/contain waypoints + ContainsWaypoints: bool + /// The URL for the transcript (may be permalink; optional) TranscriptUrl: string @@ -714,6 +717,7 @@ type EditPostModel = { Explicit = defaultArg (episode.Explicit |> Option.map string) "" ChapterFile = defaultArg episode.ChapterFile "" ChapterType = defaultArg episode.ChapterType "" + ContainsWaypoints = defaultArg episode.ChapterWaypoints false TranscriptUrl = defaultArg episode.TranscriptUrl "" TranscriptType = defaultArg episode.TranscriptType "" TranscriptLang = defaultArg episode.TranscriptLang "" @@ -775,6 +779,7 @@ type EditPostModel = { Chapters = match post.Episode with Some e -> e.Chapters | None -> None ChapterFile = noneIfBlank this.ChapterFile ChapterType = noneIfBlank this.ChapterType + ChapterWaypoints = if this.ContainsWaypoints then Some true else None TranscriptUrl = noneIfBlank this.TranscriptUrl TranscriptType = noneIfBlank this.TranscriptType TranscriptLang = noneIfBlank this.TranscriptLang diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs new file mode 100644 index 0000000..84278ae --- /dev/null +++ b/src/MyWebLog.Tests/Domain.fs @@ -0,0 +1,119 @@ +module Domain + +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 "\"Author\" succeeds" { + Expect.equal Author (AccessLevel.Parse "Author") "Author not parsed correctly" + } + test "\"Editor\" succeeds" { + Expect.equal Editor (AccessLevel.Parse "Editor") "Editor not parsed correctly" + } + test "\"WebLogAdmin\" succeeds" { + Expect.equal WebLogAdmin (AccessLevel.Parse "WebLogAdmin") "WebLogAdmin not parsed correctly" + } + test "\"Administrator\" succeeds" { + Expect.equal Administrator (AccessLevel.Parse "Administrator") "Administrator not parsed correctly" + } + test "fails when given an unrecognized value" { + Expect.throwsT + (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" + } + ] + ] + +/// All tests for the Domain namespace +let all = testList "Domain" [ nodaTests; accessLevelTests ] diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj new file mode 100644 index 0000000..1cae610 --- /dev/null +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -0,0 +1,20 @@ + + + + Exe + + + + + + + + + + + + + + + + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs new file mode 100644 index 0000000..5a5a4be --- /dev/null +++ b/src/MyWebLog.Tests/Program.fs @@ -0,0 +1,9 @@ +open Expecto + +let allTests = + testList + "MyWebLog" + [ Domain.all ] + +[] +let main args = runTestsWithCLIArgs [] args allTests diff --git a/src/MyWebLog.sln b/src/MyWebLog.sln index a594b6e..973bd50 100644 --- a/src/MyWebLog.sln +++ b/src/MyWebLog.sln @@ -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 diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index d9918f1..293fb17 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -50,6 +50,7 @@ type RedirectRuleMiddleware(next: RequestDelegate, log: ILogger ignore createSQLite "Data Source=./data/myweblog.db;Cache=Shared" @@ -122,7 +124,6 @@ let showHelp () = Task.FromResult() -open System.IO open BitBadger.AspNetCore.CanonicalDomains open Giraffe open Giraffe.EndpointRouting -- 2.45.1 From cac1174504ab11c64436264f0b88a2d56b0da415 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 6 Jan 2024 18:04:43 -0500 Subject: [PATCH 036/123] Add CommentStatus and ExplicitRating tests --- src/MyWebLog.Tests/Domain.fs | 77 +++++++++++++++++++++++++++++++++--- 1 file changed, 72 insertions(+), 5 deletions(-) diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index 84278ae..b97a0e4 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -32,16 +32,16 @@ let nodaTests = let accessLevelTests = testList "AccessLevel" [ testList "Parse" [ - test "\"Author\" succeeds" { + test "succeeds for \"Author\"" { Expect.equal Author (AccessLevel.Parse "Author") "Author not parsed correctly" } - test "\"Editor\" succeeds" { + test "succeeds for \"Editor\"" { Expect.equal Editor (AccessLevel.Parse "Editor") "Editor not parsed correctly" } - test "\"WebLogAdmin\" succeeds" { + test "succeeds for \"WebLogAdmin\"" { Expect.equal WebLogAdmin (AccessLevel.Parse "WebLogAdmin") "WebLogAdmin not parsed correctly" } - test "\"Administrator\" succeeds" { + test "succeeds for \"Administrator\"" { Expect.equal Administrator (AccessLevel.Parse "Administrator") "Administrator not parsed correctly" } test "fails when given an unrecognized value" { @@ -115,5 +115,72 @@ let accessLevelTests = ] ] +/// 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 + (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" + } + ] + ] + +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 + (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" + } + ] + ] + /// All tests for the Domain namespace -let all = testList "Domain" [ nodaTests; accessLevelTests ] +let all = + testList + "Domain" + [ nodaTests + accessLevelTests + commentStatusTests + explicitRatingTests ] -- 2.45.1 From 5c0804917084e74972504c0af0188b3edcbaf45c Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 6 Jan 2024 21:35:51 -0500 Subject: [PATCH 037/123] Finish SupportTypes tests --- src/MyWebLog.Domain/SupportTypes.fs | 5 +- src/MyWebLog.Tests/Domain.fs | 248 +++++++++++++++++++++++++++- 2 files changed, 251 insertions(+), 2 deletions(-) diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index c424dad..3d78e61 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -660,7 +660,10 @@ type ThemeAssetId = /// Convert a string into a theme asset ID static member Parse(it : string) = let themeIdx = it.IndexOf "/" - ThemeAssetId(ThemeId it[..(themeIdx - 1)], it[(themeIdx + 1)..]) + 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() = diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index b97a0e4..afdef76 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -176,6 +176,245 @@ let explicitRatingTests = ] ] +/// 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:

      howdy

      " + match txt with + | Html it when it = "

      howdy

      " -> () + | _ -> 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 + (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:

      HTML

      ")) + "HTML:

      HTML

      " + "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:

      The Heading

      ").AsHtml()) + "

      The Heading

      " + "HTML value incorrect" + } + test "succeeds for Markdown" { + Expect.equal + ((MarkupText.Parse "Markdown: *emphasis*").AsHtml()) + "

      emphasis

      \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 + (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 + (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 + (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 + (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") Database "\"Disk\" not parsed correctly" + } + test "fails for unrecognized value" { + Expect.throwsT + (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 namespace let all = testList @@ -183,4 +422,11 @@ let all = [ nodaTests accessLevelTests commentStatusTests - explicitRatingTests ] + explicitRatingTests + episodeTests + markupTextTests + podcastMediumTests + postStatusTests + customFeedSourceTests + themeAssetIdTests + uploadDestinationTests ] -- 2.45.1 From 5126e2029b37808e4154df419ab11f7f2aacd582 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 6 Jan 2024 22:29:06 -0500 Subject: [PATCH 038/123] Add tests for DataTypes --- src/MyWebLog.Domain/DataTypes.fs | 12 ++-- src/MyWebLog.Tests/Domain.fs | 96 +++++++++++++++++++++++++++++++- 2 files changed, 101 insertions(+), 7 deletions(-) diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index 413702a..ef172e7 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -381,8 +381,12 @@ type WebLog = { /// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain) [] member this.ExtraPath = - let path = this.UrlBase.Split("://").[1].Split "/" - if path.Length > 1 then $"""/{String.Join("/", path |> Array.skip 1)}""" else "" + let pathParts = this.UrlBase.Split("://") + if pathParts.Length < 2 then + "" + else + let path = pathParts[1].Split "/" + if path.Length > 1 then $"""/{String.Join("/", path |> Array.skip 1)}""" else "" /// Generate an absolute URL for the given link member this.AbsoluteUrl(permalink: Permalink) = @@ -394,7 +398,7 @@ type WebLog = { /// Convert an Instant (UTC reference) to the web log's local date/time member this.LocalTime(date: Instant) = - match DateTimeZoneProviders.Tzdb[this.TimeZone] with + match DateTimeZoneProviders.Tzdb.GetZoneOrNull this.TimeZone with | null -> date.ToDateTimeUtc() | tz -> date.InZone(tz).ToDateTimeUnspecified() @@ -454,5 +458,5 @@ type WebLogUser = { /// Get the user's displayed name [] member this.DisplayName = - (seq { match this.PreferredName with "" -> this.FirstName | n -> n; " "; this.LastName } + (seq { (match this.PreferredName with "" -> this.FirstName | n -> n); " "; this.LastName } |> Seq.reduce (+)).Trim() diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index afdef76..09c6374 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -5,6 +5,8 @@ open Expecto open MyWebLog open NodaTime +// --- SUPPORT TYPES --- + /// Tests for the NodaTime-wrapping module let nodaTests = testList "Noda" [ @@ -398,7 +400,7 @@ let uploadDestinationTests = Expect.equal (UploadDestination.Parse "Database") Database "\"Database\" not parsed correctly" } test "succeeds for \"Disk\"" { - Expect.equal (UploadDestination.Parse "Disk") Database "\"Disk\" not parsed correctly" + Expect.equal (UploadDestination.Parse "Disk") Disk "\"Disk\" not parsed correctly" } test "fails for unrecognized value" { Expect.throwsT @@ -415,11 +417,96 @@ let uploadDestinationTests = ] ] +// --- DATA TYPES --- + +/// 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 = "http://a.com/subdir" }.ExtraPath + "/subdir" + "Extra path incorrect for a single subdirectory" + } + test "succeeds for deeper nesting" { + Expect.equal + { WebLog.Empty with UrlBase = "http://b.com/users/test/units" }.ExtraPath + "/users/test/units" + "Extra path incorrect for deeper nesting" + } + ] + test "AbsoluteUrl succeeds" { + Expect.equal + ({ WebLog.Empty with UrlBase = "http://my.site" }.AbsoluteUrl(Permalink "blog/page.html")) + "http://my.site/blog/page.html" + "Absolute URL is incorrect" + } + testList "RelativeUrl" [ + test "succeeds for domain root URL" { + Expect.equal + ({ WebLog.Empty with UrlBase = "http://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 = "http://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 namespace let all = testList "Domain" - [ nodaTests + [ // support types + nodaTests accessLevelTests commentStatusTests explicitRatingTests @@ -429,4 +516,7 @@ let all = postStatusTests customFeedSourceTests themeAssetIdTests - uploadDestinationTests ] + uploadDestinationTests + // data types + webLogTests + webLogUserTests ] -- 2.45.1 From 66225298d26e9df212f831b0eb9f9cf3979aff9d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 8 Jan 2024 18:41:12 -0500 Subject: [PATCH 039/123] Add some view model tests --- src/MyWebLog.Domain/SupportTypes.fs | 22 ++++++++- src/MyWebLog.Domain/ViewModels.fs | 7 ++- src/MyWebLog.Tests/Domain.fs | 74 ++++++++++++++++++++++++++++- 3 files changed, 100 insertions(+), 3 deletions(-) diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 3d78e61..1266fd7 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -554,7 +554,27 @@ 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 diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 3b8a761..3bbdea0 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -89,7 +89,12 @@ type DisplayCustomFeed = { static member FromFeed (cats: DisplayCategory array) (feed: CustomFeed) = let source = match feed.Source with - | Category (CategoryId catId) -> $"Category: {(cats |> Array.find (fun cat -> cat.Id = catId)).Name}" + | Category (CategoryId catId) -> + cats + |> Array.tryFind (fun cat -> cat.Id = catId) + |> Option.map _.Name + |> Option.defaultValue "--INVALID; DELETE THIS FEED--" + |> sprintf "Category: %s" | Tag tag -> $"Tag: {tag}" { Id = string feed.Id Source = source diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index 09c6374..78ffeb2 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -501,6 +501,75 @@ let webLogUserTests = ] ] +// --- VIEW MODELS --- + +open MyWebLog.ViewModels + +/// Unit tests for the addBaseToRelativeUrls helper function +let addBaseToRelativeUrlsTests = + testList "PublicHelpers.addBaseToRelativeUrls" [ + test "succeeds when there is no extra URL path" { + let testText = """Howdy>""" + let modified = addBaseToRelativeUrls "" testText + Expect.equal modified testText "The text should not have been modified" + } + test "succeeds with an extra URL path" { + let testText = + """ Date: Mon, 8 Jan 2024 22:08:38 -0500 Subject: [PATCH 040/123] Add more view model tests --- src/MyWebLog.Domain/DataTypes.fs | 12 +-- src/MyWebLog.Tests/Domain.fs | 138 ++++++++++++++++++++++++++++++- 2 files changed, 143 insertions(+), 7 deletions(-) diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index ef172e7..2ea9f55 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -1,6 +1,5 @@ namespace MyWebLog -open System open MyWebLog open NodaTime @@ -381,12 +380,12 @@ type WebLog = { /// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain) [] member this.ExtraPath = - let pathParts = this.UrlBase.Split("://") + let pathParts = this.UrlBase.Split "://" if pathParts.Length < 2 then "" else let path = pathParts[1].Split "/" - if path.Length > 1 then $"""/{String.Join("/", path |> Array.skip 1)}""" else "" + if path.Length > 1 then $"""/{path |> Array.skip 1 |> String.concat "/"}""" else "" /// Generate an absolute URL for the given link member this.AbsoluteUrl(permalink: Permalink) = @@ -398,9 +397,10 @@ type WebLog = { /// Convert an Instant (UTC reference) to the web log's local date/time member this.LocalTime(date: Instant) = - match DateTimeZoneProviders.Tzdb.GetZoneOrNull this.TimeZone with - | null -> date.ToDateTimeUtc() - | tz -> date.InZone(tz).ToDateTimeUnspecified() + 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 diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index 78ffeb2..415a51e 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -570,6 +570,138 @@ let displayCustomFeedTests = } ] +/// Unit tests for the DisplayPage type +let displayPageTests = + testList "DisplayPage" [ + let page = + { Page.Empty with + Id = PageId "my-page" + AuthorId = WebLogUserId "jim" + Title = "A Fine Example" + Permalink = Permalink "about/a-fine-example.html" + PublishedOn = Noda.epoch + UpdatedOn = Noda.epoch + Duration.FromHours 1 + Text = """Click Me!""" + Metadata = [ { Name = "unit"; Value = "test" } ] } + testList "FromPageMinimal" [ + test "succeeds when page is default page" { + let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-1"; DefaultPage = "my-page" } + let model = DisplayPage.FromPageMinimal webLog page + Expect.equal model.Id "my-page" "Id not filled properly" + Expect.equal model.AuthorId "jim" "AuthorId not filled properly" + Expect.equal model.Title "A Fine Example" "Title not filled properly" + Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" + Expect.equal + model.PublishedOn + ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) + "PublishedOn not filled properly" + Expect.equal + model.UpdatedOn + ((Noda.epoch + Duration.FromHours 2).ToDateTimeUtc()) + "UpdatedOn not filled properly" + Expect.isFalse model.IsInPageList "IsInPageList should not have been set" + Expect.isTrue model.IsDefault "IsDefault should have been set" + Expect.equal model.Text "" "Text should have been blank" + Expect.isEmpty model.Metadata "Metadata should have been empty" + } + test "succeeds when page is not the default page" { + let model = DisplayPage.FromPageMinimal { WebLog.Empty with DefaultPage = "posts" } page + Expect.isFalse model.IsDefault "IsDefault should not have been set" + } + ] + testList "FromPage" [ + test "succeeds when the web log is on the domain root" { + let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-4"; UrlBase = "https://example.com" } + let model = DisplayPage.FromPage webLog page + Expect.equal model.Id "my-page" "Id not filled properly" + Expect.equal model.AuthorId "jim" "AuthorId not filled properly" + Expect.equal model.Title "A Fine Example" "Title not filled properly" + Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" + Expect.equal + model.PublishedOn + ((Noda.epoch + Duration.FromHours 4).ToDateTimeUtc()) + "PublishedOn not filled properly" + Expect.equal + model.UpdatedOn + ((Noda.epoch + Duration.FromHours 5).ToDateTimeUtc()) + "UpdatedOn not filled properly" + Expect.isFalse model.IsInPageList "IsInPageList should not have been set" + Expect.isFalse model.IsDefault "IsDefault should not have been set" + Expect.equal model.Text """Click Me!""" "Text not filled properly" + Expect.equal model.Metadata.Length 1 "Metadata not filled properly" + } + test "succeeds when the web log is not on the domain root" { + let model = DisplayPage.FromPage { WebLog.Empty with UrlBase = "https://example.com/a/b/c" } page + Expect.equal model.Text """Click Me!""" "Text not filled properly" + } + ] + ] + +/// Unit tests for the DisplayRevision type +let displayRevisionTests = + test "DisplayRevision.FromRevision succeeds" { + let model = + DisplayRevision.FromRevision + { WebLog.Empty with TimeZone = "Etc/GMT+1" } + { Text = Html "howdy"; AsOf = Noda.epoch } + Expect.equal model.AsOf (Noda.epoch.ToDateTimeUtc()) "AsOf not filled properly" + Expect.equal + model.AsOfLocal ((Noda.epoch - Duration.FromHours 1).ToDateTimeUtc()) "AsOfLocal not filled properly" + Expect.equal model.Format "HTML" "Format not filled properly" + } + +open System.IO + +/// Unit tests for the DisplayTheme type +let displayThemeTests = + testList "DisplayTheme.FromTheme" [ + let theme = + { Id = ThemeId "the-theme" + Name = "Test Theme" + Version = "v0.1.2" + Templates = [ ThemeTemplate.Empty; ThemeTemplate.Empty ] } + test "succeeds when theme is in use and not on disk" { + let model = + DisplayTheme.FromTheme + (fun it -> Expect.equal it (ThemeId "the-theme") "The theme ID not passed correctly"; true) theme + Expect.equal model.Id "the-theme" "Id not filled properly" + Expect.equal model.Name "Test Theme" "Name not filled properly" + Expect.equal model.Version "v0.1.2" "Version not filled properly" + Expect.equal model.TemplateCount 2 "TemplateCount not filled properly" + Expect.isTrue model.IsInUse "IsInUse should have been set" + Expect.isFalse model.IsOnDisk "IsOnDisk should not have been set" + } + test "succeeds when the theme is not in use as is on disk" { + let file = File.Create "the-theme-theme.zip" + try + let model = DisplayTheme.FromTheme (fun _ -> false) theme + Expect.isFalse model.IsInUse "IsInUse should not have been set" + Expect.isTrue model.IsOnDisk "IsOnDisk should have been set" + finally + file.Close() + file.Dispose() + File.Delete "the-theme-theme.zip" + } + ] + +/// Unit tests for the DisplayUpload type +let displayUploadTests = + test "DisplayUpload.FromUpload succeeds" { + let upload = + { Upload.Empty with + Id = UploadId "test-up" + Path = Permalink "2022/04/my-pic.jpg" + UpdatedOn = Noda.epoch } + let model = DisplayUpload.FromUpload { WebLog.Empty with TimeZone = "Etc/GMT-1" } Database upload + Expect.equal model.Id "test-up" "Id not filled properly" + Expect.equal model.Name "my-pic.jpg" "Name not filled properly" + Expect.equal model.Path "2022/04/" "Path not filled properly" + Expect.equal model.Source "Database" "Source not filled properly" + Expect.isSome model.UpdatedOn "There should have been an UpdatedOn value" + Expect.equal + model.UpdatedOn.Value ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "UpdatedOn not filled properly" + } + /// All tests for the Domain namespace let all = testList @@ -591,4 +723,8 @@ let all = webLogUserTests // view models addBaseToRelativeUrlsTests - displayCustomFeedTests ] + displayCustomFeedTests + displayPageTests + displayRevisionTests + displayThemeTests + displayUploadTests ] -- 2.45.1 From 8ec7610ee3db79e1ab1ed7534d275e20b47240f6 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 9 Jan 2024 18:11:31 -0500 Subject: [PATCH 041/123] Tweak domain tests --- src/MyWebLog.Tests/Domain.fs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index 415a51e..1d89d87 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -434,33 +434,33 @@ let webLogTests = } test "succeeds for single subdirectory" { Expect.equal - { WebLog.Empty with UrlBase = "http://a.com/subdir" }.ExtraPath - "/subdir" + { 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 = "http://b.com/users/test/units" }.ExtraPath + { 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 = "http://my.site" }.AbsoluteUrl(Permalink "blog/page.html")) - "http://my.site/blog/page.html" + ({ 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 = "http://test.me" }.RelativeUrl(Permalink "about.htm")) + ({ 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 = "http://site.page/a/b/c" }.RelativeUrl(Permalink "x/y/z")) + ({ 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" } @@ -672,15 +672,15 @@ let displayThemeTests = Expect.isFalse model.IsOnDisk "IsOnDisk should not have been set" } test "succeeds when the theme is not in use as is on disk" { - let file = File.Create "the-theme-theme.zip" + let file = File.Create "another-theme.zip" try - let model = DisplayTheme.FromTheme (fun _ -> false) theme + let model = DisplayTheme.FromTheme (fun _ -> false) { theme with Id = ThemeId "another" } Expect.isFalse model.IsInUse "IsInUse should not have been set" Expect.isTrue model.IsOnDisk "IsOnDisk should have been set" finally file.Close() file.Dispose() - File.Delete "the-theme-theme.zip" + File.Delete "another-theme.zip" } ] -- 2.45.1 From ba42f848998455d168235c8d769ed34175109db8 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 9 Jan 2024 21:47:46 -0500 Subject: [PATCH 042/123] Add DisplayUser tests --- src/MyWebLog.Tests/Domain.fs | 45 +++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index 1d89d87..029bde8 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -702,6 +702,48 @@ let displayUploadTests = model.UpdatedOn.Value ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "UpdatedOn not filled properly" } +/// Unit tests for the DisplayUser type +let displayUserTests = + testList "DisplayUser.FromUser" [ + let minimalUser = + { WebLogUser.Empty with + Id = WebLogUserId "test-user" + Email = "jim.james@example.com" + FirstName = "Jim" + LastName = "James" + PreferredName = "John" + AccessLevel = Editor + CreatedOn = Noda.epoch } + test "succeeds when the user has minimal information" { + let model = DisplayUser.FromUser WebLog.Empty minimalUser + Expect.equal model.Id "test-user" "Id not filled properly" + Expect.equal model.Email "jim.james@example.com" "Email not filled properly" + Expect.equal model.FirstName "Jim" "FirstName not filled properly" + Expect.equal model.LastName "James" "LastName not filled properly" + Expect.equal model.PreferredName "John" "PreferredName not filled properly" + Expect.equal model.Url "" "Url not filled properly" + Expect.equal model.AccessLevel "Editor" "AccessLevel not filled properly" + Expect.equal model.CreatedOn (Noda.epoch.ToDateTimeUtc()) "CreatedOn not filled properly" + Expect.isFalse model.LastSeenOn.HasValue "LastSeenOn should have been null" + } + test "succeeds when the user has all information" { + let model = + DisplayUser.FromUser + { WebLog.Empty with TimeZone = "Etc/GMT-1" } + { minimalUser with + Url = Some "https://my.site" + LastSeenOn = Some (Noda.epoch + Duration.FromDays 4) } + Expect.equal model.Url "https://my.site" "Url not filled properly" + Expect.equal + model.CreatedOn ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "CreatedOn not filled properly" + Expect.isTrue model.LastSeenOn.HasValue "LastSeenOn should not have been null" + Expect.equal + model.LastSeenOn.Value + ((Noda.epoch + Duration.FromDays 4 + Duration.FromHours 1).ToDateTimeUtc()) + "LastSeenOn not filled properly" + } + ] + /// All tests for the Domain namespace let all = testList @@ -727,4 +769,5 @@ let all = displayPageTests displayRevisionTests displayThemeTests - displayUploadTests ] + displayUploadTests + displayUserTests ] -- 2.45.1 From 10affa2defec667018bcd20d7ad206c62449012e Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 10 Jan 2024 20:33:06 -0500 Subject: [PATCH 043/123] Add EditCategoryModel tests --- src/MyWebLog.Tests/Domain.fs | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs index 029bde8..812fe19 100644 --- a/src/MyWebLog.Tests/Domain.fs +++ b/src/MyWebLog.Tests/Domain.fs @@ -744,6 +744,39 @@ let displayUserTests = } ] +/// Unit tests for the EditCategoryModel type +let editCategoryModelTests = + testList "EditCategoryModel" [ + testList "FromCategory" [ + let minimalCat = { Category.Empty with Id = CategoryId "test-cat"; Name = "test"; Slug = "test-slug" } + test "succeeds with minimal information" { + let model = EditCategoryModel.FromCategory minimalCat + Expect.equal model.CategoryId "test-cat" "CategoryId not filled properly" + Expect.equal model.Name "test" "Name not filled properly" + Expect.equal model.Slug "test-slug" "Slug not filled properly" + Expect.equal model.Description "" "Description not filled properly" + Expect.equal model.ParentId "" "ParentId not filled properly" + } + test "succeeds with complete information" { + let model = + EditCategoryModel.FromCategory + { minimalCat with Description = Some "Testing"; ParentId = Some (CategoryId "parent") } + Expect.equal model.Description "Testing" "Description not filled properly" + Expect.equal model.ParentId "parent" "ParentId not filled properly" + } + ] + testList "IsNew" [ + test "succeeds for a new category" { + let model = EditCategoryModel.FromCategory { Category.Empty with Id = CategoryId "new" } + Expect.isTrue model.IsNew "Category should have been considered new" + } + test "succeeds for a non-new category" { + let model = EditCategoryModel.FromCategory Category.Empty + Expect.isFalse model.IsNew "Category should not have been considered new" + } + ] + ] + /// All tests for the Domain namespace let all = testList @@ -770,4 +803,5 @@ let all = displayRevisionTests displayThemeTests displayUploadTests - displayUserTests ] + displayUserTests + editCategoryModelTests ] -- 2.45.1 From 29cbf486db792566ed1d9c05b0e7a90e1b626f0e Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 10 Jan 2024 20:53:59 -0500 Subject: [PATCH 044/123] Split tests into separate files --- src/MyWebLog.Tests/DataTypesTests.fs | 90 +++ src/MyWebLog.Tests/Domain.fs | 807 ----------------------- src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 4 +- src/MyWebLog.Tests/Program.fs | 2 +- src/MyWebLog.Tests/SupportTypesTests.fs | 432 ++++++++++++ src/MyWebLog.Tests/ViewModelsTests.fs | 292 ++++++++ 6 files changed, 818 insertions(+), 809 deletions(-) create mode 100644 src/MyWebLog.Tests/DataTypesTests.fs delete mode 100644 src/MyWebLog.Tests/Domain.fs create mode 100644 src/MyWebLog.Tests/SupportTypesTests.fs create mode 100644 src/MyWebLog.Tests/ViewModelsTests.fs diff --git a/src/MyWebLog.Tests/DataTypesTests.fs b/src/MyWebLog.Tests/DataTypesTests.fs new file mode 100644 index 0000000..0a5f904 --- /dev/null +++ b/src/MyWebLog.Tests/DataTypesTests.fs @@ -0,0 +1,90 @@ +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 ] diff --git a/src/MyWebLog.Tests/Domain.fs b/src/MyWebLog.Tests/Domain.fs deleted file mode 100644 index 812fe19..0000000 --- a/src/MyWebLog.Tests/Domain.fs +++ /dev/null @@ -1,807 +0,0 @@ -module Domain - -open System -open Expecto -open MyWebLog -open NodaTime - -// --- SUPPORT TYPES --- - -/// 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 - (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 - (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" - } - ] - ] - -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 - (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:

      howdy

      " - match txt with - | Html it when it = "

      howdy

      " -> () - | _ -> 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 - (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:

      HTML

      ")) - "HTML:

      HTML

      " - "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:

      The Heading

      ").AsHtml()) - "

      The Heading

      " - "HTML value incorrect" - } - test "succeeds for Markdown" { - Expect.equal - ((MarkupText.Parse "Markdown: *emphasis*").AsHtml()) - "

      emphasis

      \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 - (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 - (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 - (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 - (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 - (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" - } - ] - ] - -// --- DATA TYPES --- - -/// 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" - } - ] - ] - -// --- VIEW MODELS --- - -open MyWebLog.ViewModels - -/// Unit tests for the addBaseToRelativeUrls helper function -let addBaseToRelativeUrlsTests = - testList "PublicHelpers.addBaseToRelativeUrls" [ - test "succeeds when there is no extra URL path" { - let testText = """Howdy>""" - let modified = addBaseToRelativeUrls "" testText - Expect.equal modified testText "The text should not have been modified" - } - test "succeeds with an extra URL path" { - let testText = - """Click Me!""" - Metadata = [ { Name = "unit"; Value = "test" } ] } - testList "FromPageMinimal" [ - test "succeeds when page is default page" { - let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-1"; DefaultPage = "my-page" } - let model = DisplayPage.FromPageMinimal webLog page - Expect.equal model.Id "my-page" "Id not filled properly" - Expect.equal model.AuthorId "jim" "AuthorId not filled properly" - Expect.equal model.Title "A Fine Example" "Title not filled properly" - Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" - Expect.equal - model.PublishedOn - ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) - "PublishedOn not filled properly" - Expect.equal - model.UpdatedOn - ((Noda.epoch + Duration.FromHours 2).ToDateTimeUtc()) - "UpdatedOn not filled properly" - Expect.isFalse model.IsInPageList "IsInPageList should not have been set" - Expect.isTrue model.IsDefault "IsDefault should have been set" - Expect.equal model.Text "" "Text should have been blank" - Expect.isEmpty model.Metadata "Metadata should have been empty" - } - test "succeeds when page is not the default page" { - let model = DisplayPage.FromPageMinimal { WebLog.Empty with DefaultPage = "posts" } page - Expect.isFalse model.IsDefault "IsDefault should not have been set" - } - ] - testList "FromPage" [ - test "succeeds when the web log is on the domain root" { - let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-4"; UrlBase = "https://example.com" } - let model = DisplayPage.FromPage webLog page - Expect.equal model.Id "my-page" "Id not filled properly" - Expect.equal model.AuthorId "jim" "AuthorId not filled properly" - Expect.equal model.Title "A Fine Example" "Title not filled properly" - Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" - Expect.equal - model.PublishedOn - ((Noda.epoch + Duration.FromHours 4).ToDateTimeUtc()) - "PublishedOn not filled properly" - Expect.equal - model.UpdatedOn - ((Noda.epoch + Duration.FromHours 5).ToDateTimeUtc()) - "UpdatedOn not filled properly" - Expect.isFalse model.IsInPageList "IsInPageList should not have been set" - Expect.isFalse model.IsDefault "IsDefault should not have been set" - Expect.equal model.Text """Click Me!""" "Text not filled properly" - Expect.equal model.Metadata.Length 1 "Metadata not filled properly" - } - test "succeeds when the web log is not on the domain root" { - let model = DisplayPage.FromPage { WebLog.Empty with UrlBase = "https://example.com/a/b/c" } page - Expect.equal model.Text """Click Me!""" "Text not filled properly" - } - ] - ] - -/// Unit tests for the DisplayRevision type -let displayRevisionTests = - test "DisplayRevision.FromRevision succeeds" { - let model = - DisplayRevision.FromRevision - { WebLog.Empty with TimeZone = "Etc/GMT+1" } - { Text = Html "howdy"; AsOf = Noda.epoch } - Expect.equal model.AsOf (Noda.epoch.ToDateTimeUtc()) "AsOf not filled properly" - Expect.equal - model.AsOfLocal ((Noda.epoch - Duration.FromHours 1).ToDateTimeUtc()) "AsOfLocal not filled properly" - Expect.equal model.Format "HTML" "Format not filled properly" - } - -open System.IO - -/// Unit tests for the DisplayTheme type -let displayThemeTests = - testList "DisplayTheme.FromTheme" [ - let theme = - { Id = ThemeId "the-theme" - Name = "Test Theme" - Version = "v0.1.2" - Templates = [ ThemeTemplate.Empty; ThemeTemplate.Empty ] } - test "succeeds when theme is in use and not on disk" { - let model = - DisplayTheme.FromTheme - (fun it -> Expect.equal it (ThemeId "the-theme") "The theme ID not passed correctly"; true) theme - Expect.equal model.Id "the-theme" "Id not filled properly" - Expect.equal model.Name "Test Theme" "Name not filled properly" - Expect.equal model.Version "v0.1.2" "Version not filled properly" - Expect.equal model.TemplateCount 2 "TemplateCount not filled properly" - Expect.isTrue model.IsInUse "IsInUse should have been set" - Expect.isFalse model.IsOnDisk "IsOnDisk should not have been set" - } - test "succeeds when the theme is not in use as is on disk" { - let file = File.Create "another-theme.zip" - try - let model = DisplayTheme.FromTheme (fun _ -> false) { theme with Id = ThemeId "another" } - Expect.isFalse model.IsInUse "IsInUse should not have been set" - Expect.isTrue model.IsOnDisk "IsOnDisk should have been set" - finally - file.Close() - file.Dispose() - File.Delete "another-theme.zip" - } - ] - -/// Unit tests for the DisplayUpload type -let displayUploadTests = - test "DisplayUpload.FromUpload succeeds" { - let upload = - { Upload.Empty with - Id = UploadId "test-up" - Path = Permalink "2022/04/my-pic.jpg" - UpdatedOn = Noda.epoch } - let model = DisplayUpload.FromUpload { WebLog.Empty with TimeZone = "Etc/GMT-1" } Database upload - Expect.equal model.Id "test-up" "Id not filled properly" - Expect.equal model.Name "my-pic.jpg" "Name not filled properly" - Expect.equal model.Path "2022/04/" "Path not filled properly" - Expect.equal model.Source "Database" "Source not filled properly" - Expect.isSome model.UpdatedOn "There should have been an UpdatedOn value" - Expect.equal - model.UpdatedOn.Value ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "UpdatedOn not filled properly" - } - -/// Unit tests for the DisplayUser type -let displayUserTests = - testList "DisplayUser.FromUser" [ - let minimalUser = - { WebLogUser.Empty with - Id = WebLogUserId "test-user" - Email = "jim.james@example.com" - FirstName = "Jim" - LastName = "James" - PreferredName = "John" - AccessLevel = Editor - CreatedOn = Noda.epoch } - test "succeeds when the user has minimal information" { - let model = DisplayUser.FromUser WebLog.Empty minimalUser - Expect.equal model.Id "test-user" "Id not filled properly" - Expect.equal model.Email "jim.james@example.com" "Email not filled properly" - Expect.equal model.FirstName "Jim" "FirstName not filled properly" - Expect.equal model.LastName "James" "LastName not filled properly" - Expect.equal model.PreferredName "John" "PreferredName not filled properly" - Expect.equal model.Url "" "Url not filled properly" - Expect.equal model.AccessLevel "Editor" "AccessLevel not filled properly" - Expect.equal model.CreatedOn (Noda.epoch.ToDateTimeUtc()) "CreatedOn not filled properly" - Expect.isFalse model.LastSeenOn.HasValue "LastSeenOn should have been null" - } - test "succeeds when the user has all information" { - let model = - DisplayUser.FromUser - { WebLog.Empty with TimeZone = "Etc/GMT-1" } - { minimalUser with - Url = Some "https://my.site" - LastSeenOn = Some (Noda.epoch + Duration.FromDays 4) } - Expect.equal model.Url "https://my.site" "Url not filled properly" - Expect.equal - model.CreatedOn ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "CreatedOn not filled properly" - Expect.isTrue model.LastSeenOn.HasValue "LastSeenOn should not have been null" - Expect.equal - model.LastSeenOn.Value - ((Noda.epoch + Duration.FromDays 4 + Duration.FromHours 1).ToDateTimeUtc()) - "LastSeenOn not filled properly" - } - ] - -/// Unit tests for the EditCategoryModel type -let editCategoryModelTests = - testList "EditCategoryModel" [ - testList "FromCategory" [ - let minimalCat = { Category.Empty with Id = CategoryId "test-cat"; Name = "test"; Slug = "test-slug" } - test "succeeds with minimal information" { - let model = EditCategoryModel.FromCategory minimalCat - Expect.equal model.CategoryId "test-cat" "CategoryId not filled properly" - Expect.equal model.Name "test" "Name not filled properly" - Expect.equal model.Slug "test-slug" "Slug not filled properly" - Expect.equal model.Description "" "Description not filled properly" - Expect.equal model.ParentId "" "ParentId not filled properly" - } - test "succeeds with complete information" { - let model = - EditCategoryModel.FromCategory - { minimalCat with Description = Some "Testing"; ParentId = Some (CategoryId "parent") } - Expect.equal model.Description "Testing" "Description not filled properly" - Expect.equal model.ParentId "parent" "ParentId not filled properly" - } - ] - testList "IsNew" [ - test "succeeds for a new category" { - let model = EditCategoryModel.FromCategory { Category.Empty with Id = CategoryId "new" } - Expect.isTrue model.IsNew "Category should have been considered new" - } - test "succeeds for a non-new category" { - let model = EditCategoryModel.FromCategory Category.Empty - Expect.isFalse model.IsNew "Category should not have been considered new" - } - ] - ] - -/// All tests for the Domain namespace -let all = - testList - "Domain" - [ // support types - nodaTests - accessLevelTests - commentStatusTests - explicitRatingTests - episodeTests - markupTextTests - podcastMediumTests - postStatusTests - customFeedSourceTests - themeAssetIdTests - uploadDestinationTests - // data types - webLogTests - webLogUserTests - // view models - addBaseToRelativeUrlsTests - displayCustomFeedTests - displayPageTests - displayRevisionTests - displayThemeTests - displayUploadTests - displayUserTests - editCategoryModelTests ] diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 1cae610..d415d68 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -5,7 +5,9 @@ - + + + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index 5a5a4be..e7d56ba 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -3,7 +3,7 @@ let allTests = testList "MyWebLog" - [ Domain.all ] + [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] ] [] let main args = runTestsWithCLIArgs [] args allTests diff --git a/src/MyWebLog.Tests/SupportTypesTests.fs b/src/MyWebLog.Tests/SupportTypesTests.fs new file mode 100644 index 0000000..09c1fc4 --- /dev/null +++ b/src/MyWebLog.Tests/SupportTypesTests.fs @@ -0,0 +1,432 @@ +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 + (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 + (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" + } + ] + ] + +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 + (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:

      howdy

      " + match txt with + | Html it when it = "

      howdy

      " -> () + | _ -> 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 + (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:

      HTML

      ")) + "HTML:

      HTML

      " + "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:

      The Heading

      ").AsHtml()) + "

      The Heading

      " + "HTML value incorrect" + } + test "succeeds for Markdown" { + Expect.equal + ((MarkupText.Parse "Markdown: *emphasis*").AsHtml()) + "

      emphasis

      \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 + (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 + (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 + (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 + (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 + (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 ] diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs new file mode 100644 index 0000000..bddae3c --- /dev/null +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -0,0 +1,292 @@ +module ViewModelsTests + +open System +open Expecto +open MyWebLog +open MyWebLog.ViewModels +open NodaTime + +/// Unit tests for the addBaseToRelativeUrls helper function +let addBaseToRelativeUrlsTests = + testList "PublicHelpers.addBaseToRelativeUrls" [ + test "succeeds when there is no extra URL path" { + let testText = """Howdy>""" + let modified = addBaseToRelativeUrls "" testText + Expect.equal modified testText "The text should not have been modified" + } + test "succeeds with an extra URL path" { + let testText = + """Click Me!""" + Metadata = [ { Name = "unit"; Value = "test" } ] } + testList "FromPageMinimal" [ + test "succeeds when page is default page" { + let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-1"; DefaultPage = "my-page" } + let model = DisplayPage.FromPageMinimal webLog page + Expect.equal model.Id "my-page" "Id not filled properly" + Expect.equal model.AuthorId "jim" "AuthorId not filled properly" + Expect.equal model.Title "A Fine Example" "Title not filled properly" + Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" + Expect.equal + model.PublishedOn + ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) + "PublishedOn not filled properly" + Expect.equal + model.UpdatedOn + ((Noda.epoch + Duration.FromHours 2).ToDateTimeUtc()) + "UpdatedOn not filled properly" + Expect.isFalse model.IsInPageList "IsInPageList should not have been set" + Expect.isTrue model.IsDefault "IsDefault should have been set" + Expect.equal model.Text "" "Text should have been blank" + Expect.isEmpty model.Metadata "Metadata should have been empty" + } + test "succeeds when page is not the default page" { + let model = DisplayPage.FromPageMinimal { WebLog.Empty with DefaultPage = "posts" } page + Expect.isFalse model.IsDefault "IsDefault should not have been set" + } + ] + testList "FromPage" [ + test "succeeds when the web log is on the domain root" { + let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-4"; UrlBase = "https://example.com" } + let model = DisplayPage.FromPage webLog page + Expect.equal model.Id "my-page" "Id not filled properly" + Expect.equal model.AuthorId "jim" "AuthorId not filled properly" + Expect.equal model.Title "A Fine Example" "Title not filled properly" + Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" + Expect.equal + model.PublishedOn + ((Noda.epoch + Duration.FromHours 4).ToDateTimeUtc()) + "PublishedOn not filled properly" + Expect.equal + model.UpdatedOn + ((Noda.epoch + Duration.FromHours 5).ToDateTimeUtc()) + "UpdatedOn not filled properly" + Expect.isFalse model.IsInPageList "IsInPageList should not have been set" + Expect.isFalse model.IsDefault "IsDefault should not have been set" + Expect.equal model.Text """Click Me!""" "Text not filled properly" + Expect.equal model.Metadata.Length 1 "Metadata not filled properly" + } + test "succeeds when the web log is not on the domain root" { + let model = DisplayPage.FromPage { WebLog.Empty with UrlBase = "https://example.com/a/b/c" } page + Expect.equal model.Text """Click Me!""" "Text not filled properly" + } + ] + ] + +/// Unit tests for the DisplayRevision type +let displayRevisionTests = + test "DisplayRevision.FromRevision succeeds" { + let model = + DisplayRevision.FromRevision + { WebLog.Empty with TimeZone = "Etc/GMT+1" } + { Text = Html "howdy"; AsOf = Noda.epoch } + Expect.equal model.AsOf (Noda.epoch.ToDateTimeUtc()) "AsOf not filled properly" + Expect.equal + model.AsOfLocal ((Noda.epoch - Duration.FromHours 1).ToDateTimeUtc()) "AsOfLocal not filled properly" + Expect.equal model.Format "HTML" "Format not filled properly" + } + +open System.IO + +/// Unit tests for the DisplayTheme type +let displayThemeTests = + testList "DisplayTheme.FromTheme" [ + let theme = + { Id = ThemeId "the-theme" + Name = "Test Theme" + Version = "v0.1.2" + Templates = [ ThemeTemplate.Empty; ThemeTemplate.Empty ] } + test "succeeds when theme is in use and not on disk" { + let model = + DisplayTheme.FromTheme + (fun it -> Expect.equal it (ThemeId "the-theme") "The theme ID not passed correctly"; true) theme + Expect.equal model.Id "the-theme" "Id not filled properly" + Expect.equal model.Name "Test Theme" "Name not filled properly" + Expect.equal model.Version "v0.1.2" "Version not filled properly" + Expect.equal model.TemplateCount 2 "TemplateCount not filled properly" + Expect.isTrue model.IsInUse "IsInUse should have been set" + Expect.isFalse model.IsOnDisk "IsOnDisk should not have been set" + } + test "succeeds when the theme is not in use as is on disk" { + let file = File.Create "another-theme.zip" + try + let model = DisplayTheme.FromTheme (fun _ -> false) { theme with Id = ThemeId "another" } + Expect.isFalse model.IsInUse "IsInUse should not have been set" + Expect.isTrue model.IsOnDisk "IsOnDisk should have been set" + finally + file.Close() + file.Dispose() + File.Delete "another-theme.zip" + } + ] + +/// Unit tests for the DisplayUpload type +let displayUploadTests = + test "DisplayUpload.FromUpload succeeds" { + let upload = + { Upload.Empty with + Id = UploadId "test-up" + Path = Permalink "2022/04/my-pic.jpg" + UpdatedOn = Noda.epoch } + let model = DisplayUpload.FromUpload { WebLog.Empty with TimeZone = "Etc/GMT-1" } Database upload + Expect.equal model.Id "test-up" "Id not filled properly" + Expect.equal model.Name "my-pic.jpg" "Name not filled properly" + Expect.equal model.Path "2022/04/" "Path not filled properly" + Expect.equal model.Source "Database" "Source not filled properly" + Expect.isSome model.UpdatedOn "There should have been an UpdatedOn value" + Expect.equal + model.UpdatedOn.Value ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "UpdatedOn not filled properly" + } + +/// Unit tests for the DisplayUser type +let displayUserTests = + testList "DisplayUser.FromUser" [ + let minimalUser = + { WebLogUser.Empty with + Id = WebLogUserId "test-user" + Email = "jim.james@example.com" + FirstName = "Jim" + LastName = "James" + PreferredName = "John" + AccessLevel = Editor + CreatedOn = Noda.epoch } + test "succeeds when the user has minimal information" { + let model = DisplayUser.FromUser WebLog.Empty minimalUser + Expect.equal model.Id "test-user" "Id not filled properly" + Expect.equal model.Email "jim.james@example.com" "Email not filled properly" + Expect.equal model.FirstName "Jim" "FirstName not filled properly" + Expect.equal model.LastName "James" "LastName not filled properly" + Expect.equal model.PreferredName "John" "PreferredName not filled properly" + Expect.equal model.Url "" "Url not filled properly" + Expect.equal model.AccessLevel "Editor" "AccessLevel not filled properly" + Expect.equal model.CreatedOn (Noda.epoch.ToDateTimeUtc()) "CreatedOn not filled properly" + Expect.isFalse model.LastSeenOn.HasValue "LastSeenOn should have been null" + } + test "succeeds when the user has all information" { + let model = + DisplayUser.FromUser + { WebLog.Empty with TimeZone = "Etc/GMT-1" } + { minimalUser with + Url = Some "https://my.site" + LastSeenOn = Some (Noda.epoch + Duration.FromDays 4) } + Expect.equal model.Url "https://my.site" "Url not filled properly" + Expect.equal + model.CreatedOn ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "CreatedOn not filled properly" + Expect.isTrue model.LastSeenOn.HasValue "LastSeenOn should not have been null" + Expect.equal + model.LastSeenOn.Value + ((Noda.epoch + Duration.FromDays 4 + Duration.FromHours 1).ToDateTimeUtc()) + "LastSeenOn not filled properly" + } + ] + +/// Unit tests for the EditCategoryModel type +let editCategoryModelTests = + testList "EditCategoryModel" [ + testList "FromCategory" [ + let minimalCat = { Category.Empty with Id = CategoryId "test-cat"; Name = "test"; Slug = "test-slug" } + test "succeeds with minimal information" { + let model = EditCategoryModel.FromCategory minimalCat + Expect.equal model.CategoryId "test-cat" "CategoryId not filled properly" + Expect.equal model.Name "test" "Name not filled properly" + Expect.equal model.Slug "test-slug" "Slug not filled properly" + Expect.equal model.Description "" "Description not filled properly" + Expect.equal model.ParentId "" "ParentId not filled properly" + } + test "succeeds with complete information" { + let model = + EditCategoryModel.FromCategory + { minimalCat with Description = Some "Testing"; ParentId = Some (CategoryId "parent") } + Expect.equal model.Description "Testing" "Description not filled properly" + Expect.equal model.ParentId "parent" "ParentId not filled properly" + } + ] + testList "IsNew" [ + test "succeeds for a new category" { + let model = EditCategoryModel.FromCategory { Category.Empty with Id = CategoryId "new" } + Expect.isTrue model.IsNew "Category should have been considered new" + } + test "succeeds for a non-new category" { + let model = EditCategoryModel.FromCategory Category.Empty + Expect.isFalse model.IsNew "Category should not have been considered new" + } + ] + ] + +/// All tests for the Domain namespace +let all = + testList + "ViewModels" + [ addBaseToRelativeUrlsTests + displayCustomFeedTests + displayPageTests + displayRevisionTests + displayThemeTests + displayUploadTests + displayUserTests + editCategoryModelTests ] -- 2.45.1 From 29167eca6c74d05b77ec35bda2fa074c9eff9acf Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 10 Jan 2024 22:11:48 -0500 Subject: [PATCH 045/123] Add podcast/user edit model tests - Reformat test lists to save an indent --- src/MyWebLog.Tests/DataTypesTests.fs | 151 +++-- src/MyWebLog.Tests/Program.fs | 7 +- src/MyWebLog.Tests/SupportTypesTests.fs | 813 ++++++++++++------------ src/MyWebLog.Tests/ViewModelsTests.fs | 629 +++++++++++------- 4 files changed, 878 insertions(+), 722 deletions(-) diff --git a/src/MyWebLog.Tests/DataTypesTests.fs b/src/MyWebLog.Tests/DataTypesTests.fs index 0a5f904..8d04321 100644 --- a/src/MyWebLog.Tests/DataTypesTests.fs +++ b/src/MyWebLog.Tests/DataTypesTests.fs @@ -4,87 +4,84 @@ 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" +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" } - 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" - } - ] ] + 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" - } - ] +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 ] +let all = testList "DataTypes" [ webLogTests; webLogUserTests ] diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index e7d56ba..5755a72 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -1,9 +1,8 @@ open Expecto -let allTests = - testList - "MyWebLog" - [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] ] +let allTests = testList "MyWebLog" [ + testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] +] [] let main args = runTestsWithCLIArgs [] args allTests diff --git a/src/MyWebLog.Tests/SupportTypesTests.fs b/src/MyWebLog.Tests/SupportTypesTests.fs index 09c1fc4..b68494b 100644 --- a/src/MyWebLog.Tests/SupportTypesTests.fs +++ b/src/MyWebLog.Tests/SupportTypesTests.fs @@ -6,427 +6,410 @@ 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" - } - ] +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 - (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 - (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" - } - ] - ] - -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 - (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:

      howdy

      " - match txt with - | Html it when it = "

      howdy

      " -> () - | _ -> 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 - (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:

      HTML

      ")) - "HTML:

      HTML

      " - "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:

      The Heading

      ").AsHtml()) - "

      The Heading

      " - "HTML value incorrect" - } - test "succeeds for Markdown" { - Expect.equal - ((MarkupText.Parse "Markdown: *emphasis*").AsHtml()) - "

      emphasis

      \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 - (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 - (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 - (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 - (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" +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 + (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 + (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 + (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:

      howdy

      " + match txt with + | Html it when it = "

      howdy

      " -> () + | _ -> 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 + (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:

      HTML

      ")) "HTML:

      HTML

      " "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:

      The Heading

      ").AsHtml()) "

      The Heading

      " "HTML value incorrect" + } + test "succeeds for Markdown" { + Expect.equal + ((MarkupText.Parse "Markdown: *emphasis*").AsHtml()) + "

      emphasis

      \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 + (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 + (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 + (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 + (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 - (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" - } - ] +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 + (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 ] +let all = testList "SupportTypes" [ + nodaTests + accessLevelTests + commentStatusTests + explicitRatingTests + episodeTests + markupTextTests + podcastMediumTests + postStatusTests + customFeedSourceTests + themeAssetIdTests + uploadDestinationTests +] diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index bddae3c..e5c48fd 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -7,205 +7,195 @@ open MyWebLog.ViewModels open NodaTime /// Unit tests for the addBaseToRelativeUrls helper function -let addBaseToRelativeUrlsTests = - testList "PublicHelpers.addBaseToRelativeUrls" [ - test "succeeds when there is no extra URL path" { - let testText = """Howdy>""" - let modified = addBaseToRelativeUrls "" testText - Expect.equal modified testText "The text should not have been modified" - } - test "succeeds with an extra URL path" { - let testText = - """Howdy>""" + let modified = addBaseToRelativeUrls "" testText + Expect.equal modified testText "The text should not have been modified" + } + test "succeeds with an extra URL path" { + let testText = + """Click Me!""" - Metadata = [ { Name = "unit"; Value = "test" } ] } - testList "FromPageMinimal" [ - test "succeeds when page is default page" { - let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-1"; DefaultPage = "my-page" } - let model = DisplayPage.FromPageMinimal webLog page - Expect.equal model.Id "my-page" "Id not filled properly" - Expect.equal model.AuthorId "jim" "AuthorId not filled properly" - Expect.equal model.Title "A Fine Example" "Title not filled properly" - Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" - Expect.equal - model.PublishedOn - ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) - "PublishedOn not filled properly" - Expect.equal - model.UpdatedOn - ((Noda.epoch + Duration.FromHours 2).ToDateTimeUtc()) - "UpdatedOn not filled properly" - Expect.isFalse model.IsInPageList "IsInPageList should not have been set" - Expect.isTrue model.IsDefault "IsDefault should have been set" - Expect.equal model.Text "" "Text should have been blank" - Expect.isEmpty model.Metadata "Metadata should have been empty" - } - test "succeeds when page is not the default page" { - let model = DisplayPage.FromPageMinimal { WebLog.Empty with DefaultPage = "posts" } page - Expect.isFalse model.IsDefault "IsDefault should not have been set" - } - ] - testList "FromPage" [ - test "succeeds when the web log is on the domain root" { - let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-4"; UrlBase = "https://example.com" } - let model = DisplayPage.FromPage webLog page - Expect.equal model.Id "my-page" "Id not filled properly" - Expect.equal model.AuthorId "jim" "AuthorId not filled properly" - Expect.equal model.Title "A Fine Example" "Title not filled properly" - Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" - Expect.equal - model.PublishedOn - ((Noda.epoch + Duration.FromHours 4).ToDateTimeUtc()) - "PublishedOn not filled properly" - Expect.equal - model.UpdatedOn - ((Noda.epoch + Duration.FromHours 5).ToDateTimeUtc()) - "UpdatedOn not filled properly" - Expect.isFalse model.IsInPageList "IsInPageList should not have been set" - Expect.isFalse model.IsDefault "IsDefault should not have been set" - Expect.equal model.Text """Click Me!""" "Text not filled properly" - Expect.equal model.Metadata.Length 1 "Metadata not filled properly" - } - test "succeeds when the web log is not on the domain root" { - let model = DisplayPage.FromPage { WebLog.Empty with UrlBase = "https://example.com/a/b/c" } page - Expect.equal model.Text """Click Me!""" "Text not filled properly" - } - ] +let displayPageTests = testList "DisplayPage" [ + let page = + { Page.Empty with + Id = PageId "my-page" + AuthorId = WebLogUserId "jim" + Title = "A Fine Example" + Permalink = Permalink "about/a-fine-example.html" + PublishedOn = Noda.epoch + UpdatedOn = Noda.epoch + Duration.FromHours 1 + Text = """Click Me!""" + Metadata = [ { Name = "unit"; Value = "test" } ] } + testList "FromPageMinimal" [ + test "succeeds when page is default page" { + let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-1"; DefaultPage = "my-page" } + let model = DisplayPage.FromPageMinimal webLog page + Expect.equal model.Id "my-page" "Id not filled properly" + Expect.equal model.AuthorId "jim" "AuthorId not filled properly" + Expect.equal model.Title "A Fine Example" "Title not filled properly" + Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" + Expect.equal + model.PublishedOn + ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) + "PublishedOn not filled properly" + Expect.equal + model.UpdatedOn ((Noda.epoch + Duration.FromHours 2).ToDateTimeUtc()) "UpdatedOn not filled properly" + Expect.isFalse model.IsInPageList "IsInPageList should not have been set" + Expect.isTrue model.IsDefault "IsDefault should have been set" + Expect.equal model.Text "" "Text should have been blank" + Expect.isEmpty model.Metadata "Metadata should have been empty" + } + test "succeeds when page is not the default page" { + let model = DisplayPage.FromPageMinimal { WebLog.Empty with DefaultPage = "posts" } page + Expect.isFalse model.IsDefault "IsDefault should not have been set" + } ] + testList "FromPage" [ + test "succeeds when the web log is on the domain root" { + let webLog = { WebLog.Empty with TimeZone = "Etc/GMT-4"; UrlBase = "https://example.com" } + let model = DisplayPage.FromPage webLog page + Expect.equal model.Id "my-page" "Id not filled properly" + Expect.equal model.AuthorId "jim" "AuthorId not filled properly" + Expect.equal model.Title "A Fine Example" "Title not filled properly" + Expect.equal model.Permalink "about/a-fine-example.html" "Permalink not filled properly" + Expect.equal + model.PublishedOn + ((Noda.epoch + Duration.FromHours 4).ToDateTimeUtc()) + "PublishedOn not filled properly" + Expect.equal + model.UpdatedOn + ((Noda.epoch + Duration.FromHours 5).ToDateTimeUtc()) + "UpdatedOn not filled properly" + Expect.isFalse model.IsInPageList "IsInPageList should not have been set" + Expect.isFalse model.IsDefault "IsDefault should not have been set" + Expect.equal model.Text """Click Me!""" "Text not filled properly" + Expect.equal model.Metadata.Length 1 "Metadata not filled properly" + } + test "succeeds when the web log is not on the domain root" { + let model = DisplayPage.FromPage { WebLog.Empty with UrlBase = "https://example.com/a/b/c" } page + Expect.equal model.Text """Click Me!""" "Text not filled properly" + } + ] +] /// Unit tests for the DisplayRevision type -let displayRevisionTests = - test "DisplayRevision.FromRevision succeeds" { - let model = - DisplayRevision.FromRevision - { WebLog.Empty with TimeZone = "Etc/GMT+1" } - { Text = Html "howdy"; AsOf = Noda.epoch } - Expect.equal model.AsOf (Noda.epoch.ToDateTimeUtc()) "AsOf not filled properly" - Expect.equal - model.AsOfLocal ((Noda.epoch - Duration.FromHours 1).ToDateTimeUtc()) "AsOfLocal not filled properly" - Expect.equal model.Format "HTML" "Format not filled properly" - } +let displayRevisionTests = test "DisplayRevision.FromRevision succeeds" { + let model = + DisplayRevision.FromRevision + { WebLog.Empty with TimeZone = "Etc/GMT+1" } + { Text = Html "howdy"; AsOf = Noda.epoch } + Expect.equal model.AsOf (Noda.epoch.ToDateTimeUtc()) "AsOf not filled properly" + Expect.equal model.AsOfLocal ((Noda.epoch - Duration.FromHours 1).ToDateTimeUtc()) "AsOfLocal not filled properly" + Expect.equal model.Format "HTML" "Format not filled properly" +} open System.IO /// Unit tests for the DisplayTheme type -let displayThemeTests = - testList "DisplayTheme.FromTheme" [ - let theme = - { Id = ThemeId "the-theme" - Name = "Test Theme" - Version = "v0.1.2" - Templates = [ ThemeTemplate.Empty; ThemeTemplate.Empty ] } - test "succeeds when theme is in use and not on disk" { - let model = - DisplayTheme.FromTheme - (fun it -> Expect.equal it (ThemeId "the-theme") "The theme ID not passed correctly"; true) theme - Expect.equal model.Id "the-theme" "Id not filled properly" - Expect.equal model.Name "Test Theme" "Name not filled properly" - Expect.equal model.Version "v0.1.2" "Version not filled properly" - Expect.equal model.TemplateCount 2 "TemplateCount not filled properly" - Expect.isTrue model.IsInUse "IsInUse should have been set" - Expect.isFalse model.IsOnDisk "IsOnDisk should not have been set" - } - test "succeeds when the theme is not in use as is on disk" { - let file = File.Create "another-theme.zip" - try - let model = DisplayTheme.FromTheme (fun _ -> false) { theme with Id = ThemeId "another" } - Expect.isFalse model.IsInUse "IsInUse should not have been set" - Expect.isTrue model.IsOnDisk "IsOnDisk should have been set" - finally - file.Close() - file.Dispose() - File.Delete "another-theme.zip" - } - ] +let displayThemeTests = testList "DisplayTheme.FromTheme" [ + let theme = + { Id = ThemeId "the-theme" + Name = "Test Theme" + Version = "v0.1.2" + Templates = [ ThemeTemplate.Empty; ThemeTemplate.Empty ] } + test "succeeds when theme is in use and not on disk" { + let model = + DisplayTheme.FromTheme + (fun it -> Expect.equal it (ThemeId "the-theme") "The theme ID not passed correctly"; true) theme + Expect.equal model.Id "the-theme" "Id not filled properly" + Expect.equal model.Name "Test Theme" "Name not filled properly" + Expect.equal model.Version "v0.1.2" "Version not filled properly" + Expect.equal model.TemplateCount 2 "TemplateCount not filled properly" + Expect.isTrue model.IsInUse "IsInUse should have been set" + Expect.isFalse model.IsOnDisk "IsOnDisk should not have been set" + } + test "succeeds when the theme is not in use as is on disk" { + let file = File.Create "another-theme.zip" + try + let model = DisplayTheme.FromTheme (fun _ -> false) { theme with Id = ThemeId "another" } + Expect.isFalse model.IsInUse "IsInUse should not have been set" + Expect.isTrue model.IsOnDisk "IsOnDisk should have been set" + finally + file.Close() + file.Dispose() + File.Delete "another-theme.zip" + } +] /// Unit tests for the DisplayUpload type -let displayUploadTests = - test "DisplayUpload.FromUpload succeeds" { - let upload = - { Upload.Empty with - Id = UploadId "test-up" - Path = Permalink "2022/04/my-pic.jpg" - UpdatedOn = Noda.epoch } - let model = DisplayUpload.FromUpload { WebLog.Empty with TimeZone = "Etc/GMT-1" } Database upload - Expect.equal model.Id "test-up" "Id not filled properly" - Expect.equal model.Name "my-pic.jpg" "Name not filled properly" - Expect.equal model.Path "2022/04/" "Path not filled properly" - Expect.equal model.Source "Database" "Source not filled properly" - Expect.isSome model.UpdatedOn "There should have been an UpdatedOn value" - Expect.equal - model.UpdatedOn.Value ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "UpdatedOn not filled properly" - } +let displayUploadTests = test "DisplayUpload.FromUpload succeeds" { + let upload = + { Upload.Empty with + Id = UploadId "test-up" + Path = Permalink "2022/04/my-pic.jpg" + UpdatedOn = Noda.epoch } + let model = DisplayUpload.FromUpload { WebLog.Empty with TimeZone = "Etc/GMT-1" } Database upload + Expect.equal model.Id "test-up" "Id not filled properly" + Expect.equal model.Name "my-pic.jpg" "Name not filled properly" + Expect.equal model.Path "2022/04/" "Path not filled properly" + Expect.equal model.Source "Database" "Source not filled properly" + Expect.isSome model.UpdatedOn "There should have been an UpdatedOn value" + Expect.equal + model.UpdatedOn.Value ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "UpdatedOn not filled properly" +} /// Unit tests for the DisplayUser type -let displayUserTests = - testList "DisplayUser.FromUser" [ +let displayUserTests = testList "DisplayUser.FromUser" [ let minimalUser = { WebLogUser.Empty with Id = WebLogUserId "test-user" @@ -246,47 +236,234 @@ let displayUserTests = ] /// Unit tests for the EditCategoryModel type -let editCategoryModelTests = - testList "EditCategoryModel" [ - testList "FromCategory" [ - let minimalCat = { Category.Empty with Id = CategoryId "test-cat"; Name = "test"; Slug = "test-slug" } - test "succeeds with minimal information" { - let model = EditCategoryModel.FromCategory minimalCat - Expect.equal model.CategoryId "test-cat" "CategoryId not filled properly" - Expect.equal model.Name "test" "Name not filled properly" - Expect.equal model.Slug "test-slug" "Slug not filled properly" - Expect.equal model.Description "" "Description not filled properly" - Expect.equal model.ParentId "" "ParentId not filled properly" - } - test "succeeds with complete information" { - let model = - EditCategoryModel.FromCategory - { minimalCat with Description = Some "Testing"; ParentId = Some (CategoryId "parent") } - Expect.equal model.Description "Testing" "Description not filled properly" - Expect.equal model.ParentId "parent" "ParentId not filled properly" - } - ] - testList "IsNew" [ - test "succeeds for a new category" { - let model = EditCategoryModel.FromCategory { Category.Empty with Id = CategoryId "new" } - Expect.isTrue model.IsNew "Category should have been considered new" - } - test "succeeds for a non-new category" { - let model = EditCategoryModel.FromCategory Category.Empty - Expect.isFalse model.IsNew "Category should not have been considered new" - } - ] +let editCategoryModelTests = testList "EditCategoryModel" [ + testList "FromCategory" [ + let minimalCat = { Category.Empty with Id = CategoryId "test-cat"; Name = "test"; Slug = "test-slug" } + test "succeeds with minimal information" { + let model = EditCategoryModel.FromCategory minimalCat + Expect.equal model.CategoryId "test-cat" "CategoryId not filled properly" + Expect.equal model.Name "test" "Name not filled properly" + Expect.equal model.Slug "test-slug" "Slug not filled properly" + Expect.equal model.Description "" "Description not filled properly" + Expect.equal model.ParentId "" "ParentId not filled properly" + } + test "succeeds with complete information" { + let model = + EditCategoryModel.FromCategory + { minimalCat with Description = Some "Testing"; ParentId = Some (CategoryId "parent") } + Expect.equal model.Description "Testing" "Description not filled properly" + Expect.equal model.ParentId "parent" "ParentId not filled properly" + } ] + testList "IsNew" [ + test "succeeds for a new category" { + let model = EditCategoryModel.FromCategory { Category.Empty with Id = CategoryId "new" } + Expect.isTrue model.IsNew "Category should have been considered new" + } + test "succeeds for a non-new category" { + let model = EditCategoryModel.FromCategory Category.Empty + Expect.isFalse model.IsNew "Category should not have been considered new" + } + ] +] -/// All tests for the Domain namespace -let all = - testList - "ViewModels" - [ addBaseToRelativeUrlsTests - displayCustomFeedTests - displayPageTests - displayRevisionTests - displayThemeTests - displayUploadTests - displayUserTests - editCategoryModelTests ] +/// Unit tests for the EditCustomFeedModel type +let editCustomFeedModelTests = testList "EditCustomFeedModel" [ + let minimalPodcast = + { PodcastOptions.Empty with + Title = "My Minimal Podcast" + Summary = "As little as possible" + DisplayedAuthor = "The Tester" + Email = "thetester@example.com" + ImageUrl = Permalink "upload/my-image.png" + AppleCategory = "News" + Explicit = Clean } + // A GUID with all zeroes, ending in "a" + let aGuid = + let guidBytes = Guid.Empty.ToByteArray() + guidBytes[15] <- byte 10 + Guid guidBytes + let fullPodcast = + { minimalPodcast with + Subtitle = Some "A Podcast about Little" + ItemsInFeed = 17 + AppleSubcategory = Some "Analysis" + DefaultMediaType = Some "video/mpeg4" + MediaBaseUrl = Some "a/b/c" + PodcastGuid = Some aGuid + FundingUrl = Some "https://pay.me" + FundingText = Some "Gimme Money!" + Medium = Some Newsletter } + testList "FromFeed" [ + test "succeeds with no podcast" { + let model = + EditCustomFeedModel.FromFeed + { Id = CustomFeedId "test-feed" + Source = Category (CategoryId "no-podcast") + Path = Permalink "no-podcast.xml" + Podcast = None } + Expect.equal model.Id "test-feed" "Id not filled properly" + Expect.equal model.SourceType "category" "SourceType not filled properly" + Expect.equal model.SourceValue "no-podcast" "SourceValue not filled properly" + Expect.equal model.Path "no-podcast.xml" "Path not filled properly" + Expect.isFalse model.IsPodcast "IsPodcast should not have been set" + Expect.equal model.Title "" "Title should be the default value" + Expect.equal model.Subtitle "" "Subtitle should be the default value" + Expect.equal model.ItemsInFeed 25 "ItemsInFeed should be the default value" + Expect.equal model.Summary "" "Summary should be the default value" + Expect.equal model.DisplayedAuthor "" "DisplayedAuthor should be the default value" + Expect.equal model.Email "" "Email should be the default value" + Expect.equal model.ImageUrl "" "ImageUrl should be the default value" + Expect.equal model.AppleCategory "" "AppleCategory should be the default value" + Expect.equal model.AppleSubcategory "" "AppleSubcategory should be the default value" + Expect.equal model.Explicit "no" "Explicit should be the default value" + Expect.equal model.DefaultMediaType "audio/mpeg" "DefaultMediaType should be the default value" + Expect.equal model.MediaBaseUrl "" "MediaBaseUrl should be the default value" + Expect.equal model.FundingUrl "" "FundingUrl should be the default value" + Expect.equal model.FundingText "" "FundingText should be the default value" + Expect.equal model.PodcastGuid "" "PodcastGuid should be the default value" + Expect.equal model.Medium "" "Medium should be the default value" + } + test "succeeds with minimal podcast" { + let model = + EditCustomFeedModel.FromFeed + { Id = CustomFeedId "minimal-feed" + Source = Tag "min-podcast" + Path = Permalink "min-podcast.xml" + Podcast = Some minimalPodcast } + Expect.equal model.Id "minimal-feed" "Id not filled properly" + Expect.equal model.SourceType "tag" "SourceType not filled properly" + Expect.equal model.SourceValue "min-podcast" "SourceValue not filled properly" + Expect.equal model.Path "min-podcast.xml" "Path not filled properly" + Expect.isTrue model.IsPodcast "IsPodcast should have been set" + Expect.equal model.Title "My Minimal Podcast" "Title not filled properly" + Expect.equal model.Subtitle "" "Subtitle not filled properly (should be blank)" + Expect.equal model.ItemsInFeed 0 "ItemsInFeed not filled properly" + Expect.equal model.Summary "As little as possible" "Summary not filled properly" + Expect.equal model.DisplayedAuthor "The Tester" "DisplayedAuthor not filled properly" + Expect.equal model.Email "thetester@example.com" "Email not filled properly" + Expect.equal model.ImageUrl "upload/my-image.png" "ImageUrl not filled properly" + Expect.equal model.AppleCategory "News" "AppleCategory not filled properly" + Expect.equal model.AppleSubcategory "" "AppleSubcategory not filled properly (should be blank)" + Expect.equal model.Explicit "clean" "Explicit not filled properly" + Expect.equal model.DefaultMediaType "" "DefaultMediaType not filled properly (should be blank)" + Expect.equal model.MediaBaseUrl "" "MediaBaseUrl not filled properly (should be blank)" + Expect.equal model.FundingUrl "" "FundingUrl not filled properly (should be blank)" + Expect.equal model.FundingText "" "FundingText not filled properly (should be blank)" + Expect.equal model.PodcastGuid "" "PodcastGuid not filled properly (should be blank)" + Expect.equal model.Medium "" "Medium not filled properly (should be blank)" + } + test "succeeds with full podcast" { + let model = + EditCustomFeedModel.FromFeed + { Id = CustomFeedId "full-feed" + Source = Tag "whole-enchilada" + Path = Permalink "full-podcast.xml" + Podcast = Some fullPodcast } + Expect.equal model.Id "full-feed" "Id not filled properly" + Expect.equal model.SourceType "tag" "SourceType not filled properly" + Expect.equal model.SourceValue "whole-enchilada" "SourceValue not filled properly" + Expect.equal model.Path "full-podcast.xml" "Path not filled properly" + Expect.isTrue model.IsPodcast "IsPodcast should have been set" + Expect.equal model.Title "My Minimal Podcast" "Title not filled properly" + Expect.equal model.Subtitle "A Podcast about Little" "Subtitle not filled properly" + Expect.equal model.ItemsInFeed 17 "ItemsInFeed not filled properly" + Expect.equal model.Summary "As little as possible" "Summary not filled properly" + Expect.equal model.DisplayedAuthor "The Tester" "DisplayedAuthor not filled properly" + Expect.equal model.Email "thetester@example.com" "Email not filled properly" + Expect.equal model.ImageUrl "upload/my-image.png" "ImageUrl not filled properly" + Expect.equal model.AppleCategory "News" "AppleCategory not filled properly" + Expect.equal model.AppleSubcategory "Analysis" "AppleSubcategory not filled properly" + Expect.equal model.Explicit "clean" "Explicit not filled properly" + Expect.equal model.DefaultMediaType "video/mpeg4" "DefaultMediaType not filled properly" + Expect.equal model.MediaBaseUrl "a/b/c" "MediaBaseUrl not filled properly" + Expect.equal model.FundingUrl "https://pay.me" "FundingUrl not filled properly" + Expect.equal model.FundingText "Gimme Money!" "FundingText not filled properly" + Expect.equal model.PodcastGuid "00000000-0000-0000-0000-00000000000a" "PodcastGuid not filled properly" + Expect.equal model.Medium "newsletter" "Medium not filled properly" + } + ] + testList "UpdateFeed" [ + test "succeeds with no podcast" { + let model = + { EditCustomFeedModel.Empty with SourceType = "tag"; SourceValue = "no-audio"; Path = "no-podcast.xml" } + let feed = + model.UpdateFeed + { CustomFeed.Empty with Id = CustomFeedId "no-podcast-feed"; Podcast = Some fullPodcast } + Expect.equal feed.Id (CustomFeedId "no-podcast-feed") "Id not filled properly" + Expect.equal feed.Source (Tag "no-audio") "Source not filled properly" + Expect.equal feed.Path (Permalink "no-podcast.xml") "Path not filled properly" + Expect.isNone feed.Podcast "Podcast not filled properly" + } + test "succeeds with minimal podcast" { + let model = EditCustomFeedModel.FromFeed { CustomFeed.Empty with Podcast = Some minimalPodcast } + let feed = model.UpdateFeed CustomFeed.Empty + Expect.equal feed.Source (Category (CategoryId "")) "Source not filled properly" + Expect.equal feed.Path (Permalink "") "Path not filled properly" + Expect.isSome feed.Podcast "Podcast should be present" + let podcast = feed.Podcast.Value + Expect.equal podcast.Title "My Minimal Podcast" "Podcast title not filled properly" + Expect.isNone podcast.Subtitle "Podcast subtitle not filled properly" + Expect.equal podcast.ItemsInFeed 0 "Podcast items in feed not filled properly" + Expect.equal podcast.Summary "As little as possible" "Podcast summary not filled properly" + Expect.equal podcast.DisplayedAuthor "The Tester" "Podcast author not filled properly" + Expect.equal podcast.Email "thetester@example.com" "Podcast email not filled properly" + Expect.equal podcast.Explicit Clean "Podcast explicit rating not filled properly" + Expect.equal podcast.AppleCategory "News" "Podcast Apple category not filled properly" + Expect.isNone podcast.AppleSubcategory "Podcast Apple subcategory not filled properly" + Expect.isNone podcast.DefaultMediaType "Podcast default media type not filled properly" + Expect.isNone podcast.MediaBaseUrl "Podcast media base URL not filled properly" + Expect.isNone podcast.PodcastGuid "Podcast GUID not filled properly" + Expect.isNone podcast.FundingUrl "Podcast funding URL not filled properly" + Expect.isNone podcast.FundingText "Podcast funding text not filled properly" + Expect.isNone podcast.Medium "Podcast medium not filled properly" + } + test "succeeds with full podcast" { + let model = EditCustomFeedModel.FromFeed { CustomFeed.Empty with Podcast = Some fullPodcast } + let feed = model.UpdateFeed CustomFeed.Empty + Expect.equal feed.Source (Category (CategoryId "")) "Source not filled properly" + Expect.equal feed.Path (Permalink "") "Path not filled properly" + Expect.isSome feed.Podcast "Podcast should be present" + let podcast = feed.Podcast.Value + Expect.equal podcast.Title "My Minimal Podcast" "Podcast title not filled properly" + Expect.equal podcast.Subtitle (Some "A Podcast about Little") "Podcast subtitle not filled properly" + Expect.equal podcast.ItemsInFeed 17 "Podcast items in feed not filled properly" + Expect.equal podcast.Summary "As little as possible" "Podcast summary not filled properly" + Expect.equal podcast.DisplayedAuthor "The Tester" "Podcast author not filled properly" + Expect.equal podcast.Email "thetester@example.com" "Podcast email not filled properly" + Expect.equal podcast.Explicit Clean "Podcast explicit rating not filled properly" + Expect.equal podcast.AppleCategory "News" "Podcast Apple category not filled properly" + Expect.equal podcast.AppleSubcategory (Some "Analysis") "Podcast Apple subcategory not filled properly" + Expect.equal podcast.DefaultMediaType (Some "video/mpeg4") "Podcast default media type not filled properly" + Expect.equal podcast.MediaBaseUrl (Some "a/b/c") "Podcast media base URL not filled properly" + Expect.equal podcast.PodcastGuid (Some aGuid) "Podcast GUID not filled properly" + Expect.equal podcast.FundingUrl (Some "https://pay.me") "Podcast funding URL not filled properly" + Expect.equal podcast.FundingText (Some "Gimme Money!") "Podcast funding text not filled properly" + Expect.equal podcast.Medium (Some Newsletter) "Podcast medium not filled properly" + } + ] +] + +/// Unit tests for the EditMyInfoModel type +let editMyInfoModelTests = test "EditMyInfoModel.FromUser succeeds" { + let model = EditMyInfoModel.FromUser { WebLogUser.Empty with FirstName = "A"; LastName = "B"; PreferredName = "C" } + Expect.equal model.FirstName "A" "FirstName not filled properly" + Expect.equal model.LastName "B" "LastName not filled properly" + Expect.equal model.PreferredName "C" "PreferredName not filled properly" + Expect.equal model.NewPassword "" "NewPassword not filled properly" + Expect.equal model.NewPasswordConfirm "" "NewPasswordConfirm not filled properly" +} + +/// All tests in the Domain.ViewModels file +let all = testList "ViewModels" [ + addBaseToRelativeUrlsTests + displayCustomFeedTests + displayPageTests + displayRevisionTests + displayThemeTests + displayUploadTests + displayUserTests + editCategoryModelTests + editCustomFeedModelTests + editMyInfoModelTests +] -- 2.45.1 From 12c46c82041559981ae354d79dac832a0c82e03f Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 12 Jan 2024 21:32:02 -0500 Subject: [PATCH 046/123] Add edit page model tests --- src/MyWebLog.Tests/ViewModelsTests.fs | 118 ++++++++++++++++++++++++++ 1 file changed, 118 insertions(+) diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index e5c48fd..fde6da3 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -454,6 +454,123 @@ let editMyInfoModelTests = test "EditMyInfoModel.FromUser succeeds" { Expect.equal model.NewPasswordConfirm "" "NewPasswordConfirm not filled properly" } +let editPageModelTests = testList "EditPageModel" [ + let fullPage = + { Page.Empty with + Id = PageId "the-page" + Title = "Test Page" + Permalink = Permalink "blog/page.html" + Template = Some "bork" + IsInPageList = true + Revisions = + [ { AsOf = Noda.epoch + Duration.FromHours 1; Text = Markdown "# Howdy!" } + { AsOf = Noda.epoch; Text = Html "

      howdy

      " } ] + Metadata = [ { Name = "Test"; Value = "me" }; { Name = "Two"; Value = "2" } ] } + testList "FromPage" [ + test "succeeds for empty page" { + let model = EditPageModel.FromPage { Page.Empty with Id = PageId "abc" } + Expect.equal model.PageId "abc" "PageId not filled properly" + Expect.equal model.Title "" "Title not filled properly" + Expect.equal model.Permalink "" "Permalink not filled properly" + Expect.equal model.Template "" "Template not filled properly" + Expect.isFalse model.IsShownInPageList "IsShownInPageList should not have been set" + Expect.equal model.Source "HTML" "Source not filled properly" + Expect.equal model.Text "" "Text not set properly" + Expect.equal model.MetaNames.Length 1 "MetaNames should have one entry" + Expect.equal model.MetaNames[0] "" "Meta name not set properly" + Expect.equal model.MetaValues.Length 1 "MetaValues should have one entry" + Expect.equal model.MetaValues[0] "" "Meta value not set properly" + } + test "succeeds for filled page" { + let model = EditPageModel.FromPage fullPage + Expect.equal model.PageId "the-page" "PageId not filled properly" + Expect.equal model.Title "Test Page" "Title not filled properly" + Expect.equal model.Permalink "blog/page.html" "Permalink not filled properly" + Expect.equal model.Template "bork" "Template not filled properly" + Expect.isTrue model.IsShownInPageList "IsShownInPageList should have been set" + Expect.equal model.Source "Markdown" "Source not filled properly" + Expect.equal model.Text "# Howdy!" "Text not filled properly" + Expect.equal model.MetaNames.Length 2 "MetaNames should have two entries" + Expect.equal model.MetaNames[0] "Test" "Meta name 0 not set properly" + Expect.equal model.MetaNames[1] "Two" "Meta name 1 not set properly" + Expect.equal model.MetaValues.Length 2 "MetaValues should have two entries" + Expect.equal model.MetaValues[0] "me" "Meta value 0 not set properly" + Expect.equal model.MetaValues[1] "2" "Meta value 1 not set properly" + } + ] + testList "IsNew" [ + test "succeeds for a new page" { + Expect.isTrue + (EditPageModel.FromPage { Page.Empty with Id = PageId "new" }).IsNew "IsNew should have been set" + } + test "succeeds for an existing page" { + Expect.isFalse (EditPageModel.FromPage Page.Empty).IsNew "IsNew should not have been set" + } + ] + testList "UpdatePage" [ + test "succeeds with minimal changes" { + let model = { EditPageModel.FromPage fullPage with Title = "Updated Page"; IsShownInPageList = false } + let page = model.UpdatePage fullPage (Noda.epoch + Duration.FromHours 4) + Expect.equal page.Title "Updated Page" "Title not filled properly" + Expect.equal page.Permalink (Permalink "blog/page.html") "Permalink not filled properly" + Expect.isEmpty page.PriorPermalinks "PriorPermalinks should be empty" + Expect.equal page.UpdatedOn (Noda.epoch + Duration.FromHours 4) "UpdatedOn not filled properly" + Expect.isFalse page.IsInPageList "IsInPageList should have been unset" + Expect.equal page.Template (Some "bork") "Template not filled properly" + Expect.equal page.Text "

      Howdy!

      \n" "Text not filled properly" + Expect.equal page.Metadata.Length 2 "There should be 2 metadata items" + let item1 = List.item 0 page.Metadata + Expect.equal item1.Name "Test" "Meta item 0 name not filled properly" + Expect.equal item1.Value "me" "Meta item 0 value not filled properly" + let item2 = List.item 1 page.Metadata + Expect.equal item2.Name "Two" "Meta item 1 name not filled properly" + Expect.equal item2.Value "2" "Meta item 1 value not filled properly" + Expect.equal page.Revisions.Length 2 "There should be 2 revisions" + let rev1 = List.item 0 page.Revisions + Expect.equal rev1.AsOf (Noda.epoch + Duration.FromHours 1) "Revision 0 as-of not filled properly" + Expect.equal rev1.Text (Markdown "# Howdy!") "Revision 0 text not filled properly" + let rev2 = List.item 1 page.Revisions + Expect.equal rev2.AsOf Noda.epoch "Revision 1 as-of not filled properly" + Expect.equal rev2.Text (Html "

      howdy

      ") "Revision 1 text not filled properly" + } + test "succeeds with all changes" { + let model = + { PageId = "this-page" + Title = "My Updated Page" + Permalink = "blog/updated.html" + Template = "" + IsShownInPageList = false + Source = "HTML" + Text = "

      Howdy, partners!

      " + MetaNames = [| "banana"; "apple"; "grape" |] + MetaValues = [| "monkey"; "zebra"; "ape" |] } + let now = Noda.epoch + Duration.FromDays 7 + let page = model.UpdatePage fullPage now + Expect.equal page.Title "My Updated Page" "Title not filled properly" + Expect.equal page.Permalink (Permalink "blog/updated.html") "Permalink not filled properly" + Expect.equal page.PriorPermalinks [ Permalink "blog/page.html" ] "PriorPermalinks not filled properly" + Expect.equal page.UpdatedOn now "UpdatedOn not filled properly" + Expect.isFalse page.IsInPageList "IsInPageList should not have been set" + Expect.isNone page.Template "Template not filled properly" + Expect.equal page.Text "

      Howdy, partners!

      " "Text not filled properly" + Expect.equal page.Metadata.Length 3 "There should be 3 metadata items" + let item1 = List.item 0 page.Metadata + Expect.equal item1.Name "apple" "Meta item 0 name not filled properly" + Expect.equal item1.Value "zebra" "Meta item 0 value not filled properly" + let item2 = List.item 1 page.Metadata + Expect.equal item2.Name "banana" "Meta item 1 name not filled properly" + Expect.equal item2.Value "monkey" "Meta item 1 value not filled properly" + let item3 = List.item 2 page.Metadata + Expect.equal item3.Name "grape" "Meta item 2 name not filled properly" + Expect.equal item3.Value "ape" "Meta item 2 value not filled properly" + Expect.equal page.Revisions.Length 3 "There should be 3 revisions" + Expect.equal page.Revisions.Head.AsOf now "Head revision as-of not filled properly" + Expect.equal + page.Revisions.Head.Text (Html "

      Howdy, partners!

      ") "Head revision text not filled properly" + } + ] +] + /// All tests in the Domain.ViewModels file let all = testList "ViewModels" [ addBaseToRelativeUrlsTests @@ -466,4 +583,5 @@ let all = testList "ViewModels" [ editCategoryModelTests editCustomFeedModelTests editMyInfoModelTests + editPageModelTests ] -- 2.45.1 From 888f56e75ed366f9ec10f56dabeb856d8ce2576e Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 14 Jan 2024 13:59:46 -0500 Subject: [PATCH 047/123] WIP on edit post model tests --- src/MyWebLog.Tests/ViewModelsTests.fs | 137 ++++++++++++++++++++++++++ 1 file changed, 137 insertions(+) diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index fde6da3..909c4f6 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -571,6 +571,142 @@ let editPageModelTests = testList "EditPageModel" [ ] ] +/// Unit tests for the EditPostModel type +let editPostModelTests = testList "EditPostModel" [ + let fullPost = + { Post.Empty with + Id = PostId "a-post" + Status = Published + Title = "A Post" + Permalink = Permalink "1970/01/a-post.html" + PublishedOn = Some (Noda.epoch + Duration.FromDays 7) + UpdatedOn = Noda.epoch + Duration.FromDays 365 + Template = Some "demo" + Text = "

      A post!

      " + CategoryIds = [ CategoryId "cat-a"; CategoryId "cat-b"; CategoryId "cat-n" ] + Tags = [ "demo"; "post" ] + Metadata = [ { Name = "A Meta"; Value = "A Value" } ] + Revisions = + [ { AsOf = Noda.epoch + Duration.FromDays 365; Text = Html "

      A post!

      " } + { AsOf = Noda.epoch + Duration.FromDays 7; Text = Markdown "A post!" } ] + Episode = + Some { Media = "a-post-ep.mp3" + Length = 15555L + Duration = Some (Duration.FromMinutes 15L + Duration.FromSeconds 22L) + MediaType = Some "audio/mpeg3" + ImageUrl = Some "uploads/podcast-cover.jpg" + Subtitle = Some "Narration" + Explicit = Some Clean + Chapters = None // for future implementation + ChapterFile = Some "uploads/1970/01/chapters.txt" + ChapterType = Some "chapters" + ChapterWaypoints = Some true + TranscriptUrl = Some "uploads/1970/01/transcript.txt" + TranscriptType = Some "transcript" + TranscriptLang = Some "EN-us" + TranscriptCaptions = Some true + SeasonNumber = Some 3 + SeasonDescription = Some "Season Three" + EpisodeNumber = Some 322. + EpisodeDescription = Some "Episode 322" } } + testList "FromPost" [ + test "succeeds for empty post" { + let model = EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "lalala" } + Expect.equal model.PostId "lalala" "PostId not filled properly" + Expect.equal model.Title "" "Title not filled properly" + Expect.equal model.Permalink "" "Permalink not filled properly" + Expect.equal model.Source "HTML" "Source not filled properly" + Expect.equal model.Text "" "Text not filled properly" + Expect.equal model.Tags "" "Tags not filled properly" + Expect.equal model.Template "" "Template not filled properly" + Expect.isEmpty model.CategoryIds "CategoryIds not filled properly" + Expect.equal model.Status (string Draft) "Status not filled properly" + Expect.isFalse model.DoPublish "DoPublish should not have been set" + Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" + Expect.equal model.MetaNames[0] "" "Meta name 0 not filled properly" + Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" + Expect.equal model.MetaValues[0] "" "Meta value 0 not filled properly" + Expect.isFalse model.SetPublished "SetPublished should not have been set" + Expect.isFalse model.PubOverride.HasValue "PubOverride not filled properly" + Expect.isFalse model.SetUpdated "SetUpdated should not have been set" + Expect.isFalse model.IsEpisode "IsEpisode should not have been set" + Expect.equal model.Media "" "Media not filled properly" + Expect.equal model.Length 0L "Length not filled properly" + Expect.equal model.Duration "" "Duration not filled properly" + Expect.equal model.MediaType "" "MediaType not filled properly" + Expect.equal model.ImageUrl "" "ImageUrl not filled properly" + Expect.equal model.Subtitle "" "Subtitle not filled properly" + Expect.equal model.Explicit "" "Explicit not filled properly" + Expect.equal model.ChapterFile "" "ChapterFile not filled properly" + Expect.equal model.ChapterType "" "ChapterType not filled properly" + Expect.isFalse model.ContainsWaypoints "ContainsWaypoints should not have been set" + Expect.equal model.TranscriptUrl "" "TranscriptUrl not filled properly" + Expect.equal model.TranscriptType "" "TranscriptType not filled properly" + Expect.equal model.TranscriptLang "" "TranscriptLang not filled properly" + Expect.isFalse model.TranscriptCaptions "TranscriptCaptions should not have been set" + Expect.equal model.SeasonNumber 0 "SeasonNumber not filled properly" + Expect.equal model.SeasonDescription "" "SeasonDescription not filled properly" + Expect.equal model.EpisodeNumber "" "EpisodeNumber not filled properly" + Expect.equal model.EpisodeDescription "" "EpisodeDescription not filled properly" + } + test "succeeds for full post" { + let model = EditPostModel.FromPost { WebLog.Empty with TimeZone = "Etc/GMT+1" } fullPost + Expect.equal model.PostId "a-post" "PostId not filled properly" + Expect.equal model.Title "A Post" "Title not filled properly" + Expect.equal model.Permalink "1970/01/a-post.html" "Permalink not filled properly" + Expect.equal model.Source "HTML" "Source not filled properly" + Expect.equal model.Text "

      A post!

      " "Text not filled properly" + Expect.equal model.Tags "demo, post" "Tags not filled properly" + Expect.equal model.Template "demo" "Template not filled properly" + Expect.equal model.CategoryIds [| "cat-a"; "cat-b"; "cat-n" |] "CategoryIds not filled properly" + Expect.equal model.Status (string Published) "Status not filled properly" + Expect.isFalse model.DoPublish "DoPublish should not have been set" + Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" + Expect.equal model.MetaNames[0] "A Meta" "Meta name 0 not filled properly" + Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" + Expect.equal model.MetaValues[0] "A Value" "Meta value 0 not filled properly" + Expect.isFalse model.SetPublished "SetPublished should not have been set" + Expect.isTrue model.PubOverride.HasValue "PubOverride should not have been null" + Expect.equal + model.PubOverride.Value + ((Noda.epoch + Duration.FromDays 7 - Duration.FromHours 1).ToDateTimeUtc()) + "PubOverride not filled properly" + Expect.isFalse model.SetUpdated "SetUpdated should not have been set" + Expect.isTrue model.IsEpisode "IsEpisode should have been set" + Expect.equal model.Media "a-post-ep.mp3" "Media not filled properly" + Expect.equal model.Length 15555L "Length not filled properly" + Expect.equal model.Duration "0:15:22" "Duration not filled properly" + Expect.equal model.MediaType "audio/mpeg3" "MediaType not filled properly" + Expect.equal model.ImageUrl "uploads/podcast-cover.jpg" "ImageUrl not filled properly" + Expect.equal model.Subtitle "Narration" "Subtitle not filled properly" + Expect.equal model.Explicit "clean" "Explicit not filled properly" + Expect.equal model.ChapterFile "uploads/1970/01/chapters.txt" "ChapterFile not filled properly" + Expect.equal model.ChapterType "chapters" "ChapterType not filled properly" + Expect.isTrue model.ContainsWaypoints "ContainsWaypoints should have been set" + Expect.equal model.TranscriptUrl "uploads/1970/01/transcript.txt" "TranscriptUrl not filled properly" + Expect.equal model.TranscriptType "transcript" "TranscriptType not filled properly" + Expect.equal model.TranscriptLang "EN-us" "TranscriptLang not filled properly" + Expect.isTrue model.TranscriptCaptions "TranscriptCaptions should have been set" + Expect.equal model.SeasonNumber 3 "SeasonNumber not filled properly" + Expect.equal model.SeasonDescription "Season Three" "SeasonDescription not filled properly" + Expect.equal model.EpisodeNumber "322" "EpisodeNumber not filled properly" + Expect.equal model.EpisodeDescription "Episode 322" "EpisodeDescription not filled properly" + } + ] + testList "IsNew" [ + test "succeeds for a new post" { + Expect.isTrue + (EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "new" }).IsNew + "IsNew should be set for new post" + } + test "succeeds for a not-new post" { + Expect.isFalse + (EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "nu" }).IsNew + "IsNew should not be set for not-new post" + } + ] +] + /// All tests in the Domain.ViewModels file let all = testList "ViewModels" [ addBaseToRelativeUrlsTests @@ -584,4 +720,5 @@ let all = testList "ViewModels" [ editCustomFeedModelTests editMyInfoModelTests editPageModelTests + editPostModelTests ] -- 2.45.1 From cb94222558e3421b0ffbe00b50e6ce779b851b9f Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 15 Jan 2024 17:18:58 -0500 Subject: [PATCH 048/123] Finish edit post model tests --- src/MyWebLog.Tests/ViewModelsTests.fs | 124 ++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index 909c4f6..1fb541d 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -705,6 +705,130 @@ let editPostModelTests = testList "EditPostModel" [ "IsNew should not be set for not-new post" } ] + let updatedModel = + { EditPostModel.FromPost WebLog.Empty fullPost with + Title = "An Updated Post" + Permalink = "1970/01/updated-post.html" + Source = "HTML" + Text = "

      An updated post!

      " + Tags = "Zebras, Aardvarks, , Turkeys" + Template = "updated" + CategoryIds = [| "cat-x"; "cat-y" |] + MetaNames = [| "Zed Meta"; "A Meta" |] + MetaValues = [| "A Value"; "Zed Value" |] + Media = "an-updated-ep.mp3" + Length = 14444L + Duration = "0:14:42" + MediaType = "audio/mp3" + ImageUrl = "updated-cover.png" + Subtitle = "Talking" + Explicit = "no" + ChapterFile = "updated-chapters.txt" + ChapterType = "indexes" + TranscriptUrl = "updated-transcript.txt" + TranscriptType = "subtitles" + TranscriptLang = "ES-mx" + SeasonNumber = 4 + SeasonDescription = "Season Fo" + EpisodeNumber = "432.1" + EpisodeDescription = "Four Three Two pt One" } + testList "UpdatePost" [ + test "succeeds for a full podcast episode" { + let post = updatedModel.UpdatePost fullPost (Noda.epoch + Duration.FromDays 400) + Expect.equal post.Title "An Updated Post" "Title not filled properly" + Expect.equal post.Permalink (Permalink "1970/01/updated-post.html") "Permalink not filled properly" + Expect.equal post.PriorPermalinks [ Permalink "1970/01/a-post.html" ] "PriorPermalinks not filled properly" + Expect.equal post.PublishedOn fullPost.PublishedOn "PublishedOn should not have changed" + Expect.equal post.UpdatedOn (Noda.epoch + Duration.FromDays 400) "UpdatedOn not filled properly" + Expect.equal post.Text "

      An updated post!

      " "Text not filled properly" + Expect.equal post.Tags [ "aardvarks"; "turkeys"; "zebras" ] "Tags not filled properly" + Expect.equal post.Template (Some "updated") "Template not filled properly" + Expect.equal post.CategoryIds [ CategoryId "cat-x"; CategoryId "cat-y" ] "Categories not filled properly" + Expect.equal post.Metadata.Length 2 "There should have been 2 meta items" + Expect.equal post.Metadata[0].Name "A Meta" "Meta item 0 name not filled properly" + Expect.equal post.Metadata[0].Value "Zed Value" "Meta item 0 value not filled properly" + Expect.equal post.Metadata[1].Name "Zed Meta" "Meta item 1 name not filled properly" + Expect.equal post.Metadata[1].Value "A Value" "Meta item 1 value not filled properly" + Expect.equal post.Revisions.Length 3 "There should have been 3 revisions" + Expect.equal + post.Revisions[0].AsOf (Noda.epoch + Duration.FromDays 400) "Revision 0 AsOf not filled properly" + Expect.equal post.Revisions[0].Text (Html "

      An updated post!

      ") "Revision 0 Text not filled properly" + Expect.isSome post.Episode "There should have been a podcast episode" + let ep = post.Episode.Value + Expect.equal ep.Media "an-updated-ep.mp3" "Media not filled properly" + Expect.equal ep.Length 14444L "Length not filled properly" + Expect.equal + ep.Duration (Some (Duration.FromMinutes 14L + Duration.FromSeconds 42L)) "Duration not filled properly" + Expect.equal ep.MediaType (Some "audio/mp3") "MediaType not filled properly" + Expect.equal ep.ImageUrl (Some "updated-cover.png") "ImageUrl not filled properly" + Expect.equal ep.Subtitle (Some "Talking") "Subtitle not filled properly" + Expect.equal ep.Explicit (Some No) "ExplicitRating not filled properly" + Expect.equal ep.ChapterFile (Some "updated-chapters.txt") "ChapterFile not filled properly" + Expect.equal ep.ChapterType (Some "indexes") "ChapterType not filled properly" + Expect.equal ep.ChapterWaypoints (Some true) "ChapterWaypoints should have been set" + Expect.equal ep.TranscriptUrl (Some "updated-transcript.txt") "TranscriptUrl not filled properly" + Expect.equal ep.TranscriptType (Some "subtitles") "TranscriptType not filled properly" + Expect.equal ep.TranscriptLang (Some "ES-mx") "TranscriptLang not filled properly" + Expect.equal ep.TranscriptCaptions (Some true) "TranscriptCaptions should have been set" + Expect.equal ep.SeasonNumber (Some 4) "SeasonNumber not filled properly" + Expect.equal ep.SeasonDescription (Some "Season Fo") "SeasonDescription not filled properly" + Expect.equal ep.EpisodeNumber (Some 432.1) "EpisodeNumber not filled properly" + Expect.equal ep.EpisodeDescription (Some "Four Three Two pt One") "EpisodeDescription not filled properly" + } + test "succeeds for a minimal podcast episode" { + let minModel = + { updatedModel with + Duration = "" + MediaType = "" + ImageUrl = "" + Subtitle = "" + Explicit = "" + ChapterFile = "" + ChapterType = "" + ContainsWaypoints = false + TranscriptUrl = "" + TranscriptType = "" + TranscriptLang = "" + TranscriptCaptions = false + SeasonNumber = 0 + SeasonDescription = "" + EpisodeNumber = "" + EpisodeDescription = "" } + let post = minModel.UpdatePost fullPost (Noda.epoch + Duration.FromDays 500) + Expect.isSome post.Episode "There should have been a podcast episode" + let ep = post.Episode.Value + Expect.equal ep.Media "an-updated-ep.mp3" "Media not filled properly" + Expect.equal ep.Length 14444L "Length not filled properly" + Expect.isNone ep.Duration "Duration not filled properly" + Expect.isNone ep.MediaType "MediaType not filled properly" + Expect.isNone ep.ImageUrl "ImageUrl not filled properly" + Expect.isNone ep.Subtitle "Subtitle not filled properly" + Expect.isNone ep.Explicit "ExplicitRating not filled properly" + Expect.isNone ep.ChapterFile "ChapterFile not filled properly" + Expect.isNone ep.ChapterType "ChapterType not filled properly" + Expect.isNone ep.ChapterWaypoints "ChapterWaypoints should have been set" + Expect.isNone ep.TranscriptUrl "TranscriptUrl not filled properly" + Expect.isNone ep.TranscriptType "TranscriptType not filled properly" + Expect.isNone ep.TranscriptLang "TranscriptLang not filled properly" + Expect.isNone ep.TranscriptCaptions "TranscriptCaptions should have been set" + Expect.isNone ep.SeasonNumber "SeasonNumber not filled properly" + Expect.isNone ep.SeasonDescription "SeasonDescription not filled properly" + Expect.isNone ep.EpisodeNumber "EpisodeNumber not filled properly" + Expect.isNone ep.EpisodeDescription "EpisodeDescription not filled properly" + } + test "succeeds for no podcast episode and no template" { + let post = { updatedModel with IsEpisode = false; Template = "" }.UpdatePost fullPost Noda.epoch + Expect.isNone post.Template "Template not filled properly" + Expect.isNone post.Episode "Episode not filled properly" + } + test "succeeds when publishing a draft" { + let post = + { updatedModel with DoPublish = true }.UpdatePost + { fullPost with Status = Draft } (Noda.epoch + Duration.FromDays 375) + Expect.equal post.Status Published "Status not set properly" + Expect.equal post.PublishedOn (Some (Noda.epoch + Duration.FromDays 375)) "PublishedOn not set properly" + } + ] ] /// All tests in the Domain.ViewModels file -- 2.45.1 From cbe391fa898e02804032f512db5f6c5553d081cc Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 15 Jan 2024 19:04:01 -0500 Subject: [PATCH 049/123] Add edit redirect tests --- src/MyWebLog.Domain/ViewModels.fs | 269 ++++++++++++-------------- src/MyWebLog.Tests/ViewModelsTests.fs | 19 ++ 2 files changed, 147 insertions(+), 141 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 3bbdea0..416ff97 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -96,11 +96,10 @@ type DisplayCustomFeed = { |> Option.defaultValue "--INVALID; DELETE THIS FEED--" |> sprintf "Category: %s" | Tag tag -> $"Tag: {tag}" - { Id = string feed.Id - Source = source - Path = string feed.Path - IsPodcast = Option.isSome feed.Podcast - } + { Id = string feed.Id + Source = source + Path = string feed.Path + IsPodcast = Option.isSome feed.Podcast } /// Details about a page used to display page lists @@ -138,18 +137,17 @@ type DisplayPage = { } with /// Create a minimal display page (no text or metadata) from a database page - static member FromPageMinimal (webLog: WebLog) (page: Page) = { - Id = string page.Id - AuthorId = string page.AuthorId - Title = page.Title - Permalink = string page.Permalink - PublishedOn = webLog.LocalTime page.PublishedOn - UpdatedOn = webLog.LocalTime page.UpdatedOn - IsInPageList = page.IsInPageList - IsDefault = string page.Id = webLog.DefaultPage - Text = "" - Metadata = [] - } + static member FromPageMinimal (webLog: WebLog) (page: Page) = + { Id = string page.Id + AuthorId = string page.AuthorId + Title = page.Title + Permalink = string page.Permalink + PublishedOn = webLog.LocalTime page.PublishedOn + UpdatedOn = webLog.LocalTime page.UpdatedOn + IsInPageList = page.IsInPageList + IsDefault = string page.Id = webLog.DefaultPage + Text = "" + Metadata = [] } /// Create a display page from a database page static member FromPage webLog page = @@ -173,11 +171,10 @@ type DisplayRevision = { } with /// Create a display revision from an actual revision - static member FromRevision (webLog: WebLog) (rev : Revision) = { - AsOf = rev.AsOf.ToDateTimeUtc() - AsOfLocal = webLog.LocalTime rev.AsOf - Format = rev.Text.SourceType - } + static member FromRevision (webLog: WebLog) (rev : Revision) = + { AsOf = rev.AsOf.ToDateTimeUtc() + AsOfLocal = webLog.LocalTime rev.AsOf + Format = rev.Text.SourceType } open System.IO @@ -205,14 +202,13 @@ type DisplayTheme = { } with /// Create a display theme from a theme - static member FromTheme inUseFunc (theme: Theme) = { - Id = string theme.Id - Name = theme.Name - Version = theme.Version - TemplateCount = List.length theme.Templates - IsInUse = inUseFunc theme.Id - IsOnDisk = File.Exists $"{theme.Id}-theme.zip" - } + static member FromTheme inUseFunc (theme: Theme) = + { Id = string theme.Id + Name = theme.Name + Version = theme.Version + TemplateCount = List.length theme.Templates + IsInUse = inUseFunc theme.Id + IsOnDisk = File.Exists $"{theme.Id}-theme.zip" } /// Information about an uploaded file used for display @@ -238,12 +234,11 @@ type DisplayUpload = { static member FromUpload (webLog: WebLog) (source: UploadDestination) (upload: Upload) = let path = string upload.Path let name = Path.GetFileName path - { Id = string upload.Id - Name = name - Path = path.Replace(name, "") - UpdatedOn = Some (webLog.LocalTime upload.UpdatedOn) - Source = string source - } + { Id = string upload.Id + Name = name + Path = path.Replace(name, "") + UpdatedOn = Some (webLog.LocalTime upload.UpdatedOn) + Source = string source } /// View model to display a user's information @@ -278,17 +273,16 @@ type DisplayUser = { } with /// Construct a displayed user from a web log user - static member FromUser (webLog: WebLog) (user: WebLogUser) = { - Id = string user.Id - Email = user.Email - FirstName = user.FirstName - LastName = user.LastName - PreferredName = user.PreferredName - Url = defaultArg user.Url "" - AccessLevel = string user.AccessLevel - CreatedOn = webLog.LocalTime user.CreatedOn - LastSeenOn = user.LastSeenOn |> Option.map webLog.LocalTime |> Option.toNullable - } + static member FromUser (webLog: WebLog) (user: WebLogUser) = + { Id = string user.Id + Email = user.Email + FirstName = user.FirstName + LastName = user.LastName + PreferredName = user.PreferredName + Url = defaultArg user.Url "" + AccessLevel = string user.AccessLevel + CreatedOn = webLog.LocalTime user.CreatedOn + LastSeenOn = user.LastSeenOn |> Option.map webLog.LocalTime |> Option.toNullable } /// View model for editing categories @@ -311,13 +305,12 @@ type EditCategoryModel = { } with /// Create an edit model from an existing category - static member FromCategory (cat: Category) = { - CategoryId = string cat.Id - Name = cat.Name - Slug = cat.Slug - Description = defaultArg cat.Description "" - ParentId = cat.ParentId |> Option.map string |> Option.defaultValue "" - } + static member FromCategory (cat: Category) = + { CategoryId = string cat.Id + Name = cat.Name + Slug = cat.Slug + Description = defaultArg cat.Description "" + ParentId = cat.ParentId |> Option.map string |> Option.defaultValue "" } /// Is this a new category? member this.IsNew = @@ -392,29 +385,28 @@ type EditCustomFeedModel = { } with /// An empty custom feed model - static member Empty = { - Id = "" - SourceType = "category" - SourceValue = "" - Path = "" - IsPodcast = false - Title = "" - Subtitle = "" - ItemsInFeed = 25 - Summary = "" - DisplayedAuthor = "" - Email = "" - ImageUrl = "" - AppleCategory = "" - AppleSubcategory = "" - Explicit = "no" - DefaultMediaType = "audio/mpeg" - MediaBaseUrl = "" - FundingUrl = "" - FundingText = "" - PodcastGuid = "" - Medium = "" - } + static member Empty = + { Id = "" + SourceType = "category" + SourceValue = "" + Path = "" + IsPodcast = false + Title = "" + Subtitle = "" + ItemsInFeed = 25 + Summary = "" + DisplayedAuthor = "" + Email = "" + ImageUrl = "" + AppleCategory = "" + AppleSubcategory = "" + Explicit = "no" + DefaultMediaType = "audio/mpeg" + MediaBaseUrl = "" + FundingUrl = "" + FundingText = "" + PodcastGuid = "" + Medium = "" } /// Create a model from a custom feed static member FromFeed (feed: CustomFeed) = @@ -494,13 +486,12 @@ type EditMyInfoModel = { } with /// Create an edit model from a user - static member FromUser (user: WebLogUser) = { - FirstName = user.FirstName - LastName = user.LastName - PreferredName = user.PreferredName - NewPassword = "" - NewPasswordConfirm = "" - } + static member FromUser (user: WebLogUser) = + { FirstName = user.FirstName + LastName = user.LastName + PreferredName = user.PreferredName + NewPassword = "" + NewPasswordConfirm = "" } /// View model to edit a page @@ -541,16 +532,15 @@ type EditPageModel = { | Some rev -> rev | None -> Revision.Empty let page = if page.Metadata |> List.isEmpty then { page with Metadata = [ MetaItem.Empty ] } else page - { PageId = string page.Id - Title = page.Title - Permalink = string page.Permalink - Template = defaultArg page.Template "" - IsShownInPageList = page.IsInPageList - Source = latest.Text.SourceType - Text = latest.Text.Text - MetaNames = page.Metadata |> List.map _.Name |> Array.ofList - MetaValues = page.Metadata |> List.map _.Value |> Array.ofList - } + { PageId = string page.Id + Title = page.Title + Permalink = string page.Permalink + Template = defaultArg page.Template "" + IsShownInPageList = page.IsInPageList + Source = latest.Text.SourceType + Text = latest.Text.Text + MetaNames = page.Metadata |> List.map _.Name |> Array.ofList + MetaValues = page.Metadata |> List.map _.Value |> Array.ofList } /// Whether this is a new page member this.IsNew = @@ -697,41 +687,40 @@ type EditPostModel = { | None -> Revision.Empty let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.Empty ] } else post let episode = defaultArg post.Episode Episode.Empty - { PostId = string post.Id - Title = post.Title - Permalink = string post.Permalink - Source = latest.Text.SourceType - Text = latest.Text.Text - Tags = String.Join(", ", post.Tags) - Template = defaultArg post.Template "" - CategoryIds = post.CategoryIds |> List.map string |> Array.ofList - Status = string post.Status - DoPublish = false - MetaNames = post.Metadata |> List.map _.Name |> Array.ofList - MetaValues = post.Metadata |> List.map _.Value |> Array.ofList - SetPublished = false - PubOverride = post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable - SetUpdated = false - IsEpisode = Option.isSome post.Episode - Media = episode.Media - Length = episode.Length - Duration = defaultArg (episode.FormatDuration()) "" - MediaType = defaultArg episode.MediaType "" - ImageUrl = defaultArg episode.ImageUrl "" - Subtitle = defaultArg episode.Subtitle "" - Explicit = defaultArg (episode.Explicit |> Option.map string) "" - ChapterFile = defaultArg episode.ChapterFile "" - ChapterType = defaultArg episode.ChapterType "" - ContainsWaypoints = defaultArg episode.ChapterWaypoints false - TranscriptUrl = defaultArg episode.TranscriptUrl "" - TranscriptType = defaultArg episode.TranscriptType "" - TranscriptLang = defaultArg episode.TranscriptLang "" - TranscriptCaptions = defaultArg episode.TranscriptCaptions false - SeasonNumber = defaultArg episode.SeasonNumber 0 - SeasonDescription = defaultArg episode.SeasonDescription "" - EpisodeNumber = defaultArg (episode.EpisodeNumber |> Option.map string) "" - EpisodeDescription = defaultArg episode.EpisodeDescription "" - } + { PostId = string post.Id + Title = post.Title + Permalink = string post.Permalink + Source = latest.Text.SourceType + Text = latest.Text.Text + Tags = String.Join(", ", post.Tags) + Template = defaultArg post.Template "" + CategoryIds = post.CategoryIds |> List.map string |> Array.ofList + Status = string post.Status + DoPublish = false + MetaNames = post.Metadata |> List.map _.Name |> Array.ofList + MetaValues = post.Metadata |> List.map _.Value |> Array.ofList + SetPublished = false + PubOverride = post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable + SetUpdated = false + IsEpisode = Option.isSome post.Episode + Media = episode.Media + Length = episode.Length + Duration = defaultArg (episode.FormatDuration()) "" + MediaType = defaultArg episode.MediaType "" + ImageUrl = defaultArg episode.ImageUrl "" + Subtitle = defaultArg episode.Subtitle "" + Explicit = defaultArg (episode.Explicit |> Option.map string) "" + ChapterFile = defaultArg episode.ChapterFile "" + ChapterType = defaultArg episode.ChapterType "" + ContainsWaypoints = defaultArg episode.ChapterWaypoints false + TranscriptUrl = defaultArg episode.TranscriptUrl "" + TranscriptType = defaultArg episode.TranscriptType "" + TranscriptLang = defaultArg episode.TranscriptLang "" + TranscriptCaptions = defaultArg episode.TranscriptCaptions false + SeasonNumber = defaultArg episode.SeasonNumber 0 + SeasonDescription = defaultArg episode.SeasonDescription "" + EpisodeNumber = defaultArg (episode.EpisodeNumber |> Option.map string) "" + EpisodeDescription = defaultArg episode.EpisodeDescription "" } /// Whether this is a new post member this.IsNew = @@ -821,20 +810,18 @@ type EditRedirectRuleModel = { } with /// Create a model from an existing rule - static member FromRule idx (rule: RedirectRule) = { - RuleId = idx - From = rule.From - To = rule.To - IsRegex = rule.IsRegex - InsertAtTop = false - } + static member FromRule idx (rule: RedirectRule) = + { RuleId = idx + From = rule.From + To = rule.To + IsRegex = rule.IsRegex + InsertAtTop = false } /// Update a rule with the values from this model - member this.ToRule() = { - From = this.From - To = this.To - IsRegex = this.IsRegex - } + member this.ToRule() = + { From = this.From + To = this.To + IsRegex = this.IsRegex } /// View model to edit RSS settings diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index 1fb541d..9ea7e06 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -831,6 +831,24 @@ let editPostModelTests = testList "EditPostModel" [ ] ] +/// Unit tests for the EditRedirectRuleModel type +let editRedirectRuleModelTests = testList "EditRedirectRuleModel" [ + test "FromRule succeeds" { + let model = EditRedirectRuleModel.FromRule 15 { From = "here"; To = "there"; IsRegex = true } + Expect.equal model.RuleId 15 "RuleId not filled properly" + Expect.equal model.From "here" "From not filled properly" + Expect.equal model.To "there" "To not filled properly" + Expect.isTrue model.IsRegex "IsRegex should have been set" + Expect.isFalse model.InsertAtTop "InsertAtTop should not have been set" + } + test "ToRule succeeds" { + let rule = { RuleId = 10; From = "me"; To = "you"; IsRegex = false; InsertAtTop = false }.ToRule() + Expect.equal rule.From "me" "From not filled properly" + Expect.equal rule.To "you" "To not filled properly" + Expect.isFalse rule.IsRegex "IsRegex should not have been set" + } +] + /// All tests in the Domain.ViewModels file let all = testList "ViewModels" [ addBaseToRelativeUrlsTests @@ -845,4 +863,5 @@ let all = testList "ViewModels" [ editMyInfoModelTests editPageModelTests editPostModelTests + editRedirectRuleModelTests ] -- 2.45.1 From 9da9a94947fe106323ec5e0ccc37909c966808c4 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 18 Jan 2024 19:23:22 -0500 Subject: [PATCH 050/123] Add tests through mng rev --- src/MyWebLog.Domain/ViewModels.fs | 120 ++++++------- src/MyWebLog.Tests/ViewModelsTests.fs | 234 +++++++++++++++++++++++++- 2 files changed, 288 insertions(+), 66 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 416ff97..cd722eb 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -847,14 +847,13 @@ type EditRssModel = { } with /// Create an edit model from a set of RSS options - static member FromRssOptions (rss: RssOptions) = { - IsFeedEnabled = rss.IsFeedEnabled - FeedName = rss.FeedName - ItemsInFeed = defaultArg rss.ItemsInFeed 0 - IsCategoryEnabled = rss.IsCategoryEnabled - IsTagEnabled = rss.IsTagEnabled - Copyright = defaultArg rss.Copyright "" - } + static member FromRssOptions (rss: RssOptions) = + { IsFeedEnabled = rss.IsFeedEnabled + FeedName = rss.FeedName + ItemsInFeed = defaultArg rss.ItemsInFeed 0 + IsCategoryEnabled = rss.IsCategoryEnabled + IsTagEnabled = rss.IsTagEnabled + Copyright = defaultArg rss.Copyright "" } /// Update RSS options from values in this model member this.UpdateOptions (rss: RssOptions) = @@ -881,11 +880,10 @@ type EditTagMapModel = { } with /// Create an edit model from the tag mapping - static member FromMapping (tagMap: TagMap) : EditTagMapModel = { - Id = string tagMap.Id - Tag = tagMap.Tag - UrlValue = tagMap.UrlValue - } + static member FromMapping (tagMap: TagMap) : EditTagMapModel = + { Id = string tagMap.Id + Tag = tagMap.Tag + UrlValue = tagMap.UrlValue } /// Whether this is a new tag mapping member this.IsNew = @@ -924,17 +922,16 @@ type EditUserModel = { } with /// Construct a user edit form from a web log user - static member FromUser (user: WebLogUser) = { - Id = string user.Id - AccessLevel = string user.AccessLevel - Url = defaultArg user.Url "" - Email = user.Email - FirstName = user.FirstName - LastName = user.LastName - PreferredName = user.PreferredName - Password = "" - PasswordConfirm = "" - } + static member FromUser (user: WebLogUser) = + { Id = string user.Id + AccessLevel = string user.AccessLevel + Url = defaultArg user.Url "" + Email = user.Email + FirstName = user.FirstName + LastName = user.LastName + PreferredName = user.PreferredName + Password = "" + PasswordConfirm = "" } /// Is this a new user? member this.IsNew = @@ -989,22 +986,20 @@ type ManagePermalinksModel = { } with /// Create a permalink model from a page - static member FromPage (page: Page) = { - Id = string page.Id - Entity = "page" - CurrentTitle = page.Title - CurrentPermalink = string page.Permalink - Prior = page.PriorPermalinks |> List.map string |> Array.ofList - } + static member FromPage (page: Page) = + { Id = string page.Id + Entity = "page" + CurrentTitle = page.Title + CurrentPermalink = string page.Permalink + Prior = page.PriorPermalinks |> List.map string |> Array.ofList } /// Create a permalink model from a post - static member FromPost (post: Post) = { - Id = string post.Id - Entity = "post" - CurrentTitle = post.Title - CurrentPermalink = string post.Permalink - Prior = post.PriorPermalinks |> List.map string |> Array.ofList - } + static member FromPost (post: Post) = + { Id = string post.Id + Entity = "post" + CurrentTitle = post.Title + CurrentPermalink = string post.Permalink + Prior = post.PriorPermalinks |> List.map string |> Array.ofList } /// View model to manage revisions @@ -1024,20 +1019,18 @@ type ManageRevisionsModel = { } with /// Create a revision model from a page - static member FromPage webLog (page: Page) = { - Id = string page.Id - Entity = "page" - CurrentTitle = page.Title - Revisions = page.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList - } + static member FromPage webLog (page: Page) = + { Id = string page.Id + Entity = "page" + CurrentTitle = page.Title + Revisions = page.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList } /// Create a revision model from a post - static member FromPost webLog (post: Post) = { - Id = string post.Id - Entity = "post" - CurrentTitle = post.Title - Revisions = post.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList - } + static member FromPost webLog (post: Post) = + { Id = string post.Id + Entity = "post" + CurrentTitle = post.Title + Revisions = post.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList } /// View model for posts in a list @@ -1081,20 +1074,19 @@ type PostListItem = { } with /// Create a post list item from a post - static member FromPost (webLog: WebLog) (post: Post) = { - Id = string post.Id - AuthorId = string post.AuthorId - Status = string post.Status - Title = post.Title - Permalink = string post.Permalink - PublishedOn = post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable - UpdatedOn = webLog.LocalTime post.UpdatedOn - Text = addBaseToRelativeUrls webLog.ExtraPath post.Text - CategoryIds = post.CategoryIds |> List.map string - Tags = post.Tags - Episode = post.Episode - Metadata = post.Metadata - } + static member FromPost (webLog: WebLog) (post: Post) = + { Id = string post.Id + AuthorId = string post.AuthorId + Status = string post.Status + Title = post.Title + Permalink = string post.Permalink + PublishedOn = post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable + UpdatedOn = webLog.LocalTime post.UpdatedOn + Text = addBaseToRelativeUrls webLog.ExtraPath post.Text + CategoryIds = post.CategoryIds |> List.map string + Tags = post.Tags + Episode = post.Episode + Metadata = post.Metadata } /// View model for displaying posts diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index 9ea7e06..7b2aaf3 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -611,8 +611,8 @@ let editPostModelTests = testList "EditPostModel" [ EpisodeDescription = Some "Episode 322" } } testList "FromPost" [ test "succeeds for empty post" { - let model = EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "lalala" } - Expect.equal model.PostId "lalala" "PostId not filled properly" + let model = EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "la-la-la" } + Expect.equal model.PostId "la-la-la" "PostId not filled properly" Expect.equal model.Title "" "Title not filled properly" Expect.equal model.Permalink "" "Permalink not filled properly" Expect.equal model.Source "HTML" "Source not filled properly" @@ -849,6 +849,231 @@ let editRedirectRuleModelTests = testList "EditRedirectRuleModel" [ } ] +/// Unit tests for the EditRssModel type +let editRssModelTests = testList "EditRssModel" [ + testList "FromRssOptions" [ + test "succeeds with minimal options" { + let model = EditRssModel.FromRssOptions RssOptions.Empty + Expect.isTrue model.IsFeedEnabled "IsFeedEnabled should have been set" + Expect.equal model.FeedName "feed.xml" "FeedName not filled properly" + Expect.equal model.ItemsInFeed 0 "ItemsInFeed not filled properly" + Expect.isTrue model.IsCategoryEnabled "IsCategoryEnabled should have been set" + Expect.isTrue model.IsTagEnabled "IsTagEnabled should have been set" + Expect.equal model.Copyright "" "Copyright not filled properly" + } + test "succeeds with full options" { + let model = + EditRssModel.FromRssOptions + { RssOptions.Empty with + IsFeedEnabled = false + FeedName = "custom.xml" + ItemsInFeed = Some 82 + IsCategoryEnabled = false + IsTagEnabled = false + Copyright = Some "yep" } + Expect.isFalse model.IsFeedEnabled "IsFeedEnabled should not have been set" + Expect.equal model.FeedName "custom.xml" "FeedName not filled properly" + Expect.equal model.ItemsInFeed 82 "ItemsInFeed not filled properly" + Expect.isFalse model.IsCategoryEnabled "IsCategoryEnabled should not have been set" + Expect.isFalse model.IsTagEnabled "IsTagEnabled should not have been set" + Expect.equal model.Copyright "yep" "Copyright not filled properly" + } + ] + testList "UpdateOptions" [ + test "succeeds with minimal options" { + let opts = + { IsFeedEnabled = true + FeedName = "blah.xml" + ItemsInFeed = 0 + IsCategoryEnabled = true + IsTagEnabled = true + Copyright = "" }.UpdateOptions RssOptions.Empty + Expect.isTrue opts.IsFeedEnabled "IsFeedEnabled should have been set" + Expect.equal opts.FeedName "blah.xml" "FeedName not filled properly" + Expect.isNone opts.ItemsInFeed "ItemsInFeed should not have had a value" + Expect.isTrue opts.IsCategoryEnabled "IsCategoryEnabled should have been set" + Expect.isTrue opts.IsTagEnabled "IsTagEnabled should have been set" + Expect.isNone opts.Copyright "Copyright should not have had a value" + } + test "succeeds with full options" { + let opts = + { IsFeedEnabled = false + FeedName = "again.xml" + ItemsInFeed = 22 + IsCategoryEnabled = false + IsTagEnabled = false + Copyright = "none" }.UpdateOptions RssOptions.Empty + Expect.isFalse opts.IsFeedEnabled "IsFeedEnabled should not have been set" + Expect.equal opts.FeedName "again.xml" "FeedName not filled properly" + Expect.equal opts.ItemsInFeed (Some 22) "ItemsInFeed not filled properly" + Expect.isFalse opts.IsCategoryEnabled "IsCategoryEnabled should not have been set" + Expect.isFalse opts.IsTagEnabled "IsTagEnabled should not have been set" + Expect.equal opts.Copyright (Some "none") "Copyright not filled properly" + } + ] +] + +/// Unit tests for the EditTagMapModel type +let editTagMapModelTests = testList "EditTagMapModel" [ + test "FromMapping succeeds" { + let model = + EditTagMapModel.FromMapping + { Id = TagMapId "howdy"; Tag = "f#"; UrlValue = "f-sharp"; WebLogId = WebLogId "" } + Expect.equal model.Id "howdy" "Id not filled properly" + Expect.equal model.Tag "f#" "Tag not filled properly" + Expect.equal model.UrlValue "f-sharp" "UrlValue not filled properly" + } + testList "IsNew" [ + test "succeeds when tag mapping is new" { + Expect.isTrue + (EditTagMapModel.FromMapping { TagMap.Empty with Id = TagMapId "new" }).IsNew + "IsNew should have been set" + } + test "succeeds when tag mapping is not new" { + Expect.isFalse + (EditTagMapModel.FromMapping { TagMap.Empty with Id = TagMapId "ancient" }).IsNew + "IsNew should not have been set" + } + ] +] + +/// Unit tests for the EditUserModel type +let editUserModelTests = testList "EditUserModel" [ + testList "FromUser" [ + test "succeeds when the user does not have a URL" { + let model = + EditUserModel.FromUser + { WebLogUser.Empty with + Id = WebLogUserId "test" + AccessLevel = Editor + Email = "test@example.com" + FirstName = "Test" + LastName = "User" + PreferredName = "Tester" } + Expect.equal model.Id "test" "Id not filled properly" + Expect.equal model.AccessLevel "Editor" "AccessLevel not filled properly" + Expect.equal model.Url "" "Url not filled properly" + Expect.equal model.Email "test@example.com" "Email not filled properly" + Expect.equal model.FirstName "Test" "FirstName not filled properly" + Expect.equal model.LastName "User" "LastName not filled properly" + Expect.equal model.PreferredName "Tester" "PreferredName not filled properly" + Expect.equal model.Password "" "Password not filled properly" + Expect.equal model.PasswordConfirm "" "PasswordConfirm not filled properly" + } + test "succeeds when the user has a URL" { + let model = EditUserModel.FromUser { WebLogUser.Empty with Url = Some "https://test.me" } + Expect.equal model.Url "https://test.me" "Url not filled properly" + } + ] + testList "IsNew" [ + test "succeeds when the user is new" { + Expect.isTrue + (EditUserModel.FromUser { WebLogUser.Empty with Id = WebLogUserId "new" }).IsNew + "IsNew should have been set" + } + test "succeeds when the user is not new" { + Expect.isFalse + (EditUserModel.FromUser { WebLogUser.Empty with Id = WebLogUserId "not-new" }).IsNew + "IsNew should not have been set" + } + ] + testList "UpdateUser" [ + let model = + { Id = "test-user" + AccessLevel = "WebLogAdmin" + Email = "again@example.com" + Url = "" + FirstName = "Another" + LastName = "One" + PreferredName = "Happy" + Password = "my-password" + PasswordConfirm = "my-password" } + test "succeeds when user has no URL" { + let user = model.UpdateUser WebLogUser.Empty + Expect.equal user.AccessLevel WebLogAdmin "AccessLevel not filled properly" + Expect.equal user.Email "again@example.com" "Email not filled properly" + Expect.isNone user.Url "Url should not have had a value" + Expect.equal user.FirstName "Another" "FirstName not filled properly" + Expect.equal user.LastName "One" "LastName not filled properly" + Expect.equal user.PreferredName "Happy" "FirstName not filled properly" + } + test "succeeds when user has a URL" { + let user = { model with Url = "https://over.there" }.UpdateUser WebLogUser.Empty + Expect.equal user.Url (Some "https://over.there") "Url not filled properly" + } + ] +] + +/// Unit tests for the ManagePermalinksModel type +let managePermalinksModelTests = testList "ManagePermalinksModel" [ + test "FromPage succeeds" { + let model = + ManagePermalinksModel.FromPage + { Page.Empty with + Id = PageId "links" + Title = "My Awesome Page" + Permalink = Permalink "2018/02/my-awesome-page.html" + PriorPermalinks = [ Permalink "2018/02/my-awesome-pages.html"; Permalink "2018/02/oops.html" ] } + Expect.equal model.Id "links" "Id not filled properly" + Expect.equal model.Entity "page" "Entity not filled properly" + Expect.equal model.CurrentTitle "My Awesome Page" "CurrentTitle not filled properly" + Expect.equal model.CurrentPermalink "2018/02/my-awesome-page.html" "CurrentPermalink not filled properly" + Expect.equal model.Prior [| "2018/02/my-awesome-pages.html"; "2018/02/oops.html" |] "Prior not filled properly" + } + test "FromPost succeeds" { + let model = + ManagePermalinksModel.FromPost + { Post.Empty with + Id = PostId "test" + Title = "Errata" + Permalink = Permalink "2020/01/errata.html" + PriorPermalinks = [ Permalink "2020/01/errors.html"; Permalink "2020/01/whoops.html" ] } + Expect.equal model.Id "test" "Id not filled properly" + Expect.equal model.Entity "post" "Entity not filled properly" + Expect.equal model.CurrentTitle "Errata" "CurrentTitle not filled properly" + Expect.equal model.CurrentPermalink "2020/01/errata.html" "CurrentPermalink not filled properly" + Expect.equal model.Prior [| "2020/01/errors.html"; "2020/01/whoops.html" |] "Prior not filled properly" + } +] + +/// Unit tests for the ManageRevisionsModel type +let manageRevisionsModelTests = testList "ManageRevisionsModel" [ + test "FromPage succeeds" { + let revisions = + [ { AsOf = Noda.epoch + Duration.FromDays 24; Text = Html "wow" } + { AsOf = Noda.epoch + Duration.FromDays 20; Text = Html "

      huh

      " } ] + let model = + ManageRevisionsModel.FromPage + { WebLog.Empty with TimeZone = "Etc/GMT+1" } + { Page.Empty with Id = PageId "revs"; Title = "A Revised Page"; Revisions = revisions } + Expect.equal model.Id "revs" "Id not filled properly" + Expect.equal model.Entity "page" "Entity not filled properly" + Expect.equal model.CurrentTitle "A Revised Page" "CurrentTitle not filled properly" + Expect.equal model.Revisions.Length 2 "There should be two revisions" + Expect.equal + model.Revisions[0].AsOfLocal + ((revisions[0].AsOf - Duration.FromHours 1).ToDateTimeUtc()) + "AsOfLocal not filled properly" + } + test "FromPost succeeds" { + let revisions = + [ { AsOf = Noda.epoch + Duration.FromDays 13; Text = Html "

      again

      " } + { AsOf = Noda.epoch + Duration.FromDays 12; Text = Html "

      original

      " } ] + let model = + ManageRevisionsModel.FromPost + { WebLog.Empty with TimeZone = "Etc/GMT-3" } + { Post.Empty with Id = PostId "altered"; Title = "Round Two"; Revisions = revisions } + Expect.equal model.Id "altered" "Id not filled properly" + Expect.equal model.Entity "post" "Entity not filled properly" + Expect.equal model.CurrentTitle "Round Two" "CurrentTitle not filled properly" + Expect.equal model.Revisions.Length 2 "There should be two revisions" + Expect.equal + model.Revisions[0].AsOfLocal + ((revisions[0].AsOf + Duration.FromHours 3).ToDateTimeUtc()) + "AsOfLocal not filled properly" + } +] + /// All tests in the Domain.ViewModels file let all = testList "ViewModels" [ addBaseToRelativeUrlsTests @@ -864,4 +1089,9 @@ let all = testList "ViewModels" [ editPageModelTests editPostModelTests editRedirectRuleModelTests + editRssModelTests + editTagMapModelTests + editUserModelTests + managePermalinksModelTests + manageRevisionsModelTests ] -- 2.45.1 From da5918b154e81c2e04d10e34928b7fd9e8c799cd Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 19 Jan 2024 21:24:55 -0500 Subject: [PATCH 051/123] Update admin/default templates --- src/MyWebLog/DotLiquidBespoke.fs | 24 +- src/admin-theme/_edit-common.liquid | 34 +- src/admin-theme/_layout.liquid | 87 +++-- src/admin-theme/admin-dashboard.liquid | 50 ++- src/admin-theme/category-edit.liquid | 46 ++- src/admin-theme/category-list-body.liquid | 30 +- src/admin-theme/category-list.liquid | 4 +- src/admin-theme/custom-feed-edit.liquid | 347 ++++++------------- src/admin-theme/dashboard.liquid | 20 +- src/admin-theme/layout-bare.liquid | 6 +- src/admin-theme/layout-partial.liquid | 10 +- src/admin-theme/layout.liquid | 24 +- src/admin-theme/log-on.liquid | 28 +- src/admin-theme/my-info.liquid | 73 ++-- src/admin-theme/page-edit.liquid | 58 ++-- src/admin-theme/page-list.liquid | 32 +- src/admin-theme/permalinks.liquid | 51 ++- src/admin-theme/post-edit.liquid | 268 +++++++------- src/admin-theme/post-list.liquid | 32 +- src/admin-theme/redirect-edit.liquid | 40 +-- src/admin-theme/redirect-list.liquid | 49 ++- src/admin-theme/revisions.liquid | 43 ++- src/admin-theme/settings.liquid | 180 +++++----- src/admin-theme/tag-mapping-edit.liquid | 29 +- src/admin-theme/tag-mapping-list-body.liquid | 28 +- src/admin-theme/theme-list-body.liquid | 10 +- src/admin-theme/theme-upload.liquid | 26 +- src/admin-theme/upload-list.liquid | 43 ++- src/admin-theme/upload-new.liquid | 32 +- src/admin-theme/user-edit.liquid | 85 +++-- src/admin-theme/user-list-body.liquid | 14 +- src/default-theme/index.liquid | 56 ++- src/default-theme/layout.liquid | 109 +++--- src/default-theme/single-page.liquid | 6 +- src/default-theme/single-post.liquid | 30 +- src/default-theme/version.txt | 2 +- 36 files changed, 914 insertions(+), 1092 deletions(-) diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 73594f1..d5edcca 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -83,13 +83,13 @@ type NavLinkFilter() = let extraPath = ctx.WebLog.ExtraPath let path = if extraPath = "" then "" else $"{extraPath[1..]}/" seq { - "
    • " text - "
      • " + "" } |> String.concat "" @@ -111,23 +111,23 @@ type PageHeadTag() = let getBool name = defaultArg (context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean) false - result.WriteLine $"""""" + result.WriteLine $"""""" // Theme assets if assetExists "style.css" webLog then - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" if assetExists "favicon.ico" webLog then - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" // RSS feeds and canonical URLs let feedLink title url = let escTitle = HttpUtility.HtmlAttributeEncode title let relUrl = webLog.RelativeUrl(Permalink url) - $"""{s}""" + $"""{s}""" if webLog.Rss.IsFeedEnabled && getBool "is_home" then result.WriteLine(feedLink webLog.Name webLog.Rss.FeedName) - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" if webLog.Rss.IsCategoryEnabled && getBool "is_category_home" then let slug = context.Environments[0].["slug"] :?> string @@ -140,12 +140,12 @@ type PageHeadTag() = if getBool "is_post" then let post = context.Environments[0].["model"] :?> PostDisplay let url = webLog.AbsoluteUrl (Permalink post.Posts[0].Permalink) - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" if getBool "is_page" then let page = context.Environments[0].["page"] :?> DisplayPage let url = webLog.AbsoluteUrl (Permalink page.Permalink) - result.WriteLine $"""{s}""" + result.WriteLine $"""{s}""" /// Create various items in the page header based on the state of the page being generated @@ -191,10 +191,10 @@ type UserLinksTag() = """" } |> Seq.iter result.WriteLine diff --git a/src/admin-theme/_edit-common.liquid b/src/admin-theme/_edit-common.liquid index 46f1e81..214de29 100644 --- a/src/admin-theme/_edit-common.liquid +++ b/src/admin-theme/_edit-common.liquid @@ -1,32 +1,32 @@
      - - +
      - - + {%- unless model.is_new %} {%- assign entity_url_base = "admin/" | append: entity | append: "/" | append: entity_id -%} - + Manage Permalinks - • + • Manage Revisions {%- endunless -%}
      -
      -     -
      - - - - +
      +     +
      + + + +
      -
      - +
      +
      diff --git a/src/admin-theme/_layout.liquid b/src/admin-theme/_layout.liquid index c9df14c..440acea 100644 --- a/src/admin-theme/_layout.liquid +++ b/src/admin-theme/_layout.liquid @@ -1,65 +1,60 @@
      -
      -
      +
      +
      {% for msg in messages %} -
      -

      Loading…

      +

      Loading…

      {{ content }}
      {%- assign version = generator | split: " " -%} v{{ version[1] }} - myWebLog + myWebLog
      diff --git a/src/admin-theme/admin-dashboard.liquid b/src/admin-theme/admin-dashboard.liquid index 7febfc6..baed2f7 100644 --- a/src/admin-theme/admin-dashboard.liquid +++ b/src/admin-theme/admin-dashboard.liquid @@ -1,9 +1,8 @@ -

      {{ page_title }}

      +

      {{ page_title }}

      Themes - + Upload a New Theme
      @@ -21,39 +20,37 @@ {%- assign cache_base_url = "admin/cache/" -%} Caches
      -
      +

      - myWebLog uses a few caches to ensure that it serves pages as fast as possible. - (more information) -

      + myWebLog uses a few caches to ensure that it serves pages as fast as possible. + (more information)
      -
      +
      -
      +
      Web Logs
      These caches include the page list and categories for each web log
      {%- assign web_log_base_url = cache_base_url | append: "web-log/" -%} -
      - -
      -
      Web Log
      +
      Web Log
      {%- for web_log in web_logs %}
      -
      +
      {{ web_log[1] }}
      - {{ web_log[2] }}
      + {{ web_log[2] }}
      {%- assign refresh_url = web_log_base_url | append: web_log[0] | append: "/refresh" | relative_link -%} Refresh       @@ -65,7 +62,7 @@
      -
      +
      Themes
      @@ -73,29 +70,28 @@ templates will still refresh its asset cache
      {%- assign theme_base_url = cache_base_url | append: "theme/" -%} - - -
      -
      Theme
      -
      Cached
      +
      Theme
      +
      Cached
      {%- for theme in cached_themes %} {% unless theme[0] == "admin" %}
      -
      +
      {{ theme[1] }}
      - {{ theme[0] }} • + {{ theme[0] }} • {%- assign refresh_url = theme_base_url | append: theme[0] | append: "/refresh" | relative_link -%} Refresh
      -
      {{ theme[2] }}
      +
      {{ theme[2] }}
      {% endunless %} {%- endfor %} diff --git a/src/admin-theme/category-edit.liquid b/src/admin-theme/category-edit.liquid index ee13d19..3cb44ef 100644 --- a/src/admin-theme/category-edit.liquid +++ b/src/admin-theme/category-edit.liquid @@ -1,52 +1,50 @@ -
      -
      {{ page_title }}
      - - - -
      +
      +
      {{ page_title }}
      + + + +
      -
      - + - +
      -
      - + - +
      -
      - + {% for cat in categories -%} {%- unless cat.id == model.category_id %} - {% endunless -%} {%- endfor %} - +
      -
      - + - +
      - + Cancel
      diff --git a/src/admin-theme/category-list-body.liquid b/src/admin-theme/category-list-body.liquid index a3e822a..83984a9 100644 --- a/src/admin-theme/category-list-body.liquid +++ b/src/admin-theme/category-list-body.liquid @@ -1,55 +1,55 @@ -
      -
      -
      +
      +
      +
      {%- 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" -%} -
      +
      -
      Category; Description
      +
      Category; Description
      Description
      - - + +
      {% for cat in categories -%}
      {%- if cat.parent_names %} - {% for name in cat.parent_names %}{{ name }} ⟩ {% endfor %} + {% for name in cat.parent_names %}{{ name }} ⟩ {% endfor %} {%- endif %} {{ cat.name }}
      {%- assign cat_url_base = "admin/category/" | append: cat.id -%} {%- if cat.post_count > 0 %} - + View {{ cat.post_count }} Post{% unless cat.post_count == 1 %}s{% endunless -%} - • + • {%- endif %} Edit - • + • {%- assign cat_del_link = cat_url_base | append: "/delete" | relative_link -%} - Delete
      - {%- if cat.description %}{{ cat.description.value }}{% else %}none{% endif %} + {%- if cat.description %}{{ cat.description.value }}{% else %}none{% endif %}
      {%- endfor %} {%- else -%} -
      -

      This web log has no categores defined

      +
      +

      This web log has no categories defined

      {%- endif %}
      diff --git a/src/admin-theme/category-list.liquid b/src/admin-theme/category-list.liquid index d6eef09..689c41c 100644 --- a/src/admin-theme/category-list.liquid +++ b/src/admin-theme/category-list.liquid @@ -1,7 +1,7 @@ -

      {{ page_title }}

      +

      {{ page_title }}

      + hx-target=#cat_new> Add a New Category {{ category_list }} diff --git a/src/admin-theme/custom-feed-edit.liquid b/src/admin-theme/custom-feed-edit.liquid index 78e0b85..507e8cf 100644 --- a/src/admin-theme/custom-feed-edit.liquid +++ b/src/admin-theme/custom-feed-edit.liquid @@ -1,18 +1,12 @@ -

      {{ page_title }}

      +

      {{ page_title }}

      -
      - - + + + {%- assign typ = model.source_type -%} -
      +
      -
      +
      « Back to Settings
      @@ -20,32 +14,22 @@
      Identification -
      -
      -
      - - +
      +
      +
      + + Appended to {{ web_log.url_base }}/
      -
      +
      - - + +
      @@ -57,27 +41,19 @@
      - - + +
      -
      - {% for cat in categories -%} - {%- endfor %} - +
      - +
      -
      - - +
      + +
      @@ -117,254 +84,164 @@
      -
      -
      +
      +
      Podcast Settings -
      +
      -
      - - +
      + +
      -
      - - +
      + +
      -
      - - +
      + +
      -
      +
      -
      - - +
      + + - + iTunes Category / Subcategory List
      -
      - - +
      + +
      -
      - + + + - +
      -
      +
      -
      - - +
      + +
      -
      - - +
      + + For iTunes, must match registered e-mail
      -
      - - +
      + + Optional; blank for no default
      -
      - - +
      + + Relative URL will be appended to {{ web_log.url_base }}/
      -
      - - +
      + + Displayed in podcast directories
      -
      - - +
      + + Optional; prepended to episode media file if present
      -
      +
      -
      - - +
      + + Optional; URL describing donation options for this podcast, relative URL supported
      -
      - - +
      + + Optional; text for the funding link
      -
      - - +
      + + Optional; v5 UUID uniquely identifying this podcast; once entered, do not change this value - (documentation) + (documentation)
      -
      - {% for med in medium_values -%} - {%- endfor %} - + Optional; medium of the podcast content - (documentation) + (documentation)
      @@ -374,9 +251,9 @@
      - +
      -
      \ No newline at end of file +
      diff --git a/src/admin-theme/dashboard.liquid b/src/admin-theme/dashboard.liquid index 91e2bc2..782a8c3 100644 --- a/src/admin-theme/dashboard.liquid +++ b/src/admin-theme/dashboard.liquid @@ -1,10 +1,10 @@ -

      {{ web_log.name }} • Dashboard

      -
      -
      +

      {{ web_log.name }} • Dashboard

      +
      +
      -
      +
      Posts
      -
      +
      Published {{ model.posts }}   Drafts {{ model.drafts }} @@ -17,9 +17,9 @@
      -
      +
      Pages
      -
      +
      All {{ model.pages }}   Shown in Page List {{ model.listed_pages }} @@ -32,11 +32,11 @@
      -
      +
      -
      +
      Categories
      -
      +
      All {{ model.categories }}   Top Level {{ model.top_level_categories }} diff --git a/src/admin-theme/layout-bare.liquid b/src/admin-theme/layout-bare.liquid index a343dd8..4335d8d 100644 --- a/src/admin-theme/layout-bare.liquid +++ b/src/admin-theme/layout-bare.liquid @@ -1,5 +1,5 @@ - - -{{ content }} + + +{{ content }} diff --git a/src/admin-theme/layout-partial.liquid b/src/admin-theme/layout-partial.liquid index c47068d..fe06a41 100644 --- a/src/admin-theme/layout-partial.liquid +++ b/src/admin-theme/layout-partial.liquid @@ -1,9 +1,5 @@ - - - {{ page_title | strip_html }} « Admin « {{ web_log.name | strip_html }} - - - {% include_template "_layout" %} - + + {{ page_title | strip_html }} « Admin « {{ web_log.name | strip_html }} + {% include_template "_layout" %} diff --git a/src/admin-theme/layout.liquid b/src/admin-theme/layout.liquid index f5f3c81..264428c 100644 --- a/src/admin-theme/layout.liquid +++ b/src/admin-theme/layout.liquid @@ -1,18 +1,16 @@ - - - - - {{ page_title | strip_html }} « Admin « {{ web_log.name | strip_html }} - - - - + + + + {{ page_title | strip_html }} « Admin « {{ web_log.name | strip_html }} + + + {% include_template "_layout" %} - + {{ htmx_script }} diff --git a/src/admin-theme/log-on.liquid b/src/admin-theme/log-on.liquid index 8bda90f..d6880ac 100644 --- a/src/admin-theme/log-on.liquid +++ b/src/admin-theme/log-on.liquid @@ -1,28 +1,28 @@ -

      Log On to {{ web_log.name }}

      -
      -
      - +

      Log On to {{ web_log.name }}

      +
      + + {% if model.return_to %} - + {% endif %} -
      -
      +
      +
      -
      - - +
      + +
      -
      - - +
      + +
      - +
      diff --git a/src/admin-theme/my-info.liquid b/src/admin-theme/my-info.liquid index b022874..f38e3ad 100644 --- a/src/admin-theme/my-info.liquid +++ b/src/admin-theme/my-info.liquid @@ -1,75 +1,72 @@ -

      {{ page_title }}

      +

      {{ page_title }}

      - - + +
      - Access Level
      {{ access_level }} + Access Level
      {{ access_level }}
      - Created
      {{ created_on | date: "MMMM d, yyyy" }} + Created
      {{ created_on | date: "MMMM d, yyyy" }}
      - Last Log On
      + Last Log On
      {{ last_seen_on | date: "MMMM d, yyyy" }} at {{ last_seen_on | date: "h:mmtt" | downcase }}
      -
      -
      +
      +
      -
      - - +
      + +
      -
      - - +
      + +
      -
      - - +
      + +
      -
      -
      - Change Password -
      -
      -

      Optional; leave blank to keep your current password

      -
      +
      +
      + Change Password +
      +

      Optional; leave blank to keep your current password

      -
      +
      -
      - - +
      + +
      -
      - - +
      + +
      -
      +
      - +
      diff --git a/src/admin-theme/page-edit.liquid b/src/admin-theme/page-edit.liquid index 8e156d3..715ec05 100644 --- a/src/admin-theme/page-edit.liquid +++ b/src/admin-theme/page-edit.liquid @@ -1,75 +1,75 @@ -

      {{ page_title }}

      +

      {{ page_title }}

      - - -
      + + +
      -
      +
      {%- assign entity = "page" -%} {%- assign entity_id = model.page_id -%} {% include_template "_edit-common" %}
      -
      +
      - {% for tmpl in templates -%} - {%- endfor %} - +
      - - + +
      -
      - +
      +
      -
      +
      Metadata - -
      -
      +
      +
      {%- for meta in metadata %}
      -
      -
      -
      - +
      +
      +
      -
      -
      - +
      +
      +
      {% endfor -%}
      - + diff --git a/src/admin-theme/page-list.liquid b/src/admin-theme/page-list.liquid index f22871f..7682f02 100644 --- a/src/admin-theme/page-list.liquid +++ b/src/admin-theme/page-list.liquid @@ -1,4 +1,4 @@ -

      {{ page_title }}

      +

      {{ page_title }}

      Create a New Page {%- assign page_count = pages | size -%} @@ -6,11 +6,11 @@ {%- assign title_col = "col-12 col-md-5" -%} {%- assign link_col = "col-12 col-md-5" -%} {%- assign upd8_col = "col-12 col-md-2" -%} - - + +
      - TitlePage + TitlePage
      Permalink
      Updated
      @@ -23,15 +23,15 @@ {%- if pg.is_in_page_list %}   IN PAGE LIST {% endif -%}
      {%- capture pg_link %}{% unless pg.is_default %}{{ pg.permalink }}{% endunless %}{% endcapture -%} - View Page + View Page {% if is_editor or is_author and user_id == pg.author_id %} - • + • Edit {% endif %} {% if is_web_log_admin %} - • + • {%- assign pg_del_link = "admin/page/" | append: pg.id | append: "/delete" | relative_link -%} - Delete @@ -40,7 +40,7 @@
      {%- capture pg_link %}/{% unless pg.is_default %}{{ pg.permalink }}{% endunless %}{% endcapture -%} - {{ pg_link }}{{ pg_link }} + {{ pg_link }}{{ pg_link }}
      Updated {{ pg.updated_on | date: "MMMM d, yyyy" }} @@ -54,19 +54,17 @@
      {% if page_nbr > 1 %}

      - - « Previous - -

      + + « Previous + {% endif %}
      {% if has_next %}

      - - Next » - -

      + + Next » + {% endif %}
      diff --git a/src/admin-theme/permalinks.liquid b/src/admin-theme/permalinks.liquid index b296e94..2d4a168 100644 --- a/src/admin-theme/permalinks.liquid +++ b/src/admin-theme/permalinks.liquid @@ -1,43 +1,42 @@ -

      {{ page_title }}

      +

      {{ page_title }}

      {%- assign base_url = "admin/" | append: model.entity | append: "/" -%} - - - -
      -
      -
      + + + +
      +
      +

      - {{ model.current_title }}
      - - {{ model.current_permalink }}
      - - « Back to Edit {{ model.entity | capitalize }} - -       -

      + {{ model.current_title }}
      + + {{ model.current_permalink }}
      + + « Back to Edit {{ model.entity | capitalize }} + +
      -
      - +
      +
      -
      -
      -
      -
      diff --git a/src/default-theme/version.txt b/src/default-theme/version.txt index ec5e044..32e64f5 100644 --- a/src/default-theme/version.txt +++ b/src/default-theme/version.txt @@ -1,2 +1,2 @@ myWebLog Default Theme -2.0.0 \ No newline at end of file +2.1.0 \ No newline at end of file -- 2.45.1 From d50056cd6614700ff32012f6f38bae053d91e27e Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 20 Jan 2024 11:56:40 -0500 Subject: [PATCH 052/123] Finish view model tests --- src/MyWebLog.Domain/DataTypes.fs | 186 ++++++++++++-------------- src/MyWebLog.Domain/SupportTypes.fs | 111 +++++++-------- src/MyWebLog.Domain/ViewModels.fs | 21 ++- src/MyWebLog.Tests/ViewModelsTests.fs | 144 ++++++++++++++++++++ 4 files changed, 288 insertions(+), 174 deletions(-) diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index 2ea9f55..65c2325 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -26,14 +26,13 @@ type Category = { } with /// An empty category - static member Empty = { - Id = CategoryId.Empty - WebLogId = WebLogId.Empty - Name = "" - Slug = "" - Description = None - ParentId = None - } + static member Empty = + { Id = CategoryId.Empty + WebLogId = WebLogId.Empty + Name = "" + Slug = "" + Description = None + ParentId = None } /// A comment on a post @@ -68,17 +67,16 @@ type Comment = { } with /// An empty comment - static member Empty = { - Id = CommentId.Empty - PostId = PostId.Empty - InReplyToId = None - Name = "" - Email = "" - Url = None - Status = Pending - PostedOn = Noda.epoch - Text = "" - } + static member Empty = + { Id = CommentId.Empty + PostId = PostId.Empty + InReplyToId = None + Name = "" + Email = "" + Url = None + Status = Pending + PostedOn = Noda.epoch + Text = "" } /// A page (text not associated with a date/time) @@ -125,21 +123,20 @@ type Page = { } with /// An empty page - static member Empty = { - Id = PageId.Empty - WebLogId = WebLogId.Empty - AuthorId = WebLogUserId.Empty - Title = "" - Permalink = Permalink.Empty - PublishedOn = Noda.epoch - UpdatedOn = Noda.epoch - IsInPageList = false - Template = None - Text = "" - Metadata = [] - PriorPermalinks = [] - Revisions = [] - } + static member Empty = + { Id = PageId.Empty + WebLogId = WebLogId.Empty + AuthorId = WebLogUserId.Empty + Title = "" + Permalink = Permalink.Empty + PublishedOn = Noda.epoch + UpdatedOn = Noda.epoch + IsInPageList = false + Template = None + Text = "" + Metadata = [] + PriorPermalinks = [] + Revisions = [] } /// A web log post @@ -195,24 +192,23 @@ type Post = { } with /// An empty post - static member Empty = { - Id = PostId.Empty - WebLogId = WebLogId.Empty - AuthorId = WebLogUserId.Empty - Status = Draft - Title = "" - Permalink = Permalink.Empty - PublishedOn = None - UpdatedOn = Noda.epoch - Text = "" - Template = None - CategoryIds = [] - Tags = [] - Episode = None - Metadata = [] - PriorPermalinks = [] - Revisions = [] - } + static member Empty = + { Id = PostId.Empty + WebLogId = WebLogId.Empty + AuthorId = WebLogUserId.Empty + Status = Draft + Title = "" + Permalink = Permalink.Empty + PublishedOn = None + UpdatedOn = Noda.epoch + Text = "" + Template = None + CategoryIds = [] + Tags = [] + Episode = None + Metadata = [] + PriorPermalinks = [] + Revisions = [] } /// A mapping between a tag and its URL value, used to translate restricted characters (ex. "#1" -> "number-1") @@ -232,12 +228,8 @@ type TagMap = { } with /// An empty tag mapping - static member Empty = { - Id = TagMapId.Empty - WebLogId = WebLogId.Empty - Tag = "" - UrlValue = "" - } + static member Empty = + { Id = TagMapId.Empty; WebLogId = WebLogId.Empty; Tag = ""; UrlValue = "" } /// A theme @@ -257,12 +249,8 @@ type Theme = { } with /// An empty theme - static member Empty = { - Id = ThemeId.Empty - 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]) @@ -279,11 +267,8 @@ type ThemeAsset = { } with /// An empty theme asset - static member Empty = { - Id = ThemeAssetId.Empty - UpdatedOn = Noda.epoch - Data = [||] - } + static member Empty = + { Id = ThemeAssetId.Empty; UpdatedOn = Noda.epoch; Data = [||] } /// An uploaded file @@ -306,13 +291,8 @@ type Upload = { } with /// An empty upload - static member Empty = { - Id = UploadId.Empty - WebLogId = WebLogId.Empty - Path = Permalink.Empty - UpdatedOn = Noda.epoch - Data = [||] - } + static member Empty = + { Id = UploadId.Empty; WebLogId = WebLogId.Empty; Path = Permalink.Empty; UpdatedOn = Noda.epoch; Data = [||] } open Newtonsoft.Json @@ -361,21 +341,20 @@ type WebLog = { } with /// An empty web log - static member Empty = { - Id = WebLogId.Empty - Name = "" - Slug = "" - Subtitle = None - DefaultPage = "" - PostsPerPage = 10 - ThemeId = ThemeId "default" - UrlBase = "" - TimeZone = "" - Rss = RssOptions.Empty - AutoHtmx = false - Uploads = Database - RedirectRules = [] - } + static member Empty = + { Id = WebLogId.Empty + Name = "" + Slug = "" + Subtitle = None + DefaultPage = "" + PostsPerPage = 10 + ThemeId = ThemeId "default" + UrlBase = "" + TimeZone = "" + Rss = RssOptions.Empty + AutoHtmx = false + Uploads = Database + RedirectRules = [] } /// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain) [] @@ -441,19 +420,18 @@ type WebLogUser = { } with /// An empty web log user - static member Empty = { - Id = WebLogUserId.Empty - WebLogId = WebLogId.Empty - Email = "" - FirstName = "" - LastName = "" - PreferredName = "" - PasswordHash = "" - Url = None - AccessLevel = Author - CreatedOn = Noda.epoch - LastSeenOn = None - } + static member Empty = + { Id = WebLogUserId.Empty + WebLogId = WebLogId.Empty + Email = "" + FirstName = "" + LastName = "" + PreferredName = "" + PasswordHash = "" + Url = None + AccessLevel = Author + CreatedOn = Noda.epoch + LastSeenOn = None } /// Get the user's displayed name [] diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 1266fd7..53df258 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -256,27 +256,26 @@ type Episode = { } with /// An empty episode - static member Empty = { - Media = "" - Length = 0L - Duration = None - MediaType = None - ImageUrl = None - Subtitle = None - Explicit = None - Chapters = None - ChapterFile = None - ChapterType = None - ChapterWaypoints = None - TranscriptUrl = None - TranscriptType = None - TranscriptLang = None - TranscriptCaptions = None - SeasonNumber = None - SeasonDescription = None - EpisodeNumber = None - EpisodeDescription = None - } + static member Empty = + { Media = "" + Length = 0L + Duration = None + MediaType = None + ImageUrl = None + Subtitle = None + Explicit = None + Chapters = None + ChapterFile = None + ChapterType = None + ChapterWaypoints = None + TranscriptUrl = None + TranscriptType = None + TranscriptLang = None + TranscriptCaptions = None + SeasonNumber = None + SeasonDescription = None + EpisodeNumber = None + EpisodeDescription = None } /// Format a duration for an episode member this.FormatDuration() = @@ -460,11 +459,8 @@ type RedirectRule = { } with /// An empty redirect rule - static member Empty = { - From = "" - To = "" - IsRegex = false - } + static member Empty = + { From = ""; To = ""; IsRegex = false } /// An identifier for a custom feed @@ -557,24 +553,23 @@ type PodcastOptions = { } 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 - } + 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 @@ -594,12 +589,11 @@ type CustomFeed = { } with /// An empty custom feed - static member Empty = { - Id = CustomFeedId.Empty - Source = Category CategoryId.Empty - Path = Permalink.Empty - 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 @@ -628,15 +622,14 @@ type RssOptions = { } with /// An empty set of RSS options - static member Empty = { - IsFeedEnabled = true - FeedName = "feed.xml" - ItemsInFeed = None - IsCategoryEnabled = true - IsTagEnabled = true - Copyright = None - CustomFeeds = [] - } + static member Empty = + { IsFeedEnabled = true + FeedName = "feed.xml" + ItemsInFeed = None + IsCategoryEnabled = true + IsTagEnabled = true + Copyright = None + CustomFeeds = [] } /// An identifier for a tag mapping diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index cd722eb..c5c93a3 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -1146,17 +1146,16 @@ type SettingsModel = { } with /// Create a settings model from a web log - static member FromWebLog(webLog: WebLog) = { - Name = webLog.Name - Slug = webLog.Slug - Subtitle = defaultArg webLog.Subtitle "" - DefaultPage = webLog.DefaultPage - PostsPerPage = webLog.PostsPerPage - TimeZone = webLog.TimeZone - ThemeId = string webLog.ThemeId - AutoHtmx = webLog.AutoHtmx - Uploads = string webLog.Uploads - } + static member FromWebLog(webLog: WebLog) = + { Name = webLog.Name + Slug = webLog.Slug + Subtitle = defaultArg webLog.Subtitle "" + DefaultPage = webLog.DefaultPage + PostsPerPage = webLog.PostsPerPage + TimeZone = webLog.TimeZone + ThemeId = string webLog.ThemeId + AutoHtmx = webLog.AutoHtmx + Uploads = string webLog.Uploads } /// Update a web log with settings from the form member this.Update(webLog: WebLog) = diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index 7b2aaf3..86bc476 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -1074,6 +1074,147 @@ let manageRevisionsModelTests = testList "ManageRevisionsModel" [ } ] +/// Unit tests for the PostListItem type +let postListItemTests = testList "PostListItem" [ + testList "FromPost" [ + test "succeeds for a draft post" { + let post = + { Post.Empty with + Id = PostId "draft-post" + AuthorId = WebLogUserId "myself" + Title = "Not Ready for Prime Time" + Permalink = Permalink "2021/draft.html" + UpdatedOn = Noda.epoch + Duration.FromHours 8 + Text = "

      WIP

      " } + let model = PostListItem.FromPost { WebLog.Empty with TimeZone = "Etc/GMT-1" } post + Expect.equal model.Id "draft-post" "Id not filled properly" + Expect.equal model.AuthorId "myself" "AuthorId not filled properly" + Expect.equal model.Status "Draft" "Status not filled properly" + Expect.equal model.Title "Not Ready for Prime Time" "Title not filled properly" + Expect.equal model.Permalink "2021/draft.html" "Permalink not filled properly" + Expect.isFalse model.PublishedOn.HasValue "PublishedOn should not have had a value" + Expect.equal + model.UpdatedOn ((Noda.epoch + Duration.FromHours 9).ToDateTimeUtc()) "UpdatedOn not filled properly" + Expect.equal model.Text "

      WIP

      " "Text not filled properly" + Expect.isEmpty model.CategoryIds "There should have been no category IDs" + Expect.isEmpty model.Tags "There should have been no tags" + Expect.isNone model.Episode "There should not have been an episode" + Expect.isEmpty model.Metadata "There should have been no metadata" + } + test "succeeds for a published post in a non-root domain" { + let post = + { Post.Empty with + Id = PostId "full-post" + AuthorId = WebLogUserId "me" + Status = Published + Title = "Finished Product" + Permalink = Permalink "2021/post.html" + PublishedOn = Some (Noda.epoch + Duration.FromHours 12) + UpdatedOn = Noda.epoch + Duration.FromHours 13 + Text = """Click""" + CategoryIds = [ CategoryId "z"; CategoryId "y" ] + Tags = [ "test"; "unit" ] + Episode = Some { Episode.Empty with Media = "test.mp3" } + Metadata = [ { Name = "MyMeta"; Value = "MyValue" } ] } + let model = + PostListItem.FromPost { WebLog.Empty with UrlBase = "https://u.t/w"; TimeZone = "Etc/GMT+1" } post + Expect.equal model.Id "full-post" "Id not filled properly" + Expect.equal model.AuthorId "me" "AuthorId not filled properly" + Expect.equal model.Status "Published" "Status not filled properly" + Expect.equal model.Title "Finished Product" "Title not filled properly" + Expect.equal model.Permalink "2021/post.html" "Permalink not filled properly" + Expect.isTrue model.PublishedOn.HasValue "PublishedOn should not have had a value" + Expect.equal + model.PublishedOn.Value + ((Noda.epoch + Duration.FromHours 11).ToDateTimeUtc()) + "PublishedOn not filled properly" + Expect.equal + model.UpdatedOn ((Noda.epoch + Duration.FromHours 12).ToDateTimeUtc()) "UpdatedOn not filled properly" + Expect.equal model.Text """Click""" "Text not filled properly" + Expect.equal model.CategoryIds [ "z"; "y" ] "CategoryIds not filled properly" + Expect.equal model.Tags [ "test"; "unit" ] "Tags not filled properly" + Expect.isSome model.Episode "There should have been an episode" + Expect.equal model.Episode.Value.Media "test.mp3" "Episode not filled properly" + Expect.equal model.Metadata.Length 1 "There should have been 1 metadata item" + Expect.equal model.Metadata[0].Name "MyMeta" "Metadata not filled properly" + } + ] +] + +/// Unit tests for the SettingModel type +let settingsModelTests = testList "SettingsModel" [ + testList "FromWebLog" [ + test "succeeds with no subtitle" { + let model = + SettingsModel.FromWebLog + { WebLog.Empty with + Name = "The Web Log" + Slug = "the-web-log" + DefaultPage = "this-one" + PostsPerPage = 18 + TimeZone = "America/Denver" + ThemeId = ThemeId "my-theme" + AutoHtmx = true } + Expect.equal model.Name "The Web Log" "Name not filled properly" + Expect.equal model.Slug "the-web-log" "Slug not filled properly" + Expect.equal model.Subtitle "" "Subtitle not filled properly" + Expect.equal model.DefaultPage "this-one" "DefaultPage not filled properly" + Expect.equal model.PostsPerPage 18 "PostsPerPage not filled properly" + Expect.equal model.TimeZone "America/Denver" "TimeZone not filled properly" + Expect.equal model.ThemeId "my-theme" "ThemeId not filled properly" + Expect.isTrue model.AutoHtmx "AutoHtmx should have been set" + Expect.equal model.Uploads "Database" "Uploads not filled properly" + } + test "succeeds with a subtitle" { + let model = SettingsModel.FromWebLog { WebLog.Empty with Subtitle = Some "sub here!" } + Expect.equal model.Subtitle "sub here!" "Subtitle not filled properly" + } + ] + testList "Update" [ + test "succeeds with no subtitle" { + let webLog = + { Name = "Interesting" + Slug = "some-stuff" + Subtitle = "" + DefaultPage = "that-one" + PostsPerPage = 8 + TimeZone = "America/Chicago" + ThemeId = "test-theme" + AutoHtmx = true + Uploads = "Disk" }.Update WebLog.Empty + Expect.equal webLog.Name "Interesting" "Name not filled properly" + Expect.equal webLog.Slug "some-stuff" "Slug not filled properly" + Expect.isNone webLog.Subtitle "Subtitle should not have had a value" + Expect.equal webLog.DefaultPage "that-one" "DefaultPage not filled properly" + Expect.equal webLog.PostsPerPage 8 "PostsPerPage not filled properly" + Expect.equal webLog.TimeZone "America/Chicago" "TimeZone not filled properly" + Expect.equal webLog.ThemeId (ThemeId "test-theme") "ThemeId not filled properly" + Expect.isTrue webLog.AutoHtmx "AutoHtmx should have been set" + Expect.equal webLog.Uploads Disk "Uploads not filled properly" + } + test "succeeds with a subtitle" { + let webLog = { SettingsModel.FromWebLog WebLog.Empty with Subtitle = "Sub" }.Update WebLog.Empty + Expect.equal webLog.Subtitle (Some "Sub") "Subtitle should have had a value" + } + ] +] + +/// Unit tests for the UserMessage type +let userMessageTests = testList "UserMessage" [ + test "Success succeeds" { + Expect.equal UserMessage.Success.Level "success" "Level incorrect" + } + test "Info succeeds" { + Expect.equal UserMessage.Info.Level "primary" "Level incorrect" + } + test "Warning succeeds" { + Expect.equal UserMessage.Warning.Level "warning" "Level incorrect" + } + test "Error succeeds" { + Expect.equal UserMessage.Error.Level "danger" "Level incorrect" + } +] + /// All tests in the Domain.ViewModels file let all = testList "ViewModels" [ addBaseToRelativeUrlsTests @@ -1094,4 +1235,7 @@ let all = testList "ViewModels" [ editUserModelTests managePermalinksModelTests manageRevisionsModelTests + postListItemTests + settingsModelTests + userMessageTests ] -- 2.45.1 From a0ab99f73703988d491ec5282c2b2f08741b31aa Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 20 Jan 2024 13:45:56 -0500 Subject: [PATCH 053/123] Add unquoted relative URL support --- src/MyWebLog.Domain/ViewModels.fs | 4 +++- src/MyWebLog.Tests/ViewModelsTests.fs | 21 ++++++++++++++++----- 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index c5c93a3..b7620c9 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -21,7 +21,9 @@ module PublicHelpers = /// post text let addBaseToRelativeUrls extra (text: string) = if extra = "" then text - else text.Replace("href=\"/", $"href=\"{extra}/").Replace("src=\"/", $"src=\"{extra}/") + else + text.Replace("href=\"/", $"href=\"{extra}/").Replace("href=/", $"href={extra}/") + .Replace("src=\"/", $"src=\"{extra}/").Replace("src=/", $"src={extra}/") /// The model used to display the admin dashboard diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index 86bc476..44847e4 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -8,16 +8,27 @@ open NodaTime /// Unit tests for the addBaseToRelativeUrls helper function let addBaseToRelativeUrlsTests = testList "PublicHelpers.addBaseToRelativeUrls" [ - test "succeeds when there is no extra URL path" { - let testText = """Howdy>""" + test "succeeds for quoted URLs when there is no extra URL path" { + let testText = """""" let modified = addBaseToRelativeUrls "" testText Expect.equal modified testText "The text should not have been modified" } - test "succeeds with an extra URL path" { + test "succeeds for quoted URLs with an extra URL path" { let testText = - """link""" let expected = - """link""" + Expect.equal (addBaseToRelativeUrls "/a/b" testText) expected "Relative URLs not modified correctly" + } + test "succeeds for unquoted URLs when there is no extra URL path" { + let testText = "" + let modified = addBaseToRelativeUrls "" testText + Expect.equal modified testText "The text should not have been modified" + } + test "succeeds for unquoted URLs with an extra URL path" { + let testText = "link" + let expected = + "link" Expect.equal (addBaseToRelativeUrls "/a/b" testText) expected "Relative URLs not modified correctly" } ] -- 2.45.1 From 5ce84e18ca3829308c947ef336db04f2067f8589 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 20 Jan 2024 14:52:17 -0500 Subject: [PATCH 054/123] Fix SQLite page list query --- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 4 ++-- src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index fd390de..e76448c 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -53,7 +53,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = let countListed webLogId = log.LogTrace "Page.countListed" conn.customScalar - $"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField pgListName EQ "'true'"}""" + $"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField pgListName EQ "true"}""" [ webLogParam webLogId ] (toCount >> int) @@ -116,7 +116,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = let findListed webLogId = log.LogTrace "Page.findListed" conn.customList - $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField pgListName EQ "'true'"} + $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField pgListName EQ "true"} ORDER BY LOWER({titleField})""" [ webLogParam webLogId ] (fun rdr -> { fromData rdr with Text = "" }) diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 61cae3b..216c29b 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -49,7 +49,7 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = /// Find the names of users by their IDs for the given web log let findNames webLogId (userIds: WebLogUserId list) = log.LogTrace "WebLogUser.findNames" - let nameSql, nameParams = inClause "AND data ->> 'Id'" "id" string userIds + let nameSql, nameParams = inClause $"AND data ->> '{nameof WebLogUser.Empty.Id}'" "id" string userIds conn.customList $"{Document.Query.selectByWebLog Table.WebLogUser} {nameSql}" (webLogParam webLogId :: nameParams) -- 2.45.1 From d1a9606c5ca642a6c737b17109c8a4f683800cb4 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 20 Jan 2024 17:58:24 -0500 Subject: [PATCH 055/123] Tweak admin theme changes - Fix SQLite posts-by-tag query - Fix "on disk" check for default theme --- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 2 +- src/MyWebLog.Domain/ViewModels.fs | 3 ++- src/MyWebLog.Tests/ViewModelsTests.fs | 19 ++++++++++++++++--- src/admin-theme/custom-feed-edit.liquid | 8 ++++---- src/admin-theme/settings.liquid | 2 +- 5 files changed, 24 insertions(+), 10 deletions(-) diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index e5ab713..d2d5f0d 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -145,7 +145,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let tagSql, tagParams = inJsonArray Table.Post (nameof Post.Empty.Tags) "tag" [ tag ] conn.customList $"{publishedPostByWebLog} AND {tagSql} - ORDER BY p.published_on DESC + ORDER BY {publishField} DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" (webLogParam webLogId :: tagParams) fromData diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index b7620c9..f0036ee 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -205,12 +205,13 @@ type DisplayTheme = { /// Create a display theme from a theme static member FromTheme inUseFunc (theme: Theme) = + let fileName = if string theme.Id = "default" then "default-theme.zip" else $"./themes/{theme.Id}-theme.zip" { Id = string theme.Id Name = theme.Name Version = theme.Version TemplateCount = List.length theme.Templates IsInUse = inUseFunc theme.Id - IsOnDisk = File.Exists $"{theme.Id}-theme.zip" } + IsOnDisk = File.Exists fileName } /// Information about an uploaded file used for display diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/ViewModelsTests.fs index 44847e4..6bc7ecf 100644 --- a/src/MyWebLog.Tests/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/ViewModelsTests.fs @@ -175,8 +175,9 @@ let displayThemeTests = testList "DisplayTheme.FromTheme" [ Expect.isTrue model.IsInUse "IsInUse should have been set" Expect.isFalse model.IsOnDisk "IsOnDisk should not have been set" } - test "succeeds when the theme is not in use as is on disk" { - let file = File.Create "another-theme.zip" + test "succeeds when a non-default theme is not in use and is on disk" { + let dir = Directory.CreateDirectory "themes" + let file = File.Create "./themes/another-theme.zip" try let model = DisplayTheme.FromTheme (fun _ -> false) { theme with Id = ThemeId "another" } Expect.isFalse model.IsInUse "IsInUse should not have been set" @@ -184,7 +185,19 @@ let displayThemeTests = testList "DisplayTheme.FromTheme" [ finally file.Close() file.Dispose() - File.Delete "another-theme.zip" + File.Delete "./themes/another-theme.zip" + dir.Delete() + } + test "succeeds when the default theme is on disk" { + let file = File.Create "./default-theme.zip" + try + Expect.isTrue + (DisplayTheme.FromTheme (fun _ -> false) { theme with Id = ThemeId "default" }).IsOnDisk + "IsOnDisk should have been set" + finally + file.Close() + file.Dispose() + File.Delete "./default-theme.zip" } ] diff --git a/src/admin-theme/custom-feed-edit.liquid b/src/admin-theme/custom-feed-edit.liquid index 507e8cf..20d4297 100644 --- a/src/admin-theme/custom-feed-edit.liquid +++ b/src/admin-theme/custom-feed-edit.liquid @@ -28,7 +28,7 @@
      + {%- if model.is_podcast %} checked{% endif %} onclick="Admin.checkPodcast()">
      @@ -42,7 +42,7 @@
      + {%- unless typ == "tag" %} checked{% endunless %} onclick="Admin.customFeedBy('category')">
      @@ -67,14 +67,14 @@
      + {%- if typ == "tag" %} checked{% endif %} onclick="Admin.customFeedBy('tag')">
      diff --git a/src/admin-theme/settings.liquid b/src/admin-theme/settings.liquid index e9a03cc..ec70201 100644 --- a/src/admin-theme/settings.liquid +++ b/src/admin-theme/settings.liquid @@ -145,7 +145,7 @@
      + {%- if rss_model.is_tag_enabled %} checked{% endif %}>
      -- 2.45.1 From cfb3c3a2870ec37bf2fa3fa99f19f7843f1f6ac8 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 20 Jan 2024 22:11:27 -0500 Subject: [PATCH 056/123] Add JSON converter tests --- src/MyWebLog.Tests/ConvertersTests.fs | 265 +++++++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 2 + src/MyWebLog.Tests/Program.fs | 1 + src/MyWebLog.Tests/root-weblog.json | 1 + 4 files changed, 269 insertions(+) create mode 100644 src/MyWebLog.Tests/ConvertersTests.fs create mode 100644 src/MyWebLog.Tests/root-weblog.json diff --git a/src/MyWebLog.Tests/ConvertersTests.fs b/src/MyWebLog.Tests/ConvertersTests.fs new file mode 100644 index 0000000..3699943 --- /dev/null +++ b/src/MyWebLog.Tests/ConvertersTests.fs @@ -0,0 +1,265 @@ +module ConvertersTests + +open Expecto +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("\"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("\"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("\"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("\"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("\"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("\"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 "

      test

      ", opts) + Expect.equal after "\"HTML:

      test

      \"" "Markup text serialized incorrectly" + } + test "succeeds when deserializing" { + let after = JsonConvert.DeserializeObject("\"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("\"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("\"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("\"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("\"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("\"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("\"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("\"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("\"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("\"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("\"user-test\"", opts) + Expect.equal after (WebLogUserId "user-test") "Web log user ID deserialized 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 +] diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index d415d68..b33f3fd 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -8,7 +8,9 @@ + + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index 5755a72..7db606f 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -2,6 +2,7 @@ let allTests = testList "MyWebLog" [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] + testList "Data" [ ConvertersTests.all ] ] [] diff --git a/src/MyWebLog.Tests/root-weblog.json b/src/MyWebLog.Tests/root-weblog.json new file mode 100644 index 0000000..7577c81 --- /dev/null +++ b/src/MyWebLog.Tests/root-weblog.json @@ -0,0 +1 @@ +{"WebLog":{"Id":"uSitJEuD3UyzWC9jgOHc8g","Name":"Root WebLog","Slug":"root-weblog","Subtitle":"This is the main one","DefaultPage":"posts","PostsPerPage":9,"ThemeId":"default","UrlBase":"http://localhost:8081","TimeZone":"America/Denver","Rss":{"IsFeedEnabled":true,"FeedName":"feed","ItemsInFeed":7,"IsCategoryEnabled":true,"IsTagEnabled":true,"Copyright":"CC40-NC-BY","CustomFeeds":[{"Id":"isPQ6drbDEydxohQzaiYtQ","Source":"tag:podcast","Path":"podcast-feed","Podcast":{"Title":"Root Podcast","ItemsInFeed":23,"Summary":"All things that happen in the domain root","DisplayedAuthor":"Podcaster Extraordinaire","Email":"podcaster@example.com","ImageUrl":"images/cover-art.png","AppleCategory":"Fiction","AppleSubcategory":"Drama","Explicit":"no","DefaultMediaType":"audio/mpeg","MediaBaseUrl":"https://media.example.com/root/","PodcastGuid":"10fd7f79-c719-4e1d-9da7-10405dd4fd96","FundingUrl":"https://example.com/support-us","FundingText":"Support Our Work","Medium":"newsletter"}}]},"AutoHtmx":true,"Uploads":"Database","RedirectRules":[]},"Users":[{"Id":"5EM2rimH9kONpmd2zQkiVA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Email":"root@example.com","FirstName":"Root","LastName":"Owner","PreferredName":"Admin","PasswordHash":"AQAAAAIAAYagAAAAEEnq9J9lKZoMQZaTOJHKIQo44skDdzDigzqS+o6myMop38YuHfm/vNs9b/WpYjsOxg==","AccessLevel":"Administrator","CreatedOn":"2024-01-20T21:49:03Z","LastSeenOn":"2024-01-20T22:25:03Z"},{"Id":"GPbJaSOwTkKt14ZKYyveKA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Email":"editor@example.com","FirstName":"Ed","LastName":"It-Or","PreferredName":"Edits","PasswordHash":"AQAAAAIAAYagAAAAEA8E3NwJkZO+q35FTmUT0wMNB8IpBOSVACKQcccXpaWfZJMRmZzjPEzd4j/f9h+rEA==","AccessLevel":"Editor","CreatedOn":"2024-01-20T21:58:42Z"},{"Id":"iIRNLSeY0EanxRPyqGuwVg","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Email":"author@example.com","FirstName":"Author","LastName":"Dude","PreferredName":"Mister","PasswordHash":"AQAAAAIAAYagAAAAEBYNf1sR/pjaX2dZgqlvpH/Tqpz2h/CG3rsk/wH2ReTysjpK/gxSqht7IULWXM7KHQ==","Url":"https://example.com/author","AccessLevel":"Author","CreatedOn":"2024-01-20T21:53:27Z"}],"Theme":{"Id":"default","Name":"myWebLog Default Theme","Version":"2.1.0","Templates":[{"Name":"single-post","Text":"{%- assign post = model.posts | first -%}\n

      {{ post.title }}

      \n

      \n {% if post.published_on -%}\n Published {{ post.published_on | date: \"dddd, MMMM d, yyyy\" }}\n at {{ post.published_on | date: \"h:mm tt\" | downcase }}\n {%- else -%}\n **DRAFT**\n {% endif %}\n by {{ model.authors | value: post.author_id }}\n {%- if is_editor or is_author and user_id == post.author_id %}\n • Edit Post\n {%- endif %}\n

      \n
      \n
      \n
      {{ post.text }}
      \n {%- assign cat_count = post.category_ids | size -%}\n {% if cat_count > 0 -%}\n

      \n Categorized under\n {% for cat_id in post.category_ids -%}\n {% assign cat = categories | where: \"Id\", cat_id | first %}\n \n \n {{ cat.name }}\n \n \n {% unless forloop.last %} • {% endunless %}\n {%- endfor %}\n

      \n {%- endif %}\n {%- assign tag_count = post.tags | size -%}\n {% if tag_count > 0 -%}\n

      \n Tagged\n {% for tag in post.tags %}\n \n {{ tag }}\n \n {% unless forloop.last %} • {% endunless %}\n {%- endfor %}\n

      \n {%- endif %}\n
      \n
      \n \n
      \n
      \n"},{"Name":"single-page","Text":"

      {{ page.title }}

      \n
      {{ page.text }}
      \n"},{"Name":"layout","Text":"\n\n \n \n \n {{ page_title | strip_html }}{% if page_title %} « {% endif %}{{ web_log.name | strip_html }}\n {% page_head -%}\n
      \n \n
      \n
      \n {% if messages %}\n
      \n {% for msg in messages %}\n \n {% endfor %}\n
      \n {% endif %}\n {{ content }} \n
      \n
      \n
      \n
      \n myWebLog\n
      \n
      \n \n\n"},{"Name":"index","Text":"{%- if is_category or is_tag %}\n

      {{ page_title }}

      \n {%- if subtitle %}

      {{ subtitle }}

      {% endif -%}\n{% endif %}\n{%- assign post_count = model.posts | size -%}\n{%- if post_count > 0 %}\n
      \n {%- for post in model.posts %}\n
      \n

      \n \n {{ post.title }}\n \n

      \n

      \n Published on {{ post.published_on | date: \"MMMM d, yyyy\" }}\n at {{ post.published_on | date: \"h:mmtt\" | downcase }}\n by {{ model.authors | value: post.author_id }}\n {{ post.text }}\n {%- assign category_count = post.category_ids | size -%}\n {%- assign tag_count = post.tags | size -%}\n {% if category_count > 0 or tag_count > 0 %}\n

      \n

      \n {%- if category_count > 0 -%}\n Categorized under:\n {% for cat in post.category_ids -%}\n {%- assign this_cat = categories | where: \"Id\", cat | first -%}\n {{ this_cat.name }}{% unless forloop.last %}, {% endunless %}\n {%- assign cat_names = this_cat.name | concat: cat_names -%}\n {%- endfor -%}\n {%- assign cat_names = \"\" -%}\n
      \n {% endif -%}\n {%- if tag_count > 0 %}\n Tagged: {{ post.tags | join: \", \" }}\n {% endif -%}\n

      \n {% endif %}\n
      \n
      \n {% endfor %}\n
      \n \n{%- else %}\n

      No posts found

      \n{%- endif %}\n"}]},"Assets":[{"Id":"default/style.css","UpdatedOn":"2023-07-02T20:36:28Z","Data":"Lm1lc3NhZ2VzIHsKICBtYXgtd2lkdGg6IDYwcmVtOwogIG1hcmdpbjogYXV0bzsKfQpibG9ja3F1b3RlIHsKICBib3JkZXItbGVmdDogc29saWQgNHB4IGxpZ2h0Z3JheTsKICBwYWRkaW5nLWxlZnQ6IDFyZW07Cn0KLml0ZW0tbWV0YSB7CiAgZm9udC1zaXplOiAxLjFyZW07CiAgZm9udC13ZWlnaHQ6IG5vcm1hbDs7Cn0KLml0ZW0tbWV0YTo6YmVmb3JlIHsKICBjb250ZW50OiAiwrsiOwogIHZlcnRpY2FsLWFsaWduOiB0ZXh0LXRvcDsKfQphOmxpbmssIGE6dmlzaXRlZCB7CiAgdGV4dC1kZWNvcmF0aW9uOiBub25lOwp9CmE6aG92ZXIgewogIHRleHQtZGVjb3JhdGlvbjogdW5kZXJsaW5lOwp9Cg=="}],"Categories":[{"Id":"S5JflPsJ9EG7gA2LD4m92A","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Name":"Favorites","Slug":"favorites","Description":"Favorite posts"},{"Id":"jw6N69YtTEWVHAO33jHU-w","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Name":"Spitball","Slug":"spitball","Description":"Posts that may or may not work"},{"Id":"ScVpyu1e7UiP7bDdge3ZEw","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Name":"Moonshot","Slug":"moonshot","ParentId":"jw6N69YtTEWVHAO33jHU-w"}],"TagMappings":[{"Id":"Icm027noqE-rPHKZA98vAw","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Tag":"f#","UrlValue":"f-sharp"},{"Id":"GdryXh-S0kGsNBs2RIacGA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Tag":"ghoti","UrlValue":"fish"}],"Pages":[{"Id":"hgc_BLEZ50SoAWLuPNISvA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Title":"Page Title","Permalink":"a-cool-page.html","PublishedOn":"2024-01-20T22:14:28Z","UpdatedOn":"2024-01-20T22:14:28Z","IsInPageList":false,"Text":"

      A Cool Page

      \n

      It really is cool!

      \n","Metadata":[{"Name":"Cool","Value":"true"},{"Name":"Warm","Value":"false"}],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:14:28Z","Text":"Markdown: # A Cool Page\n\nIt really is cool!"}]},{"Id":"KouRjvSmm0Wz6TMD8xf67A","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Title":"Yet Another Page","Permalink":"this-again.html","PublishedOn":"2024-01-20T22:15:08Z","UpdatedOn":"2024-01-20T22:15:08Z","IsInPageList":true,"Text":"

      Page 2

      \n\n

      It's a trip.","Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:15:08Z","Text":"HTML:

      Page 2

      \n\n

      It's a trip."}]}],"Posts":[{"Id":"RCsCU2puYEmkpzotoi8p4g","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Test Post 1","Permalink":"2024/test-post-1.html","PublishedOn":"2024-01-20T22:17:29Z","UpdatedOn":"2024-01-20T22:17:29Z","Text":"

      Introduction

      \n

      Visit my web site or my local page for more information.

      \n","CategoryIds":["ScVpyu1e7UiP7bDdge3ZEw"],"Tags":["f#","howdy","intro"],"Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:17:29Z","Text":"Markdown: ## Introduction\n\nVisit [my web site](https://example.com) or [my local page](/a-fine-page.html) for more information."}]},{"Id":"osxMfWGlAkyugUbJ1-xD1g","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Episode 1","Permalink":"2024/episode-1.html","PublishedOn":"2024-01-20T22:24:01Z","UpdatedOn":"2024-01-20T22:24:01Z","Text":"

      It's the launch of my new podcast - y'all come listen!","CategoryIds":["S5JflPsJ9EG7gA2LD4m92A"],"Tags":["general","podcast"],"Episode":{"Media":"episode-1.mp3","Length":124302,"Duration":"0:12:22","ImageUrl":"images/ep1-cover.png","Subtitle":"An introduction to this podcast","Explicit":"clean","ChapterFile":"uploads/chapters.json","TranscriptUrl":"uploads/transcript.srt","TranscriptType":"application/srt","TranscriptLang":"en","TranscriptCaptions":true,"SeasonNumber":1,"SeasonDescription":"The First Season","EpisodeNumber":1.0,"EpisodeDescription":"The first episode ever!"},"Metadata":[{"Name":"Density","Value":"Non-existent"},{"Name":"Intensity","Value":"Low"}],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:24:01Z","Text":"HTML:

      It's the launch of my new podcast - y'all come listen!"}]},{"Id":"l4_Eh4aFO06SqqJjOymNzA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Episode 2","Permalink":"2024/episode-2.html","PublishedOn":"2024-01-20T22:31:32Z","UpdatedOn":"2024-01-20T22:31:32Z","Text":"

      m i n i m a l","CategoryIds":[],"Tags":["podcast"],"Episode":{"Media":"episode-2.mp3","Length":12873952,"Duration":"1:03:24","SeasonNumber":1,"SeasonDescription":"The First Season","EpisodeNumber":2.0,"EpisodeDescription":"A long update"},"Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:31:32Z","Text":"HTML:

      m i n i m a l"}]},{"Id":"QweKbWQiOkqqrjEdgP9wwg","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Something May Happen","Permalink":"2024/something.html","PublishedOn":"2024-01-20T22:32:59Z","UpdatedOn":"2024-01-20T22:32:59Z","Text":"

      Hmm

      ","CategoryIds":["jw6N69YtTEWVHAO33jHU-w"],"Tags":["f#","ghoti","speculation"],"Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:32:59Z","Text":"HTML:

      Hmm

      "}]}],"Uploads":[]} \ No newline at end of file -- 2.45.1 From ffe6713b5e1ff7ac99da9edbe15c37e37592f4ca Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 21 Jan 2024 09:17:01 -0500 Subject: [PATCH 057/123] Add converter / utils tests --- src/MyWebLog.Data/Converters.fs | 36 ++++----- src/MyWebLog.Data/MyWebLog.Data.fsproj | 8 +- src/MyWebLog.Data/Utils.fs | 22 ++---- src/MyWebLog.Tests/ConvertersTests.fs | 31 ++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + src/MyWebLog.Tests/Program.fs | 2 +- src/MyWebLog.Tests/UtilsTests.fs | 96 ++++++++++++++++++++++++ 7 files changed, 161 insertions(+), 35 deletions(-) create mode 100644 src/MyWebLog.Tests/UtilsTests.fs diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index b4e07a1..ad14d54 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -135,24 +135,24 @@ module Json = /// Configure a serializer to use these converters let configure (ser : JsonSerializer) = // Our converters - [ CategoryIdConverter() :> JsonConverter - CommentIdConverter() - CommentStatusConverter() - CustomFeedIdConverter() - CustomFeedSourceConverter() - ExplicitRatingConverter() - MarkupTextConverter() - PermalinkConverter() - PageIdConverter() - PodcastMediumConverter() - PostIdConverter() - TagMapIdConverter() - ThemeAssetIdConverter() - ThemeIdConverter() - UploadIdConverter() - WebLogIdConverter() - WebLogUserIdConverter() - ] |> List.iter ser.Converters.Add + [ CategoryIdConverter() :> JsonConverter + CommentIdConverter() + CommentStatusConverter() + CustomFeedIdConverter() + CustomFeedSourceConverter() + ExplicitRatingConverter() + MarkupTextConverter() + PermalinkConverter() + PageIdConverter() + PodcastMediumConverter() + PostIdConverter() + TagMapIdConverter() + ThemeAssetIdConverter() + ThemeIdConverter() + UploadIdConverter() + WebLogIdConverter() + WebLogUserIdConverter() ] + |> List.iter ser.Converters.Add // NodaTime let _ = ser.ConfigureForNodaTime DateTimeZoneProviders.Tzdb // Handles DUs with no associated data, as well as option fields diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 5c8082d..0aa40b8 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -42,7 +42,13 @@ - + +       + + + + <_Parameter1>MyWebLog.Tests + diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index eb87162..3432d34 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -9,13 +9,13 @@ 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 = 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 } + { 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 } yield! orderByHierarchy cats (Some cat.Id) (Some fullSlug) ([ cat.Name ] |> List.append parentNames) } @@ -24,14 +24,6 @@ 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: Permalink list) newLinks = - diffLists oldLinks newLinks string - /// Find the revisions added and removed let diffRevisions (oldRevs: Revision list) newRevs = diffLists oldRevs newRevs (fun rev -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text}") diff --git a/src/MyWebLog.Tests/ConvertersTests.fs b/src/MyWebLog.Tests/ConvertersTests.fs index 3699943..3f9f053 100644 --- a/src/MyWebLog.Tests/ConvertersTests.fs +++ b/src/MyWebLog.Tests/ConvertersTests.fs @@ -1,6 +1,7 @@ module ConvertersTests open Expecto +open Microsoft.FSharpLu.Json open MyWebLog open MyWebLog.Converters.Json open Newtonsoft.Json @@ -243,6 +244,35 @@ let webLogUserIdConverterTests = testList "WebLogUserIdConverter" [ } ] +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) "Category ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Comment ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Comment status converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Custom feed ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Custom feed source converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Explicit rating converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Markup text converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Permalink converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Page ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Podcast medium converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Post ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Tag map ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Theme asset ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Theme ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Upload ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Web log ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "Web log user ID converter not found" + Expect.hasCountOf ser.Converters 1u (has typeof) "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 @@ -262,4 +292,5 @@ let all = testList "Converters" [ uploadIdConverterTests webLogIdConverterTests webLogUserIdConverterTests + configureTests ] diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index b33f3fd..a0433b0 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -9,6 +9,7 @@ + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index 7db606f..eda78d1 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -2,7 +2,7 @@ let allTests = testList "MyWebLog" [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] - testList "Data" [ ConvertersTests.all ] + testList "Data" [ ConvertersTests.all; UtilsTests.all ] ] [] diff --git a/src/MyWebLog.Tests/UtilsTests.fs b/src/MyWebLog.Tests/UtilsTests.fs new file mode 100644 index 0000000..9346e87 --- /dev/null +++ b/src/MyWebLog.Tests/UtilsTests.fs @@ -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 "

      test" } + { AsOf = Noda.epoch; Text = Html "

      test test" } ] + let newItems = + [ { AsOf = Noda.epoch; Text = Html "

      test test" } + { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "

      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 "

      test" } + { AsOf = Noda.epoch + Duration.FromDays 2; Text = Html "

      tests" } + { AsOf = Noda.epoch; Text = Html "

      test test" } ] + let newItems = + [ { AsOf = Noda.epoch + Duration.FromDays 4; Text = Html "

      tests" } + { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "

      test" } + { AsOf = Noda.epoch; Text = Html "

      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 +] -- 2.45.1 From 1345074c71a3c76153e79f18a602f5d7c5169577 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 21 Jan 2024 14:26:02 -0500 Subject: [PATCH 058/123] Add framework for SQLite data tests --- src/MyWebLog.Data/SQLiteData.fs | 8 ++-- src/MyWebLog.Tests/CategoryDataTests.fs | 15 ++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 2 + src/MyWebLog.Tests/Program.fs | 2 +- src/MyWebLog.Tests/SQLiteDataTests.fs | 59 ++++++++++++++++++++++++ src/MyWebLog/Maintenance.fs | 2 +- src/MyWebLog/MyWebLog.fsproj | 6 +++ 7 files changed, 88 insertions(+), 6 deletions(-) create mode 100644 src/MyWebLog.Tests/CategoryDataTests.fs create mode 100644 src/MyWebLog.Tests/SQLiteDataTests.fs diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 52f6de2..424f282 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -1,5 +1,6 @@ namespace MyWebLog.Data +open System open System.Threading.Tasks open BitBadger.Documents open BitBadger.Documents.Sqlite @@ -221,8 +222,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria 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 System.Double.Parse + EpisodeNumber = Map.tryString "episode_number" epRdr |> Option.map Double.Parse EpisodeDescription = Map.tryString "episode_description" epRdr } } |> List.ofSeq epRdr.Close() @@ -235,8 +235,8 @@ type SQLiteData(conn: SqliteConnection, log: ILogger, ser: JsonSeria cmd.Parameters.Clear()) logStep "Migrating dates/times" - let inst (dt: System.DateTime) = - System.DateTime(dt.Ticks, System.DateTimeKind.Utc) + 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" diff --git a/src/MyWebLog.Tests/CategoryDataTests.fs b/src/MyWebLog.Tests/CategoryDataTests.fs new file mode 100644 index 0000000..01872a1 --- /dev/null +++ b/src/MyWebLog.Tests/CategoryDataTests.fs @@ -0,0 +1,15 @@ +module CategoryDataTests + +open Expecto +open MyWebLog +open MyWebLog.Data + +/// Tests for the Add method +let addTests (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" +} + diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index a0433b0..8887ed0 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -10,6 +10,8 @@ + + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index eda78d1..b01944f 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -2,7 +2,7 @@ let allTests = testList "MyWebLog" [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] - testList "Data" [ ConvertersTests.all; UtilsTests.all ] + testList "Data" [ ConvertersTests.all; UtilsTests.all; SQLiteDataTests.all ] ] [] diff --git a/src/MyWebLog.Tests/SQLiteDataTests.fs b/src/MyWebLog.Tests/SQLiteDataTests.fs new file mode 100644 index 0000000..073115e --- /dev/null +++ b/src/MyWebLog.Tests/SQLiteDataTests.fs @@ -0,0 +1,59 @@ +module SQLiteDataTests + +open BitBadger.Documents +open Expecto +open Microsoft.Extensions.Logging.Abstractions +open MyWebLog +open MyWebLog.Converters +open MyWebLog.Data +open Newtonsoft.Json + +/// JSON serializer +let ser = Json.configure (JsonSerializer.CreateDefault()) + +/// Create a SQLiteData instance for testing +let mkData () = + Sqlite.Configuration.useConnectionString "Data Source=./test-db.db" + let conn = Sqlite.Configuration.dbConn () + SQLiteData(conn, NullLogger(), ser) :> IData + +/// Dispose the connection associated with the SQLiteData instance +let dispose (data: IData) = + (data :?> SQLiteData).Conn.Dispose() + +/// Set up the environment for the SQLite tests +let environmentSetUp = testList "Environment" [ + testTask "creating database" { + let data = mkData () + try + do! data.StartUp() + do! Maintenance.Backup.restoreBackup "root-weblog.json" None false data + finally dispose data + } +] + +/// Integration tests for the Category implementation in SQLite +let categoryTests = testList "Category" [ + testTask "Add succeeds" { + let data = mkData () + try do! CategoryDataTests.addTests data + finally dispose data + } +] + + +open System.IO + +/// Delete the SQLite database +let environmentCleanUp = test "Clean Up" { + File.Delete "test-db.db" + Expect.isFalse (File.Exists "test-db.db") "The test SQLite database should have been deleted" +} + +/// All SQLite data tests +let all = + testList "SQLiteData" + [ environmentSetUp + categoryTests + environmentCleanUp ] + |> testSequenced diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 54ab9fc..1612add 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -395,7 +395,7 @@ module Backup = } /// Decide whether to restore a backup - let private restoreBackup fileName newUrlBase promptForOverwrite data = task { + let internal restoreBackup fileName newUrlBase promptForOverwrite data = task { let serializer = getSerializer false use stream = new FileStream(fileName, FileMode.Open) diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index a270487..4707fa3 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -42,4 +42,10 @@ + + + <_Parameter1>MyWebLog.Tests + + + -- 2.45.1 From 3835ed984e8ec7a0dc62d06650a1bdb9034486fd Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 21 Jan 2024 14:29:58 -0500 Subject: [PATCH 059/123] Rearrange test files --- .../{ => Data}/CategoryDataTests.fs | 0 src/MyWebLog.Tests/{ => Data}/ConvertersTests.fs | 0 src/MyWebLog.Tests/{ => Data}/SQLiteDataTests.fs | 0 src/MyWebLog.Tests/{ => Data}/UtilsTests.fs | 0 .../{ => Domain}/DataTypesTests.fs | 0 .../{ => Domain}/SupportTypesTests.fs | 0 .../{ => Domain}/ViewModelsTests.fs | 0 src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 16 ++++++++-------- 8 files changed, 8 insertions(+), 8 deletions(-) rename src/MyWebLog.Tests/{ => Data}/CategoryDataTests.fs (100%) rename src/MyWebLog.Tests/{ => Data}/ConvertersTests.fs (100%) rename src/MyWebLog.Tests/{ => Data}/SQLiteDataTests.fs (100%) rename src/MyWebLog.Tests/{ => Data}/UtilsTests.fs (100%) rename src/MyWebLog.Tests/{ => Domain}/DataTypesTests.fs (100%) rename src/MyWebLog.Tests/{ => Domain}/SupportTypesTests.fs (100%) rename src/MyWebLog.Tests/{ => Domain}/ViewModelsTests.fs (100%) diff --git a/src/MyWebLog.Tests/CategoryDataTests.fs b/src/MyWebLog.Tests/Data/CategoryDataTests.fs similarity index 100% rename from src/MyWebLog.Tests/CategoryDataTests.fs rename to src/MyWebLog.Tests/Data/CategoryDataTests.fs diff --git a/src/MyWebLog.Tests/ConvertersTests.fs b/src/MyWebLog.Tests/Data/ConvertersTests.fs similarity index 100% rename from src/MyWebLog.Tests/ConvertersTests.fs rename to src/MyWebLog.Tests/Data/ConvertersTests.fs diff --git a/src/MyWebLog.Tests/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs similarity index 100% rename from src/MyWebLog.Tests/SQLiteDataTests.fs rename to src/MyWebLog.Tests/Data/SQLiteDataTests.fs diff --git a/src/MyWebLog.Tests/UtilsTests.fs b/src/MyWebLog.Tests/Data/UtilsTests.fs similarity index 100% rename from src/MyWebLog.Tests/UtilsTests.fs rename to src/MyWebLog.Tests/Data/UtilsTests.fs diff --git a/src/MyWebLog.Tests/DataTypesTests.fs b/src/MyWebLog.Tests/Domain/DataTypesTests.fs similarity index 100% rename from src/MyWebLog.Tests/DataTypesTests.fs rename to src/MyWebLog.Tests/Domain/DataTypesTests.fs diff --git a/src/MyWebLog.Tests/SupportTypesTests.fs b/src/MyWebLog.Tests/Domain/SupportTypesTests.fs similarity index 100% rename from src/MyWebLog.Tests/SupportTypesTests.fs rename to src/MyWebLog.Tests/Domain/SupportTypesTests.fs diff --git a/src/MyWebLog.Tests/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs similarity index 100% rename from src/MyWebLog.Tests/ViewModelsTests.fs rename to src/MyWebLog.Tests/Domain/ViewModelsTests.fs diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 8887ed0..3196b07 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -5,15 +5,15 @@ - - - - - - - + + + + + + + - + -- 2.45.1 From 182b33ae79eb18d9a65bab19cf4e3b8632a102c1 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 21 Jan 2024 22:03:57 -0500 Subject: [PATCH 060/123] Add Category tests, implement for SQLite --- .../SQLite/SQLiteCategoryData.fs | 14 +- src/MyWebLog.Tests/Data/CategoryDataTests.fs | 135 +++++++++++++++++- src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 116 +++++++++++++-- src/MyWebLog/Maintenance.fs | 27 ++-- 4 files changed, 266 insertions(+), 26 deletions(-) diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index e1fb304..66d325f 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -80,13 +80,21 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge | Some cat -> // Reassign any children to the category's parent category let! children = conn.countByField Table.Category parentIdField EQ (string catId) - if children > 0 then - do! conn.patchByField Table.Category parentIdField EQ (string catId) {| ParentId = cat.ParentId |} + if children > 0L then + match cat.ParentId with + | Some _ -> + do! conn.patchByField Table.Category parentIdField EQ (string catId) {| ParentId = cat.ParentId |} + | None -> + do! conn.customNonQuery + $"""UPDATE {Table.Category} + SET data = json_remove(data, '$.ParentId') + WHERE {Query.whereByField parentIdField EQ "@field"}""" + [ fieldParam (string catId) ] // 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 ->> '{Post.Empty.Id}', data -> '{catIdField}' + $"SELECT data ->> '{nameof Post.Empty.Id}', data -> '{catIdField}' FROM {Table.Post} WHERE {Document.Query.whereByWebLog} AND EXISTS diff --git a/src/MyWebLog.Tests/Data/CategoryDataTests.fs b/src/MyWebLog.Tests/Data/CategoryDataTests.fs index 01872a1..a148b7e 100644 --- a/src/MyWebLog.Tests/Data/CategoryDataTests.fs +++ b/src/MyWebLog.Tests/Data/CategoryDataTests.fs @@ -4,8 +4,14 @@ 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 favoritesId = CategoryId "S5JflPsJ9EG7gA2LD4m92A" + /// Tests for the Add method -let addTests (data: IData) = task { +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 @@ -13,3 +19,130 @@ let addTests (data: IData) = task { 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" +} diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 073115e..f010601 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -1,5 +1,6 @@ module SQLiteDataTests +open System.IO open BitBadger.Documents open Expecto open Microsoft.Extensions.Logging.Abstractions @@ -11,9 +12,12 @@ open Newtonsoft.Json /// JSON serializer let ser = Json.configure (JsonSerializer.CreateDefault()) +/// The test database name +let dbName = "test-db.db" + /// Create a SQLiteData instance for testing let mkData () = - Sqlite.Configuration.useConnectionString "Data Source=./test-db.db" + Sqlite.Configuration.useConnectionString $"Data Source=./{dbName}" let conn = Sqlite.Configuration.dbConn () SQLiteData(conn, NullLogger(), ser) :> IData @@ -21,13 +25,24 @@ let mkData () = let dispose (data: IData) = (data :?> SQLiteData).Conn.Dispose() +/// Create a fresh environment from the root backup +let freshEnvironment (data: IData option) = task { + let env = + match data with + | Some d -> d + | None -> + File.Delete dbName + 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 SQLite tests let environmentSetUp = testList "Environment" [ testTask "creating database" { let data = mkData () - try - do! data.StartUp() - do! Maintenance.Backup.restoreBackup "root-weblog.json" None false data + try do! freshEnvironment (Some data) finally dispose data } ] @@ -36,18 +51,101 @@ let environmentSetUp = testList "Environment" [ let categoryTests = testList "Category" [ testTask "Add succeeds" { let data = mkData () - try do! CategoryDataTests.addTests data + try do! CategoryDataTests.``Add succeeds`` data finally dispose data } + testList "CountAll" [ + testTask "succeeds when categories exist" { + let data = mkData () + try do! CategoryDataTests.``CountAll succeeds when categories exist`` data + finally dispose data + } + testTask "succeeds when categories do not exist" { + let data = mkData () + try do! CategoryDataTests.``CountAll succeeds when categories do not exist`` data + finally dispose data + } + ] + testList "CountTopLevel" [ + testTask "succeeds when top-level categories exist" { + let data = mkData () + try do! CategoryDataTests.``CountTopLevel succeeds when top-level categories exist`` data + finally dispose data + } + testTask "succeeds when no top-level categories exist" { + let data = mkData () + try do! CategoryDataTests.``CountTopLevel succeeds when no top-level categories exist`` data + finally dispose data + } + ] + testTask "FindAllForView succeeds" { + let data = mkData () + try do! CategoryDataTests.``FindAllForView succeeds`` data + finally dispose data + } + testList "FindById" [ + testTask "succeeds when a category is found" { + let data = mkData () + try do! CategoryDataTests.``FindById succeeds when a category is found`` data + finally dispose data + } + testTask "succeeds when a category is not found" { + let data = mkData () + try do! CategoryDataTests.``FindById succeeds when a category is not found`` data + finally dispose data + } + ] + testList "FindByWebLog" [ + testTask "succeeds when categories exist" { + let data = mkData () + try do! CategoryDataTests.``FindByWebLog succeeds when categories exist`` data + finally dispose data + } + testTask "succeeds when no categories exist" { + let data = mkData () + try do! CategoryDataTests.``FindByWebLog succeeds when no categories exist`` data + finally dispose data + } + ] + testTask "Update succeeds" { + let data = mkData () + try do! CategoryDataTests.``Update succeeds`` data + finally dispose data + } + testList "Delete" [ + testTask "succeeds when the category is deleted (no posts)" { + let data = mkData () + try do! CategoryDataTests.``Delete succeeds when the category is deleted (no posts)`` data + finally dispose data + } + testTask "succeeds when the category does not exist" { + let data = mkData () + try do! CategoryDataTests.``Delete succeeds when the category does not exist`` data + finally dispose data + } + testTask "succeeds when reassigning parent category to None" { + let data = mkData () + try do! CategoryDataTests.``Delete succeeds when reassigning parent category to None`` data + finally dispose data + } + testTask "succeeds when reassigning parent category to Some" { + let data = mkData () + try do! CategoryDataTests.``Delete succeeds when reassigning parent category to Some`` data + finally dispose data + } + testTask "succeeds and removes category from posts" { + let data = mkData () + try do! CategoryDataTests.``Delete succeeds and removes category from posts`` data + finally dispose data + } + ] ] -open System.IO - /// Delete the SQLite database let environmentCleanUp = test "Clean Up" { - File.Delete "test-db.db" - Expect.isFalse (File.Exists "test-db.db") "The test SQLite database should have been deleted" + File.Delete dbName + Expect.isFalse (File.Exists dbName) "The test SQLite database should have been deleted" } /// All SQLite data tests diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 1612add..43caaca 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -313,7 +313,7 @@ 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 -> @@ -357,45 +357,46 @@ module Backup = } // Restore theme and assets (one at a time, as assets can be large) - printfn "" - printfn "- Importing theme..." + if isInteractive then + printfn "" + printfn "- Importing theme..." do! data.Theme.Save restore.Theme restore.Assets |> List.iter (EncodedAsset.toAsset >> data.ThemeAsset.Save >> Async.AwaitTask >> Async.RunSynchronously) // Restore web log data - printfn "- Restoring web log..." + 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..." + 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..." + if isInteractive then printfn "- Restoring pages..." if not (List.isEmpty restore.Pages) then do! data.Page.Restore restore.Pages - printfn "- Restoring 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 internal restoreBackup fileName newUrlBase promptForOverwrite data = task { + let internal restoreBackup fileName newUrlBase promptForOverwrite isInteractive data = task { let serializer = getSerializer false use stream = new FileStream(fileName, FileMode.Open) @@ -413,7 +414,7 @@ module Backup = 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" } @@ -445,7 +446,7 @@ module Backup = if args.Length = 2 || args.Length = 3 then let data = sp.GetRequiredService() let newUrlBase = if args.Length = 3 then Some args[2] else None - do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") data + do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") true data else eprintfn "Usage: myWebLog restore [backup-file-name] [*url-base]" eprintfn " * optional - will restore to original URL base if omitted" -- 2.45.1 From 13994a29e7c519fa74c77d7cc66f4a520b178f7c Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 23 Jan 2024 23:26:30 -0500 Subject: [PATCH 061/123] Convert to rc2 of doc lib --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 6 ++-- .../Postgres/PostgresCategoryData.fs | 29 +++++++++++++------ .../SQLite/SQLiteCategoryData.fs | 15 ++++------ src/MyWebLog.Data/SQLite/SQLiteHelpers.fs | 6 ++-- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 9 +++--- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 15 ++++++---- src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs | 6 ++-- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 16 +++++----- .../SQLite/SQLiteWebLogUserData.fs | 9 +++--- src/MyWebLog.Domain/MyWebLog.Domain.fsproj | 4 +-- src/MyWebLog/MyWebLog.fsproj | 4 +-- 11 files changed, 65 insertions(+), 54 deletions(-) diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 0aa40b8..804465b 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -5,9 +5,9 @@ - - - + + + diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index d127585..60afe53 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -81,15 +81,26 @@ type PostgresCategoryData(log: ILogger) = let! children = Find.byContains Table.Category {| ParentId = catId |} let hasChildren = not (List.isEmpty children) if hasChildren then - let! _ = - Configuration.dataSource () - |> Sql.fromDataSource - |> Sql.executeTransactionAsync - [ Query.Patch.byId Table.Category, - children - |> List.map (fun child -> - [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ]) ] - () + if cat.ParentId.IsSome then + let! _ = + Configuration.dataSource () + |> Sql.fromDataSource + |> Sql.executeTransactionAsync + [ Query.Patch.byId Table.Category, + children + |> List.map (fun child -> + [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ]) ] + () + else + let! _ = + Configuration.dataSource () + |> Sql.fromDataSource + |> Sql.executeTransactionAsync + [ Query.RemoveFields.byId Table.Category, + children + |> List.map (fun child -> + [ idParam child.Id; fieldNameParam [ nameof Category.Empty.ParentId ] ]) ] + () // Delete the category off all posts where it is assigned let! posts = Custom.list diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index 66d325f..4cf6104 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -53,7 +53,7 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') FROM {Table.Post} WHERE {Document.Query.whereByWebLog} - AND {Query.whereByField (nameof Post.Empty.Status) EQ $"'{string Published}'"} + 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 @@ -79,17 +79,12 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge match! findById catId webLogId with | Some cat -> // Reassign any children to the category's parent category - let! children = conn.countByField Table.Category parentIdField EQ (string catId) + 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 parentIdField EQ (string catId) {| ParentId = cat.ParentId |} - | None -> - do! conn.customNonQuery - $"""UPDATE {Table.Category} - SET data = json_remove(data, '$.ParentId') - WHERE {Query.whereByField parentIdField EQ "@field"}""" - [ fieldParam (string catId) ] + | 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 = diff --git a/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs index 07e23e7..bfb8952 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteHelpers.fs @@ -239,7 +239,7 @@ module Document = /// Fragment to add a web log ID condition to a WHERE clause (parameter @webLogId) let whereByWebLog = - Query.whereByField "WebLogId" EQ "@webLogId" + Query.whereByField (Field.EQ "WebLogId" "") "@webLogId" /// A SELECT query to count documents for a given web log ID let countByWebLog table = @@ -255,7 +255,7 @@ module Document = /// Count documents for the given web log ID let countByWebLog table (webLogId: WebLogId) conn = backgroundTask { - let! count = Count.byField table "WebLogId" EQ (string webLogId) conn + let! count = Count.byField table (Field.EQ "WebLogId" (string webLogId)) conn return int count } @@ -265,7 +265,7 @@ module Document = /// Find documents for the given web log let findByWebLog<'TDoc> table (webLogId: WebLogId) conn = - Find.byField<'TDoc> table "WebLogId" EQ (string webLogId) conn + Find.byField<'TDoc> table (Field.EQ "WebLogId" (string webLogId)) conn /// Functions to support revisions diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index e76448c..dde7b02 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -53,7 +53,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = let countListed webLogId = log.LogTrace "Page.countListed" conn.customScalar - $"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField pgListName EQ "true"}""" + $"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"}""" [ webLogParam webLogId ] (toCount >> int) @@ -88,9 +88,10 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = /// Find a page by its permalink for the given web log let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Page.findByPermalink" + let linkParam = Field.EQ linkName (string permalink) conn.customSingle - $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkName EQ "@link"}""" - [ webLogParam webLogId; SqliteParameter("@link", string permalink) ] + $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkParam "@link"}""" + (addFieldParam "@link" linkParam [ webLogParam webLogId ]) fromData /// Find the current permalink within a set of potential prior permalinks for the given web log @@ -116,7 +117,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = let findListed webLogId = log.LogTrace "Page.findListed" conn.customList - $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField pgListName EQ "true"} + $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"} ORDER BY LOWER({titleField})""" [ webLogParam webLogId ] (fun rdr -> { fromData rdr with Text = "" }) diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index d2d5f0d..3a67a9c 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -34,7 +34,8 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = let postByWebLog = Document.Query.selectByWebLog Table.Post /// The SELECT statement to retrieve published posts with a web log ID parameter - let publishedPostByWebLog = $"""{postByWebLog} AND {Query.whereByField statName EQ $"'{string Published}'"}""" + let publishedPostByWebLog = + $"""{postByWebLog} AND {Query.whereByField (Field.EQ statName "") $"'{string Published}'"}""" /// Update a post's revisions let updatePostRevisions (postId: PostId) oldRevs newRevs = @@ -46,9 +47,10 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = /// Count posts in a status for the given web log 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 statName EQ "@status"}""" - [ webLogParam webLogId; SqliteParameter("@status", string status) ] + $"""{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) @@ -59,9 +61,10 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = /// Find a post by its permalink for the given web log (excluding revisions) let findByPermalink (permalink: Permalink) webLogId = log.LogTrace "Post.findByPermalink" + let linkParam = Field.EQ linkName (string permalink) conn.customSingle - $"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkName EQ "@link"}""" - [ webLogParam webLogId; SqliteParameter("@link", string permalink) ] + $"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkParam "@link"}""" + (addFieldParam "@link" linkParam [ webLogParam webLogId ]) fromData /// Find a complete post by its ID for the given web log @@ -82,7 +85,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = do! conn.customNonQuery $"""DELETE FROM {Table.PostRevision} WHERE post_id = @id; DELETE FROM {Table.PostComment} - WHERE {Query.whereByField (nameof Comment.Empty.PostId) EQ "@id"}; + WHERE {Query.whereByField (Field.EQ (nameof Comment.Empty.PostId) "") "@id"}; {Query.Delete.byId Table.Post}""" [ idParam postId ] return true diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index 50a4b04..f71c61e 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -28,10 +28,10 @@ type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) = /// Find a tag mapping by its URL value for the given web log let findByUrlValue (urlValue: string) webLogId = log.LogTrace "TagMap.findByUrlValue" + let urlParam = Field.EQ (nameof TagMap.Empty.UrlValue) urlValue conn.customSingle - $"""{Document.Query.selectByWebLog Table.TagMap} - AND {Query.whereByField (nameof TagMap.Empty.UrlValue) EQ "@urlValue"}""" - [ webLogParam webLogId; SqliteParameter("@urlValue", urlValue) ] + $"""{Document.Query.selectByWebLog Table.TagMap} AND {Query.whereByField urlParam "@urlValue"}""" + (addFieldParam "@urlValue" urlParam [ webLogParam webLogId ]) fromData /// Get all tag mappings for the given web log diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index a9d1d17..93af895 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -23,25 +23,25 @@ type SQLiteWebLogData(conn: SqliteConnection, log: ILogger) = /// Delete a web log by its ID let delete webLogId = log.LogTrace "WebLog.delete" - let subQuery table = - $"""(SELECT data ->> 'Id' FROM {table} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}""" + 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 {Query.whereByField "WebLogId" EQ "@webLogId"}; - DELETE FROM {Table.Page} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; - DELETE FROM {Table.Category} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; - DELETE FROM {Table.TagMap} WHERE {Query.whereByField "WebLogId" EQ "@webLogId"}; + 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 {Query.whereByField "WebLogId" EQ "@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) = log.LogTrace "WebLog.findByHost" - conn.findFirstByField Table.WebLog (nameof WebLog.Empty.UrlBase) EQ url + conn.findFirstByField Table.WebLog (Field.EQ (nameof WebLog.Empty.UrlBase) url) /// Find a web log by its ID let findById webLogId = diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 216c29b..f87b6c4 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -20,8 +20,8 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = log.LogTrace "WebLogUser.delete" match! findById userId webLogId with | Some _ -> - let! pageCount = conn.countByField Table.Page (nameof Page.Empty.AuthorId) EQ (string userId) - let! postCount = conn.countByField Table.Post (nameof Post.Empty.AuthorId) EQ (string userId) + 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 @@ -33,10 +33,11 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = /// Find a user by their e-mail address for the given web log let findByEmail (email: string) webLogId = log.LogTrace "WebLogUser.findByEmail" + let emailParam = Field.EQ (nameof WebLogUser.Empty.Email) email conn.customSingle $"""{Document.Query.selectByWebLog Table.WebLogUser} - AND {Query.whereByField (nameof WebLogUser.Empty.Email) EQ "@email"}""" - [ webLogParam webLogId; sqlParam "@email" email ] + AND {Query.whereByField emailParam "@email"}""" + (addFieldParam "@email" emailParam [ webLogParam webLogId ]) fromData /// Get all users for the given web log diff --git a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj index 9460006..d86aa8a 100644 --- a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj +++ b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj @@ -7,10 +7,10 @@ - + - + diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 4707fa3..076a51b 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -26,8 +26,8 @@ - - + + -- 2.45.1 From 19777c7badf383ae9f55449dcf0ffc5692eb1730 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 24 Jan 2024 20:20:46 -0500 Subject: [PATCH 062/123] Add Postgres Category tests --- .../Postgres/PostgresCategoryData.fs | 41 +++---- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 114 ++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 2 + src/MyWebLog.Tests/Program.fs | 2 +- 4 files changed, 137 insertions(+), 22 deletions(-) create mode 100644 src/MyWebLog.Tests/Data/PostgresDataTests.fs diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index 60afe53..6909684 100644 --- a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -18,7 +18,11 @@ type PostgresCategoryData(log: ILogger) = /// Count all top-level categories for the given web log let countTopLevel webLogId = log.LogTrace "Category.countTopLevel" - Count.byContains Table.Category {| webLogDoc webLogId with ParentId = None |} + 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 { @@ -81,26 +85,21 @@ type PostgresCategoryData(log: ILogger) = let! children = Find.byContains Table.Category {| ParentId = catId |} let hasChildren = not (List.isEmpty children) if hasChildren then - if cat.ParentId.IsSome then - let! _ = - Configuration.dataSource () - |> Sql.fromDataSource - |> Sql.executeTransactionAsync - [ Query.Patch.byId Table.Category, - children - |> List.map (fun child -> - [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ]) ] - () - else - let! _ = - Configuration.dataSource () - |> Sql.fromDataSource - |> Sql.executeTransactionAsync - [ Query.RemoveFields.byId Table.Category, - children - |> List.map (fun child -> - [ idParam child.Id; fieldNameParam [ nameof Category.Empty.ParentId ] ]) ] - () + 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 diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs new file mode 100644 index 0000000..217f475 --- /dev/null +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -0,0 +1,114 @@ +module PostgresDataTests + +open BitBadger.Documents +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 ser = Json.configure (JsonSerializer.CreateDefault()) + +/// The throwaway database (deleted when disposed) +let mutable db: ThrowawayDatabase option = None + +/// Create a PostgresData instance for testing +let mkData () = + PostgresData(NullLogger(), ser) :> IData + +/// Create a fresh environment from the root backup +let freshEnvironment () = task { + if Option.isSome db then db.Value.Dispose() + db <- Some (ThrowawayDatabase.Create "Host=localhost;Database=postgres;User ID=postgres;Password=postgres") + let source = NpgsqlDataSourceBuilder db.Value.ConnectionString + let _ = source.UseNodaTime() + Postgres.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 environmentSetUp = testTask "creating database" { + do! freshEnvironment () +} + +/// Integration tests for the Category implementation in SQLite +let 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 ()) + } + ] +] + +/// Drop the throwaway PostgreSQL database +let environmentCleanUp = test "Clean Up" { + if db.IsSome then db.Value.Dispose() +} + +/// All PostgreSQL data tests +let all = + testList "PostgresData" + [ environmentSetUp + categoryTests + environmentCleanUp ] + |> testSequenced diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 3196b07..0d58c9e 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -12,12 +12,14 @@ + + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index b01944f..f360e1c 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -2,7 +2,7 @@ let allTests = testList "MyWebLog" [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] - testList "Data" [ ConvertersTests.all; UtilsTests.all; SQLiteDataTests.all ] + testList "Data" [ ConvertersTests.all; UtilsTests.all; SQLiteDataTests.all; PostgresDataTests.all ] ] [] -- 2.45.1 From d09a5e1243ecfa853fb040fc31598fe07c2e55bf Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 25 Jan 2024 22:34:42 -0500 Subject: [PATCH 063/123] Add data test for Page.Add --- src/MyWebLog.Tests/Data/CategoryDataTests.fs | 1 - src/MyWebLog.Tests/Data/PageDataTests.fs | 45 ++++++++++++++++++++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 10 ++++- src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 9 ++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + 5 files changed, 64 insertions(+), 2 deletions(-) create mode 100644 src/MyWebLog.Tests/Data/PageDataTests.fs diff --git a/src/MyWebLog.Tests/Data/CategoryDataTests.fs b/src/MyWebLog.Tests/Data/CategoryDataTests.fs index a148b7e..9368545 100644 --- a/src/MyWebLog.Tests/Data/CategoryDataTests.fs +++ b/src/MyWebLog.Tests/Data/CategoryDataTests.fs @@ -10,7 +10,6 @@ let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" /// The ID of the Favorites category let favoritesId = CategoryId "S5JflPsJ9EG7gA2LD4m92A" -/// Tests for the Add method let ``Add succeeds`` (data: IData) = task { let category = { Category.Empty with Id = CategoryId "added-cat"; WebLogId = WebLogId "test"; Name = "Added"; Slug = "added" } diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs new file mode 100644 index 0000000..3b04430 --- /dev/null +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -0,0 +1,45 @@ +module PageDataTests + +open Expecto +open MyWebLog +open MyWebLog.Data +open NodaTime + +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 = "

      A new page

      " + Metadata = [ { Name = "Meta Item"; Value = "Meta Value" } ] + PriorPermalinks = [ Permalink "2024/the-new-page.htm" ] + Revisions = [ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "

      A new page

      " } ] } + 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.hasLength pg.Metadata 1 "There should have been one meta item properly" + Expect.equal pg.Metadata[0].Name page.Metadata[0].Name "Metadata name not saved properly" + Expect.equal pg.Metadata[0].Value page.Metadata[0].Value "Metadata value not saved properly" + Expect.hasLength pg.PriorPermalinks 1 "There should have been one prior permalink" + Expect.equal pg.PriorPermalinks[0] page.PriorPermalinks[0] "Prior permalink not saved properly" + Expect.hasLength pg.Revisions 1 "There should have been one revision" + Expect.equal pg.Revisions[0].AsOf page.Revisions[0].AsOf "Revision as of not saved properly" + Expect.equal pg.Revisions[0].Text page.Revisions[0].Text "Revision text not saved properly" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 217f475..dc553e5 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -38,7 +38,7 @@ let environmentSetUp = testTask "creating database" { do! freshEnvironment () } -/// Integration tests for the Category implementation in SQLite +/// Integration tests for the Category implementation in PostgreSQL let categoryTests = testList "Category" [ testTask "Add succeeds" { do! CategoryDataTests.``Add succeeds`` (mkData ()) @@ -100,6 +100,13 @@ let categoryTests = testList "Category" [ ] ] +/// Integration tests for the Page implementation in PostgreSQL +let pageTests = testList "Page" [ + testTask "Add succeeds" { + do! PageDataTests.``Add succeeds`` (mkData ()) + } +] + /// Drop the throwaway PostgreSQL database let environmentCleanUp = test "Clean Up" { if db.IsSome then db.Value.Dispose() @@ -110,5 +117,6 @@ let all = testList "PostgresData" [ environmentSetUp categoryTests + pageTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index f010601..2f06919 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -141,6 +141,14 @@ let categoryTests = testList "Category" [ ] ] +/// Integration tests for the Page implementation in SQLite +let pageTests = testList "Page" [ + testTask "Add succeeds" { + let data = mkData () + try do! PageDataTests.``Add succeeds`` data + finally dispose data + } +] /// Delete the SQLite database let environmentCleanUp = test "Clean Up" { @@ -153,5 +161,6 @@ let all = testList "SQLiteData" [ environmentSetUp categoryTests + pageTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 0d58c9e..2066418 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -11,6 +11,7 @@ + -- 2.45.1 From f701fc9c93de0cde04bb02ea6b3cdd544aebe0e6 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 26 Jan 2024 17:27:04 -0500 Subject: [PATCH 064/123] Add data test for Page.All --- src/MyWebLog.Data/Interfaces.fs | 2 +- src/MyWebLog.Tests/Data/PageDataTests.fs | 10 ++++++++++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 3 +++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 5 +++++ 4 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index 15d8069..a05d6b5 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -54,7 +54,7 @@ type IPageData = /// Add a page abstract member Add : Page -> Task - /// Get all pages for the web log (excluding meta items, text, revisions, and prior permalinks) + /// Get all pages for the web log (excluding revisions) abstract member All : WebLogId -> Task /// Count all pages for the given web log diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index 3b04430..0017066 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -5,6 +5,9 @@ open MyWebLog open MyWebLog.Data open NodaTime +/// The ID of the root web log +let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" + let ``Add succeeds`` (data: IData) = task { let page = { Id = PageId "added-page" @@ -43,3 +46,10 @@ let ``Add succeeds`` (data: IData) = task { Expect.equal pg.Revisions[0].AsOf page.Revisions[0].AsOf "Revision as of not saved properly" Expect.equal pg.Revisions[0].Text page.Revisions[0].Text "Revision text not saved properly" } + +let ``All succeeds`` (data: IData) = task { + let! pages = data.Page.All rootId + Expect.hasLength pages 2 "There should have been 4 pages retrieved" + Expect.isEmpty pages[0].Revisions "Page 0 should have had no revisions" + Expect.isEmpty pages[1].Revisions "Page 1 should have had no revisions" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index dc553e5..d7c4d3b 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -105,6 +105,9 @@ let pageTests = testList "Page" [ testTask "Add succeeds" { do! PageDataTests.``Add succeeds`` (mkData ()) } + testTask "All succeeds" { + do! PageDataTests.``All succeeds`` (mkData ()) + } ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 2f06919..08edc8b 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -148,6 +148,11 @@ let pageTests = testList "Page" [ try do! PageDataTests.``Add succeeds`` data finally dispose data } + testTask "All succeeds" { + let data = mkData () + try do! PageDataTests.``All succeeds`` data + finally dispose data + } ] /// Delete the SQLite database -- 2.45.1 From 0e8044b9484fd276e29287a2642632477f6a6d7b Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 27 Jan 2024 18:04:41 -0500 Subject: [PATCH 065/123] Add RethinkDB tests - Add env variables for all data tests - Standardize Page.All behavior - Add Page.Count* tests --- src/MyWebLog.Data/Interfaces.fs | 2 +- .../Postgres/PostgresPageData.fs | 4 +- src/MyWebLog.Data/RethinkDbData.fs | 14 +- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 4 +- src/MyWebLog.Tests/Data/PageDataTests.fs | 19 ++- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 25 ++- src/MyWebLog.Tests/Data/RethinkDbTests.fs | 147 ++++++++++++++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 13 +- src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + src/MyWebLog.Tests/Program.fs | 8 +- 10 files changed, 220 insertions(+), 17 deletions(-) create mode 100644 src/MyWebLog.Tests/Data/RethinkDbTests.fs diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index a05d6b5..1f6a839 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -54,7 +54,7 @@ type IPageData = /// Add a page abstract member Add : Page -> Task - /// Get all pages for the web log (excluding revisions) + /// Get all pages for the web log (excluding text, metadata, revisions, and prior permalinks) abstract member All : WebLogId -> Task /// Count all pages for the given web log diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 33fb0e4..465172b 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -35,13 +35,13 @@ type PostgresPageData(log: ILogger) = // IMPLEMENTATION FUNCTIONS - /// Get all pages for a web log (without text or 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 ] - fromData + (fun row -> { fromData row with Text = ""; Metadata = []; PriorPermalinks = [] }) /// Count all pages for the given web log let countAll webLogId = diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 4ab4294..ce65ef3 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -279,7 +279,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger { withTable Table.Category getAll [ webLogId ] (nameof Category.Empty.WebLogId) - filter (nameof Category.Empty.ParentId) None + filter (nameof Category.Empty.ParentId) None (Default FilterDefaultHandling.Return) count result; withRetryDefault conn } @@ -361,7 +361,9 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger 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 @@ -408,10 +410,10 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger { 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 ] + 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 } diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index dde7b02..738b5f4 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -36,13 +36,13 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = // IMPLEMENTATION FUNCTIONS - /// Get all pages for a web log (without text or revisions) + /// 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 rdr with Text = "" }) + (fun rdr -> { fromData rdr with Text = ""; Metadata = []; PriorPermalinks = [] }) /// Count all pages for the given web log let countAll webLogId = diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index 0017066..1bece19 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -49,7 +49,20 @@ let ``Add succeeds`` (data: IData) = task { let ``All succeeds`` (data: IData) = task { let! pages = data.Page.All rootId - Expect.hasLength pages 2 "There should have been 4 pages retrieved" - Expect.isEmpty pages[0].Revisions "Page 0 should have had no revisions" - Expect.isEmpty pages[1].Revisions "Page 1 should have had no revisions" + 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 ``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" } diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index d7c4d3b..6266bc6 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -1,5 +1,6 @@ module PostgresDataTests +open System open BitBadger.Documents open Expecto open Microsoft.Extensions.Logging.Abstractions @@ -20,10 +21,26 @@ let mutable db: ThrowawayDatabase option = None let mkData () = PostgresData(NullLogger(), ser) :> IData +/// The host for the PostgreSQL test database (defaults to localhost) +let testHost = + RethinkDbTests.env "PG_HOST" "localhost" + +/// The database name for the PostgreSQL test database (defaults to postgres) +let testDb = + RethinkDbTests.env "PG_DB" "postgres" + +/// The user ID for the PostgreSQL test database (defaults to postgres) +let testUser = + RethinkDbTests.env "PG_USER" "postgres" + +/// The password for the PostgreSQL test database (defaults to postgres) +let testPw = + RethinkDbTests.env "PG_PW" "postgres" + /// Create a fresh environment from the root backup let freshEnvironment () = task { if Option.isSome db then db.Value.Dispose() - db <- Some (ThrowawayDatabase.Create "Host=localhost;Database=postgres;User ID=postgres;Password=postgres") + db <- Some (ThrowawayDatabase.Create $"Host={testHost};Database={testDb};User ID={testUser};Password={testPw}") let source = NpgsqlDataSourceBuilder db.Value.ConnectionString let _ = source.UseNodaTime() Postgres.Configuration.useDataSource (source.Build()) @@ -108,6 +125,12 @@ let pageTests = testList "Page" [ testTask "All succeeds" { do! PageDataTests.``All succeeds`` (mkData ()) } + testTask "CountAll succeeds" { + do! PageDataTests.``CountAll succeeds`` (mkData ()) + } + testTask "CountListed succeeds" { + do! PageDataTests.``CountListed succeeds`` (mkData ()) + } ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbTests.fs b/src/MyWebLog.Tests/Data/RethinkDbTests.fs new file mode 100644 index 0000000..d5abf93 --- /dev/null +++ b/src/MyWebLog.Tests/Data/RethinkDbTests.fs @@ -0,0 +1,147 @@ +module RethinkDbTests + +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 dataCfg = + DataConfig.FromUri (env "RETHINK_URI" "rethinkdb://172.17.0.2/mwl_test") + +/// The active data instance to use for testing +let mutable data: IData option = None + +/// Dispose the existing data +let 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 newData () = + let log = NullLogger() + let conn = dataCfg.CreateConnection log + RethinkDbData(conn, dataCfg, log) + +/// Create a fresh environment from the root backup +let 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 environmentSetUp = testTask "creating database" { + let _ = Json.configure Converter.Serializer + do! freshEnvironment () +} + +/// Integration tests for the Category implementation in RethinkDB +let 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 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 + } +] + +/// Drop the throwaway RethinkDB database +let environmentCleanUp = testTask "Clean Up" { + do! disposeData () +} + +/// All RethinkDB data tests +let all = + testList "RethinkDbData" + [ environmentSetUp + categoryTests + pageTests + environmentCleanUp ] + |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 08edc8b..a6bcde2 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -13,7 +13,8 @@ open Newtonsoft.Json let ser = Json.configure (JsonSerializer.CreateDefault()) /// The test database name -let dbName = "test-db.db" +let dbName = + RethinkDbTests.env "SQLITE_DB" "test-db.db" /// Create a SQLiteData instance for testing let mkData () = @@ -153,6 +154,16 @@ let pageTests = testList "Page" [ try do! PageDataTests.``All succeeds`` data finally dispose data } + testTask "CountAll succeeds" { + let data = mkData () + try do! PageDataTests.``CountAll succeeds`` data + finally dispose data + } + testTask "CountListed succeeds" { + let data = mkData () + try do! PageDataTests.``CountListed succeeds`` data + finally dispose data + } ] /// Delete the SQLite database diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 2066418..1ef9297 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -12,6 +12,7 @@ + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index f360e1c..43077ee 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -2,7 +2,13 @@ let allTests = testList "MyWebLog" [ testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] - testList "Data" [ ConvertersTests.all; UtilsTests.all; SQLiteDataTests.all; PostgresDataTests.all ] + testList "Data" [ + ConvertersTests.all + UtilsTests.all + RethinkDbTests.all + SQLiteDataTests.all + PostgresDataTests.all + ] ] [] -- 2.45.1 From 3f269ed3ba6ea95bd078fc07101794b57591321f Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 27 Jan 2024 23:22:54 -0500 Subject: [PATCH 066/123] Add Page Find[Full]ById tests - Add prior permalink to a page --- .../Postgres/PostgresPageData.fs | 11 +- src/MyWebLog.Data/RethinkDbData.fs | 29 +- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 11 +- src/MyWebLog.Tests/Data/PageDataTests.fs | 60 +++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 19 + src/MyWebLog.Tests/Data/RethinkDbTests.fs | 19 + src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 29 ++ src/MyWebLog.Tests/root-weblog.json | 345 +++++++++++++++++- 8 files changed, 503 insertions(+), 20 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 465172b..d8350bd 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -53,15 +53,18 @@ type PostgresPageData(log: ILogger) = log.LogTrace "Page.countListed" Count.byContains Table.Page {| webLogDoc webLogId with IsInPageList = true |} - /// Find a page by its ID (without revisions) - let findById pageId webLogId = + /// Find a page by its ID (without revisions or prior permalinks) + let findById pageId webLogId = backgroundTask { log.LogTrace "Page.findById" - Document.findByIdAndWebLog Table.Page pageId webLogId + match! Document.findByIdAndWebLog 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! findById pageId webLogId with + match! Document.findByIdAndWebLog Table.Page pageId webLogId with | Some page -> let! withMore = appendPageRevisions page return Some withMore diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index ce65ef3..70fbb6f 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -444,20 +444,27 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger 0UL } - member _.FindById pageId webLogId = - rethink { - withTable Table.Page - get pageId - without [ nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] - resultOption; withRetryOptionDefault - } - |> verifyWebLog webLogId (fun it -> it.WebLogId) <| conn + member _.FindById pageId webLogId = backgroundTask { + let! page = + rethink { + withTable Table.Page + getAll [ pageId ] + without [ nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] + result; withRetryDefault + } + |> tryFirst <| conn + return + page + |> Option.filter (fun pg -> pg.WebLogId = webLogId) + |> Option.map (fun pg -> { pg with Revisions = []; PriorPermalinks = [] }) + } member _.FindByPermalink permalink webLogId = rethink { withTable Table.Page getAll [ [| webLogId :> obj; permalink |] ] (nameof Page.Empty.Permalink) - without [ nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] + merge (r.HashMap(nameof Page.Empty.PriorPermalinks, [||]) + .With(nameof Page.Empty.Revisions, [||])) limit 1 result; withRetryDefault } @@ -474,7 +481,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger tryFirst) conn - return result |> Option.map (fun pg -> pg.Permalink) + return result |> Option.map _.Permalink } member _.FindFullById pageId webLogId = @@ -483,7 +490,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger verifyWebLog webLogId (fun it -> it.WebLogId) <| conn + |> verifyWebLog webLogId _.WebLogId <| conn member _.FindFullByWebLog webLogId = rethink { withTable Table.Page diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index 738b5f4..1d11140 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -57,15 +57,18 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = [ webLogParam webLogId ] (toCount >> int) - /// Find a page by its ID (without revisions) - let findById pageId webLogId = + /// Find a page by its ID (without revisions and prior permalinks) + let findById pageId webLogId = backgroundTask { log.LogTrace "Page.findById" - Document.findByIdAndWebLog Table.Page pageId webLogId conn + match! Document.findByIdAndWebLog 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 { log.LogTrace "Page.findFullById" - match! findById pageId webLogId with + match! Document.findByIdAndWebLog Table.Page pageId webLogId conn with | Some page -> let! page = appendPageRevisions page return Some page diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index 1bece19..d8513ee 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -1,5 +1,6 @@ module PageDataTests +open System open Expecto open MyWebLog open MyWebLog.Data @@ -8,6 +9,12 @@ open NodaTime /// The ID of the root web log let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" +/// 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 coolPagePublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z") + let ``Add succeeds`` (data: IData) = task { let page = { Id = PageId "added-page" @@ -55,6 +62,8 @@ let ``All succeeds`` (data: IData) = task { 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 { @@ -66,3 +75,54 @@ 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 (Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z")) "Published On is incorrect" + Expect.equal pg.UpdatedOn (Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z")) "Updated On is incorrect" + Expect.isFalse pg.IsInPageList "Is in page list flag should not have been set" + Expect.equal pg.Text "

      A Cool Page

      \n

      It really is cool!

      \n" "Text is incorrect" + Expect.hasLength pg.Metadata 2 "There should be 2 metadata items on this page" + Expect.equal pg.Metadata[0].Name "Cool" "Meta item 0 name is incorrect" + Expect.equal pg.Metadata[0].Value "true" "Meta item 0 value is incorrect" + Expect.equal pg.Metadata[1].Name "Warm" "Meta item 1 name is incorrect" + Expect.equal pg.Metadata[1].Value "false" "Meta item 1 value 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 ``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.hasLength pg.Revisions 1 "There should be 1 revision" + Expect.equal pg.Revisions[0].AsOf coolPagePublished "Revision 0 as-of is incorrect" + Expect.equal pg.Revisions[0].Text (Markdown "# A Cool Page\n\nIt really is cool!") "Revision 0 text is incorrect" + Expect.hasLength pg.PriorPermalinks 1 "There should be 1 prior permalink" + Expect.equal pg.PriorPermalinks[0] (Permalink "a-cool-pg.html") "Prior permalink 0 is 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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 6266bc6..8a87552 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -131,6 +131,25 @@ let pageTests = testList "Page" [ 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 "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 ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbTests.fs b/src/MyWebLog.Tests/Data/RethinkDbTests.fs index d5abf93..f6d3863 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbTests.fs @@ -130,6 +130,25 @@ let pageTests = testList "Page" [ 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 "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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index a6bcde2..b2c724c 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -164,6 +164,35 @@ let pageTests = testList "Page" [ try do! PageDataTests.``CountListed succeeds`` data finally dispose data } + testList "FindById" [ + testTask "succeeds when a page is found" { + let data = mkData () + try do! PageDataTests.``FindById succeeds when a page is found`` data + finally dispose data + } + testTask "succeeds when a page is not found (incorrect weblog)" { + let data = mkData () + try do! PageDataTests.``FindById succeeds when a page is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a page is not found (bad page ID)" { + let data = mkData () + try do! PageDataTests.``FindById succeeds when a page is not found (bad page ID)`` data + finally dispose data + } + ] + testList "FindFullById" [ + testTask "succeeds when a page is found" { + let data = mkData () + try do! PageDataTests.``FindFullById succeeds when a page is found`` data + finally dispose data + } + testTask "succeeds when a page is not found" { + let data = mkData () + try do! PageDataTests.``FindFullById succeeds when a page is not found`` data + finally dispose data + } + ] ] /// Delete the SQLite database diff --git a/src/MyWebLog.Tests/root-weblog.json b/src/MyWebLog.Tests/root-weblog.json index 7577c81..39babe3 100644 --- a/src/MyWebLog.Tests/root-weblog.json +++ b/src/MyWebLog.Tests/root-weblog.json @@ -1 +1,344 @@ -{"WebLog":{"Id":"uSitJEuD3UyzWC9jgOHc8g","Name":"Root WebLog","Slug":"root-weblog","Subtitle":"This is the main one","DefaultPage":"posts","PostsPerPage":9,"ThemeId":"default","UrlBase":"http://localhost:8081","TimeZone":"America/Denver","Rss":{"IsFeedEnabled":true,"FeedName":"feed","ItemsInFeed":7,"IsCategoryEnabled":true,"IsTagEnabled":true,"Copyright":"CC40-NC-BY","CustomFeeds":[{"Id":"isPQ6drbDEydxohQzaiYtQ","Source":"tag:podcast","Path":"podcast-feed","Podcast":{"Title":"Root Podcast","ItemsInFeed":23,"Summary":"All things that happen in the domain root","DisplayedAuthor":"Podcaster Extraordinaire","Email":"podcaster@example.com","ImageUrl":"images/cover-art.png","AppleCategory":"Fiction","AppleSubcategory":"Drama","Explicit":"no","DefaultMediaType":"audio/mpeg","MediaBaseUrl":"https://media.example.com/root/","PodcastGuid":"10fd7f79-c719-4e1d-9da7-10405dd4fd96","FundingUrl":"https://example.com/support-us","FundingText":"Support Our Work","Medium":"newsletter"}}]},"AutoHtmx":true,"Uploads":"Database","RedirectRules":[]},"Users":[{"Id":"5EM2rimH9kONpmd2zQkiVA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Email":"root@example.com","FirstName":"Root","LastName":"Owner","PreferredName":"Admin","PasswordHash":"AQAAAAIAAYagAAAAEEnq9J9lKZoMQZaTOJHKIQo44skDdzDigzqS+o6myMop38YuHfm/vNs9b/WpYjsOxg==","AccessLevel":"Administrator","CreatedOn":"2024-01-20T21:49:03Z","LastSeenOn":"2024-01-20T22:25:03Z"},{"Id":"GPbJaSOwTkKt14ZKYyveKA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Email":"editor@example.com","FirstName":"Ed","LastName":"It-Or","PreferredName":"Edits","PasswordHash":"AQAAAAIAAYagAAAAEA8E3NwJkZO+q35FTmUT0wMNB8IpBOSVACKQcccXpaWfZJMRmZzjPEzd4j/f9h+rEA==","AccessLevel":"Editor","CreatedOn":"2024-01-20T21:58:42Z"},{"Id":"iIRNLSeY0EanxRPyqGuwVg","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Email":"author@example.com","FirstName":"Author","LastName":"Dude","PreferredName":"Mister","PasswordHash":"AQAAAAIAAYagAAAAEBYNf1sR/pjaX2dZgqlvpH/Tqpz2h/CG3rsk/wH2ReTysjpK/gxSqht7IULWXM7KHQ==","Url":"https://example.com/author","AccessLevel":"Author","CreatedOn":"2024-01-20T21:53:27Z"}],"Theme":{"Id":"default","Name":"myWebLog Default Theme","Version":"2.1.0","Templates":[{"Name":"single-post","Text":"{%- assign post = model.posts | first -%}\n

      {{ post.title }}

      \n

      \n {% if post.published_on -%}\n Published {{ post.published_on | date: \"dddd, MMMM d, yyyy\" }}\n at {{ post.published_on | date: \"h:mm tt\" | downcase }}\n {%- else -%}\n **DRAFT**\n {% endif %}\n by {{ model.authors | value: post.author_id }}\n {%- if is_editor or is_author and user_id == post.author_id %}\n • Edit Post\n {%- endif %}\n

      \n
      \n
      \n
      {{ post.text }}
      \n {%- assign cat_count = post.category_ids | size -%}\n {% if cat_count > 0 -%}\n

      \n Categorized under\n {% for cat_id in post.category_ids -%}\n {% assign cat = categories | where: \"Id\", cat_id | first %}\n \n \n {{ cat.name }}\n \n \n {% unless forloop.last %} • {% endunless %}\n {%- endfor %}\n

      \n {%- endif %}\n {%- assign tag_count = post.tags | size -%}\n {% if tag_count > 0 -%}\n

      \n Tagged\n {% for tag in post.tags %}\n \n {{ tag }}\n \n {% unless forloop.last %} • {% endunless %}\n {%- endfor %}\n

      \n {%- endif %}\n
      \n
      \n \n
      \n
      \n"},{"Name":"single-page","Text":"

      {{ page.title }}

      \n
      {{ page.text }}
      \n"},{"Name":"layout","Text":"\n\n \n \n \n {{ page_title | strip_html }}{% if page_title %} « {% endif %}{{ web_log.name | strip_html }}\n {% page_head -%}\n
      \n \n
      \n
      \n {% if messages %}\n
      \n {% for msg in messages %}\n \n {% endfor %}\n
      \n {% endif %}\n {{ content }} \n
      \n
      \n
      \n
      \n myWebLog\n
      \n
      \n \n\n"},{"Name":"index","Text":"{%- if is_category or is_tag %}\n

      {{ page_title }}

      \n {%- if subtitle %}

      {{ subtitle }}

      {% endif -%}\n{% endif %}\n{%- assign post_count = model.posts | size -%}\n{%- if post_count > 0 %}\n
      \n {%- for post in model.posts %}\n
      \n

      \n \n {{ post.title }}\n \n

      \n

      \n Published on {{ post.published_on | date: \"MMMM d, yyyy\" }}\n at {{ post.published_on | date: \"h:mmtt\" | downcase }}\n by {{ model.authors | value: post.author_id }}\n {{ post.text }}\n {%- assign category_count = post.category_ids | size -%}\n {%- assign tag_count = post.tags | size -%}\n {% if category_count > 0 or tag_count > 0 %}\n

      \n

      \n {%- if category_count > 0 -%}\n Categorized under:\n {% for cat in post.category_ids -%}\n {%- assign this_cat = categories | where: \"Id\", cat | first -%}\n {{ this_cat.name }}{% unless forloop.last %}, {% endunless %}\n {%- assign cat_names = this_cat.name | concat: cat_names -%}\n {%- endfor -%}\n {%- assign cat_names = \"\" -%}\n
      \n {% endif -%}\n {%- if tag_count > 0 %}\n Tagged: {{ post.tags | join: \", \" }}\n {% endif -%}\n

      \n {% endif %}\n
      \n
      \n {% endfor %}\n
      \n \n{%- else %}\n

      No posts found

      \n{%- endif %}\n"}]},"Assets":[{"Id":"default/style.css","UpdatedOn":"2023-07-02T20:36:28Z","Data":"Lm1lc3NhZ2VzIHsKICBtYXgtd2lkdGg6IDYwcmVtOwogIG1hcmdpbjogYXV0bzsKfQpibG9ja3F1b3RlIHsKICBib3JkZXItbGVmdDogc29saWQgNHB4IGxpZ2h0Z3JheTsKICBwYWRkaW5nLWxlZnQ6IDFyZW07Cn0KLml0ZW0tbWV0YSB7CiAgZm9udC1zaXplOiAxLjFyZW07CiAgZm9udC13ZWlnaHQ6IG5vcm1hbDs7Cn0KLml0ZW0tbWV0YTo6YmVmb3JlIHsKICBjb250ZW50OiAiwrsiOwogIHZlcnRpY2FsLWFsaWduOiB0ZXh0LXRvcDsKfQphOmxpbmssIGE6dmlzaXRlZCB7CiAgdGV4dC1kZWNvcmF0aW9uOiBub25lOwp9CmE6aG92ZXIgewogIHRleHQtZGVjb3JhdGlvbjogdW5kZXJsaW5lOwp9Cg=="}],"Categories":[{"Id":"S5JflPsJ9EG7gA2LD4m92A","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Name":"Favorites","Slug":"favorites","Description":"Favorite posts"},{"Id":"jw6N69YtTEWVHAO33jHU-w","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Name":"Spitball","Slug":"spitball","Description":"Posts that may or may not work"},{"Id":"ScVpyu1e7UiP7bDdge3ZEw","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Name":"Moonshot","Slug":"moonshot","ParentId":"jw6N69YtTEWVHAO33jHU-w"}],"TagMappings":[{"Id":"Icm027noqE-rPHKZA98vAw","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Tag":"f#","UrlValue":"f-sharp"},{"Id":"GdryXh-S0kGsNBs2RIacGA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","Tag":"ghoti","UrlValue":"fish"}],"Pages":[{"Id":"hgc_BLEZ50SoAWLuPNISvA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Title":"Page Title","Permalink":"a-cool-page.html","PublishedOn":"2024-01-20T22:14:28Z","UpdatedOn":"2024-01-20T22:14:28Z","IsInPageList":false,"Text":"

      A Cool Page

      \n

      It really is cool!

      \n","Metadata":[{"Name":"Cool","Value":"true"},{"Name":"Warm","Value":"false"}],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:14:28Z","Text":"Markdown: # A Cool Page\n\nIt really is cool!"}]},{"Id":"KouRjvSmm0Wz6TMD8xf67A","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Title":"Yet Another Page","Permalink":"this-again.html","PublishedOn":"2024-01-20T22:15:08Z","UpdatedOn":"2024-01-20T22:15:08Z","IsInPageList":true,"Text":"

      Page 2

      \n\n

      It's a trip.","Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:15:08Z","Text":"HTML:

      Page 2

      \n\n

      It's a trip."}]}],"Posts":[{"Id":"RCsCU2puYEmkpzotoi8p4g","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Test Post 1","Permalink":"2024/test-post-1.html","PublishedOn":"2024-01-20T22:17:29Z","UpdatedOn":"2024-01-20T22:17:29Z","Text":"

      Introduction

      \n

      Visit my web site or my local page for more information.

      \n","CategoryIds":["ScVpyu1e7UiP7bDdge3ZEw"],"Tags":["f#","howdy","intro"],"Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:17:29Z","Text":"Markdown: ## Introduction\n\nVisit [my web site](https://example.com) or [my local page](/a-fine-page.html) for more information."}]},{"Id":"osxMfWGlAkyugUbJ1-xD1g","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Episode 1","Permalink":"2024/episode-1.html","PublishedOn":"2024-01-20T22:24:01Z","UpdatedOn":"2024-01-20T22:24:01Z","Text":"

      It's the launch of my new podcast - y'all come listen!","CategoryIds":["S5JflPsJ9EG7gA2LD4m92A"],"Tags":["general","podcast"],"Episode":{"Media":"episode-1.mp3","Length":124302,"Duration":"0:12:22","ImageUrl":"images/ep1-cover.png","Subtitle":"An introduction to this podcast","Explicit":"clean","ChapterFile":"uploads/chapters.json","TranscriptUrl":"uploads/transcript.srt","TranscriptType":"application/srt","TranscriptLang":"en","TranscriptCaptions":true,"SeasonNumber":1,"SeasonDescription":"The First Season","EpisodeNumber":1.0,"EpisodeDescription":"The first episode ever!"},"Metadata":[{"Name":"Density","Value":"Non-existent"},{"Name":"Intensity","Value":"Low"}],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:24:01Z","Text":"HTML:

      It's the launch of my new podcast - y'all come listen!"}]},{"Id":"l4_Eh4aFO06SqqJjOymNzA","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Episode 2","Permalink":"2024/episode-2.html","PublishedOn":"2024-01-20T22:31:32Z","UpdatedOn":"2024-01-20T22:31:32Z","Text":"

      m i n i m a l","CategoryIds":[],"Tags":["podcast"],"Episode":{"Media":"episode-2.mp3","Length":12873952,"Duration":"1:03:24","SeasonNumber":1,"SeasonDescription":"The First Season","EpisodeNumber":2.0,"EpisodeDescription":"A long update"},"Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:31:32Z","Text":"HTML:

      m i n i m a l"}]},{"Id":"QweKbWQiOkqqrjEdgP9wwg","WebLogId":"uSitJEuD3UyzWC9jgOHc8g","AuthorId":"5EM2rimH9kONpmd2zQkiVA","Status":"Published","Title":"Something May Happen","Permalink":"2024/something.html","PublishedOn":"2024-01-20T22:32:59Z","UpdatedOn":"2024-01-20T22:32:59Z","Text":"

      Hmm

      ","CategoryIds":["jw6N69YtTEWVHAO33jHU-w"],"Tags":["f#","ghoti","speculation"],"Metadata":[],"PriorPermalinks":[],"Revisions":[{"AsOf":"2024-01-20T22:32:59Z","Text":"HTML:

      Hmm

      "}]}],"Uploads":[]} \ No newline at end of file +{ + "WebLog": { + "Id": "uSitJEuD3UyzWC9jgOHc8g", + "Name": "Root WebLog", + "Slug": "root-weblog", + "Subtitle": "This is the main one", + "DefaultPage": "posts", + "PostsPerPage": 9, + "ThemeId": "default", + "UrlBase": "http://localhost:8081", + "TimeZone": "America/Denver", + "Rss": { + "IsFeedEnabled": true, + "FeedName": "feed", + "ItemsInFeed": 7, + "IsCategoryEnabled": true, + "IsTagEnabled": true, + "Copyright": "CC40-NC-BY", + "CustomFeeds": [ + { + "Id": "isPQ6drbDEydxohQzaiYtQ", + "Source": "tag:podcast", + "Path": "podcast-feed", + "Podcast": { + "Title": "Root Podcast", + "ItemsInFeed": 23, + "Summary": "All things that happen in the domain root", + "DisplayedAuthor": "Podcaster Extraordinaire", + "Email": "podcaster@example.com", + "ImageUrl": "images/cover-art.png", + "AppleCategory": "Fiction", + "AppleSubcategory": "Drama", + "Explicit": "no", + "DefaultMediaType": "audio/mpeg", + "MediaBaseUrl": "https://media.example.com/root/", + "PodcastGuid": "10fd7f79-c719-4e1d-9da7-10405dd4fd96", + "FundingUrl": "https://example.com/support-us", + "FundingText": "Support Our Work", + "Medium": "newsletter" + } + } + ] + }, + "AutoHtmx": true, + "Uploads": "Database", + "RedirectRules": [] + }, + "Users": [ + { + "Id": "5EM2rimH9kONpmd2zQkiVA", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Email": "root@example.com", + "FirstName": "Root", + "LastName": "Owner", + "PreferredName": "Admin", + "PasswordHash": "AQAAAAIAAYagAAAAEEnq9J9lKZoMQZaTOJHKIQo44skDdzDigzqS+o6myMop38YuHfm/vNs9b/WpYjsOxg==", + "AccessLevel": "Administrator", + "CreatedOn": "2024-01-20T21:49:03Z", + "LastSeenOn": "2024-01-20T22:25:03Z" + }, + { + "Id": "GPbJaSOwTkKt14ZKYyveKA", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Email": "editor@example.com", + "FirstName": "Ed", + "LastName": "It-Or", + "PreferredName": "Edits", + "PasswordHash": "AQAAAAIAAYagAAAAEA8E3NwJkZO+q35FTmUT0wMNB8IpBOSVACKQcccXpaWfZJMRmZzjPEzd4j/f9h+rEA==", + "AccessLevel": "Editor", + "CreatedOn": "2024-01-20T21:58:42Z" + }, + { + "Id": "iIRNLSeY0EanxRPyqGuwVg", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Email": "author@example.com", + "FirstName": "Author", + "LastName": "Dude", + "PreferredName": "Mister", + "PasswordHash": "AQAAAAIAAYagAAAAEBYNf1sR/pjaX2dZgqlvpH/Tqpz2h/CG3rsk/wH2ReTysjpK/gxSqht7IULWXM7KHQ==", + "Url": "https://example.com/author", + "AccessLevel": "Author", + "CreatedOn": "2024-01-20T21:53:27Z" + } + ], + "Theme": { + "Id": "default", + "Name": "myWebLog Default Theme", + "Version": "2.1.0", + "Templates": [ + { + "Name": "single-post", + "Text": "{%- assign post = model.posts | first -%}\n

      {{ post.title }}

      \n

      \n {% if post.published_on -%}\n Published {{ post.published_on | date: \"dddd, MMMM d, yyyy\" }}\n at {{ post.published_on | date: \"h:mm tt\" | downcase }}\n {%- else -%}\n **DRAFT**\n {% endif %}\n by {{ model.authors | value: post.author_id }}\n {%- if is_editor or is_author and user_id == post.author_id %}\n • Edit Post\n {%- endif %}\n

      \n
      \n
      \n
      {{ post.text }}
      \n {%- assign cat_count = post.category_ids | size -%}\n {% if cat_count > 0 -%}\n

      \n Categorized under\n {% for cat_id in post.category_ids -%}\n {% assign cat = categories | where: \"Id\", cat_id | first %}\n \n \n {{ cat.name }}\n \n \n {% unless forloop.last %} • {% endunless %}\n {%- endfor %}\n

      \n {%- endif %}\n {%- assign tag_count = post.tags | size -%}\n {% if tag_count > 0 -%}\n

      \n Tagged\n {% for tag in post.tags %}\n \n {{ tag }}\n \n {% unless forloop.last %} • {% endunless %}\n {%- endfor %}\n

      \n {%- endif %}\n
      \n
      \n \n
      \n
      \n" + }, + { + "Name": "single-page", + "Text": "

      {{ page.title }}

      \n
      {{ page.text }}
      \n" + }, + { + "Name": "layout", + "Text": "\n\n \n \n \n {{ page_title | strip_html }}{% if page_title %} « {% endif %}{{ web_log.name | strip_html }}\n {% page_head -%}\n
      \n \n
      \n
      \n {% if messages %}\n
      \n {% for msg in messages %}\n \n {% endfor %}\n
      \n {% endif %}\n {{ content }} \n
      \n
      \n
      \n
      \n myWebLog\n
      \n
      \n \n\n" + }, + { + "Name": "index", + "Text": "{%- if is_category or is_tag %}\n

      {{ page_title }}

      \n {%- if subtitle %}

      {{ subtitle }}

      {% endif -%}\n{% endif %}\n{%- assign post_count = model.posts | size -%}\n{%- if post_count > 0 %}\n
      \n {%- for post in model.posts %}\n
      \n

      \n \n {{ post.title }}\n \n

      \n

      \n Published on {{ post.published_on | date: \"MMMM d, yyyy\" }}\n at {{ post.published_on | date: \"h:mmtt\" | downcase }}\n by {{ model.authors | value: post.author_id }}\n {{ post.text }}\n {%- assign category_count = post.category_ids | size -%}\n {%- assign tag_count = post.tags | size -%}\n {% if category_count > 0 or tag_count > 0 %}\n

      \n

      \n {%- if category_count > 0 -%}\n Categorized under:\n {% for cat in post.category_ids -%}\n {%- assign this_cat = categories | where: \"Id\", cat | first -%}\n {{ this_cat.name }}{% unless forloop.last %}, {% endunless %}\n {%- assign cat_names = this_cat.name | concat: cat_names -%}\n {%- endfor -%}\n {%- assign cat_names = \"\" -%}\n
      \n {% endif -%}\n {%- if tag_count > 0 %}\n Tagged: {{ post.tags | join: \", \" }}\n {% endif -%}\n

      \n {% endif %}\n
      \n
      \n {% endfor %}\n
      \n \n{%- else %}\n

      No posts found

      \n{%- endif %}\n" + } + ] + }, + "Assets": [ + { + "Id": "default/style.css", + "UpdatedOn": "2023-07-02T20:36:28Z", + "Data": "Lm1lc3NhZ2VzIHsKICBtYXgtd2lkdGg6IDYwcmVtOwogIG1hcmdpbjogYXV0bzsKfQpibG9ja3F1b3RlIHsKICBib3JkZXItbGVmdDogc29saWQgNHB4IGxpZ2h0Z3JheTsKICBwYWRkaW5nLWxlZnQ6IDFyZW07Cn0KLml0ZW0tbWV0YSB7CiAgZm9udC1zaXplOiAxLjFyZW07CiAgZm9udC13ZWlnaHQ6IG5vcm1hbDs7Cn0KLml0ZW0tbWV0YTo6YmVmb3JlIHsKICBjb250ZW50OiAiwrsiOwogIHZlcnRpY2FsLWFsaWduOiB0ZXh0LXRvcDsKfQphOmxpbmssIGE6dmlzaXRlZCB7CiAgdGV4dC1kZWNvcmF0aW9uOiBub25lOwp9CmE6aG92ZXIgewogIHRleHQtZGVjb3JhdGlvbjogdW5kZXJsaW5lOwp9Cg==" + } + ], + "Categories": [ + { + "Id": "S5JflPsJ9EG7gA2LD4m92A", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Name": "Favorites", + "Slug": "favorites", + "Description": "Favorite posts" + }, + { + "Id": "jw6N69YtTEWVHAO33jHU-w", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Name": "Spitball", + "Slug": "spitball", + "Description": "Posts that may or may not work" + }, + { + "Id": "ScVpyu1e7UiP7bDdge3ZEw", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Name": "Moonshot", + "Slug": "moonshot", + "ParentId": "jw6N69YtTEWVHAO33jHU-w" + } + ], + "TagMappings": [ + { + "Id": "Icm027noqE-rPHKZA98vAw", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Tag": "f#", + "UrlValue": "f-sharp" + }, + { + "Id": "GdryXh-S0kGsNBs2RIacGA", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Tag": "ghoti", + "UrlValue": "fish" + } + ], + "Pages": [ + { + "Id": "hgc_BLEZ50SoAWLuPNISvA", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "Title": "Page Title", + "Permalink": "a-cool-page.html", + "PublishedOn": "2024-01-20T22:14:28Z", + "UpdatedOn": "2024-01-20T22:14:28Z", + "IsInPageList": false, + "Text": "

      A Cool Page

      \n

      It really is cool!

      \n", + "Metadata": [ + { + "Name": "Cool", + "Value": "true" + }, + { + "Name": "Warm", + "Value": "false" + } + ], + "PriorPermalinks": [ + "a-cool-pg.html" + ], + "Revisions": [ + { + "AsOf": "2024-01-20T22:14:28Z", + "Text": "Markdown: # A Cool Page\n\nIt really is cool!" + } + ] + }, + { + "Id": "KouRjvSmm0Wz6TMD8xf67A", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "Title": "Yet Another Page", + "Permalink": "this-again.html", + "PublishedOn": "2024-01-20T22:15:08Z", + "UpdatedOn": "2024-01-20T22:15:08Z", + "IsInPageList": true, + "Text": "

      Page 2

      \n\n

      It's a trip.", + "Metadata": [], + "PriorPermalinks": [], + "Revisions": [ + { + "AsOf": "2024-01-20T22:15:08Z", + "Text": "HTML:

      Page 2

      \n\n

      It's a trip." + } + ] + } + ], + "Posts": [ + { + "Id": "RCsCU2puYEmkpzotoi8p4g", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "Status": "Published", + "Title": "Test Post 1", + "Permalink": "2024/test-post-1.html", + "PublishedOn": "2024-01-20T22:17:29Z", + "UpdatedOn": "2024-01-20T22:17:29Z", + "Text": "

      Introduction

      \n

      Visit my web site or my local page for more information.

      \n", + "CategoryIds": [ + "ScVpyu1e7UiP7bDdge3ZEw" + ], + "Tags": [ + "f#", + "howdy", + "intro" + ], + "Metadata": [], + "PriorPermalinks": [], + "Revisions": [ + { + "AsOf": "2024-01-20T22:17:29Z", + "Text": "Markdown: ## Introduction\n\nVisit [my web site](https://example.com) or [my local page](/a-fine-page.html) for more information." + } + ] + }, + { + "Id": "osxMfWGlAkyugUbJ1-xD1g", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "Status": "Published", + "Title": "Episode 1", + "Permalink": "2024/episode-1.html", + "PublishedOn": "2024-01-20T22:24:01Z", + "UpdatedOn": "2024-01-20T22:24:01Z", + "Text": "

      It's the launch of my new podcast - y'all come listen!", + "CategoryIds": [ + "S5JflPsJ9EG7gA2LD4m92A" + ], + "Tags": [ + "general", + "podcast" + ], + "Episode": { + "Media": "episode-1.mp3", + "Length": 124302, + "Duration": "0:12:22", + "ImageUrl": "images/ep1-cover.png", + "Subtitle": "An introduction to this podcast", + "Explicit": "clean", + "ChapterFile": "uploads/chapters.json", + "TranscriptUrl": "uploads/transcript.srt", + "TranscriptType": "application/srt", + "TranscriptLang": "en", + "TranscriptCaptions": true, + "SeasonNumber": 1, + "SeasonDescription": "The First Season", + "EpisodeNumber": 1.0, + "EpisodeDescription": "The first episode ever!" + }, + "Metadata": [ + { + "Name": "Density", + "Value": "Non-existent" + }, + { + "Name": "Intensity", + "Value": "Low" + } + ], + "PriorPermalinks": [], + "Revisions": [ + { + "AsOf": "2024-01-20T22:24:01Z", + "Text": "HTML:

      It's the launch of my new podcast - y'all come listen!" + } + ] + }, + { + "Id": "l4_Eh4aFO06SqqJjOymNzA", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "Status": "Published", + "Title": "Episode 2", + "Permalink": "2024/episode-2.html", + "PublishedOn": "2024-01-20T22:31:32Z", + "UpdatedOn": "2024-01-20T22:31:32Z", + "Text": "

      m i n i m a l", + "CategoryIds": [], + "Tags": [ + "podcast" + ], + "Episode": { + "Media": "episode-2.mp3", + "Length": 12873952, + "Duration": "1:03:24", + "SeasonNumber": 1, + "SeasonDescription": "The First Season", + "EpisodeNumber": 2.0, + "EpisodeDescription": "A long update" + }, + "Metadata": [], + "PriorPermalinks": [], + "Revisions": [ + { + "AsOf": "2024-01-20T22:31:32Z", + "Text": "HTML:

      m i n i m a l" + } + ] + }, + { + "Id": "QweKbWQiOkqqrjEdgP9wwg", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "Status": "Published", + "Title": "Something May Happen", + "Permalink": "2024/something.html", + "PublishedOn": "2024-01-20T22:32:59Z", + "UpdatedOn": "2024-01-20T22:32:59Z", + "Text": "

      Hmm

      ", + "CategoryIds": [ + "jw6N69YtTEWVHAO33jHU-w" + ], + "Tags": [ + "f#", + "ghoti", + "speculation" + ], + "Metadata": [], + "PriorPermalinks": [], + "Revisions": [ + { + "AsOf": "2024-01-20T22:32:59Z", + "Text": "HTML:

      Hmm

      " + } + ] + } + ], + "Uploads": [] +} \ No newline at end of file -- 2.45.1 From c319ff15fdb0ce8d8c8b1fee55a280abd04cc109 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 28 Jan 2024 17:50:05 -0500 Subject: [PATCH 067/123] Add tests for pages via permalinks --- src/MyWebLog.Data/RethinkDbData.fs | 2 +- src/MyWebLog.Tests/Data/PageDataTests.fs | 34 ++++++++++++++++++-- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 19 +++++++++++ src/MyWebLog.Tests/Data/RethinkDbTests.fs | 19 +++++++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 29 +++++++++++++++++ 5 files changed, 99 insertions(+), 4 deletions(-) diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 70fbb6f..d1516c1 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -127,7 +127,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger 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) diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index d8513ee..ac78240 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -85,9 +85,8 @@ let ``FindById succeeds when a page is found`` (data: IData) = task { 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 (Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z")) "Published On is incorrect" - Expect.equal pg.UpdatedOn (Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z")) "Updated On 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 "

      A Cool Page

      \n

      It really is cool!

      \n" "Text is incorrect" Expect.hasLength pg.Metadata 2 "There should be 2 metadata items on this page" @@ -109,6 +108,35 @@ let ``FindById succeeds when a page is not found (bad page ID)`` (data: IData) = 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" +} + +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" diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 8a87552..901df88 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -142,6 +142,25 @@ let pageTests = testList "Page" [ 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 ()) diff --git a/src/MyWebLog.Tests/Data/RethinkDbTests.fs b/src/MyWebLog.Tests/Data/RethinkDbTests.fs index f6d3863..c24a2d5 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbTests.fs @@ -141,6 +141,25 @@ let pageTests = testList "Page" [ 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 diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index b2c724c..a6a212a 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -181,6 +181,35 @@ let pageTests = testList "Page" [ finally dispose data } ] + testList "FindByPermalink" [ + testTask "succeeds when a page is found" { + let data = mkData () + try do! PageDataTests.``FindByPermalink succeeds when a page is found`` data + finally dispose data + } + testTask "succeeds when a page is not found (incorrect weblog)" { + let data = mkData () + try do! PageDataTests.``FindByPermalink succeeds when a page is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a page is not found (no such permalink)" { + let data = mkData () + try do! PageDataTests.``FindByPermalink succeeds when a page is not found (no such permalink)`` data + finally dispose data + } + ] + testList "FindCurrentPermalink" [ + testTask "succeeds when a page is found" { + let data = mkData () + try do! PageDataTests.``FindCurrentPermalink succeeds when a page is found`` data + finally dispose data + } + testTask "succeeds when a page is not found" { + let data = mkData () + try do! PageDataTests.``FindCurrentPermalink succeeds when a page is not found`` data + finally dispose data + } + ] testList "FindFullById" [ testTask "succeeds when a page is found" { let data = mkData () -- 2.45.1 From f60139db1c513d7de11031f837214c2621678654 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 28 Jan 2024 22:50:28 -0500 Subject: [PATCH 068/123] Add more page tests --- src/MyWebLog.Data/Interfaces.fs | 12 +++---- src/MyWebLog.Data/RethinkDbData.fs | 4 ++- src/MyWebLog.Tests/Data/PageDataTests.fs | 34 +++++++++++++++++++- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 16 +++++++++ src/MyWebLog.Tests/Data/RethinkDbTests.fs | 16 +++++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 24 ++++++++++++++ 6 files changed, 98 insertions(+), 8 deletions(-) diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index 1f6a839..4c4c4c7 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -85,7 +85,7 @@ type IPageData = abstract member FindListed : WebLogId -> Task /// Find a page of pages (displayed in admin section) (excluding meta items, revisions and prior permalinks) - abstract member FindPageOfPages : WebLogId -> pageNbr : int -> Task + abstract member FindPageOfPages : WebLogId -> pageNbr: int -> Task /// Restore pages from a backup abstract member Restore : Page list -> Task @@ -126,20 +126,20 @@ type IPostData = /// Find posts to be displayed on a category list page (excluding revisions and prior permalinks) abstract member FindPageOfCategorizedPosts : - WebLogId -> CategoryId list -> pageNbr : int -> postsPerPage : int -> Task + WebLogId -> CategoryId list -> pageNbr: int -> postsPerPage: int -> Task /// Find posts to be displayed on an admin page (excluding revisions and prior permalinks) - abstract member FindPageOfPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task + abstract member FindPageOfPosts : WebLogId -> pageNbr: int -> postsPerPage: int -> Task /// Find posts to be displayed on a page (excluding revisions and prior permalinks) - abstract member FindPageOfPublishedPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task + abstract member FindPageOfPublishedPosts : WebLogId -> pageNbr: int -> postsPerPage: int -> Task /// Find posts to be displayed on a tag list page (excluding revisions and prior permalinks) abstract member FindPageOfTaggedPosts : - WebLogId -> tag : string -> pageNbr : int -> postsPerPage : int -> Task + WebLogId -> tag : string -> pageNbr: int -> postsPerPage: int -> Task /// Find the next older and newer post for the given published date/time (excluding revisions and prior permalinks) - abstract member FindSurroundingPosts : WebLogId -> publishedOn : Instant -> Task + abstract member FindSurroundingPosts : WebLogId -> publishedOn: Instant -> Task /// Restore posts from a backup abstract member Restore : Post list -> Task diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index d1516c1..de75824 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -502,7 +502,9 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger obj ] - without [ nameof Page.Empty.Text; nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] + 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 } diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index ac78240..06a054f 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -15,6 +15,9 @@ let coolPageId = PageId "hgc_BLEZ50SoAWLuPNISvA" /// The published and updated time of the "A cool page" page let coolPagePublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z") +/// The ID of the "Yet Another Page" page +let otherPageId = PageId "KouRjvSmm0Wz6TMD8xf67A" + let ``Add succeeds`` (data: IData) = task { let page = { Id = PageId "added-page" @@ -136,7 +139,6 @@ let ``FindCurrentPermalink succeeds when a page is not found`` (data: IData) = t 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" @@ -154,3 +156,33 @@ 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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 901df88..93e008f 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -169,6 +169,22 @@ let pageTests = testList "Page" [ 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 ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbTests.fs b/src/MyWebLog.Tests/Data/RethinkDbTests.fs index c24a2d5..5f5d4d8 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbTests.fs @@ -168,6 +168,22 @@ let pageTests = testList "Page" [ 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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index a6a212a..4db7194 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -222,6 +222,30 @@ let pageTests = testList "Page" [ finally dispose data } ] + testList "FindFullByWebLog" [ + testTask "succeeds when pages are found" { + let data = mkData () + try do! PageDataTests.``FindFullByWebLog succeeds when pages are found`` data + finally dispose data + } + testTask "succeeds when a pages are not found" { + let data = mkData () + try do! PageDataTests.``FindFullByWebLog succeeds when pages are not found`` data + finally dispose data + } + ] + testList "FindListed" [ + testTask "succeeds when pages are found" { + let data = mkData () + try do! PageDataTests.``FindListed succeeds when pages are found`` data + finally dispose data + } + testTask "succeeds when a pages are not found" { + let data = mkData () + try do! PageDataTests.``FindListed succeeds when pages are not found`` data + finally dispose data + } + ] ] /// Delete the SQLite database -- 2.45.1 From 0a53e27f2222040a878082645e87ff168f58fb59 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 29 Jan 2024 08:52:37 -0500 Subject: [PATCH 069/123] Add page-of-page and update tests --- .../Postgres/PostgresPageData.fs | 28 ++++++--- src/MyWebLog.Data/RethinkDbData.fs | 6 +- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 25 +++++--- src/MyWebLog.Tests/Data/PageDataTests.fs | 57 +++++++++++++++++++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 16 ++++++ src/MyWebLog.Tests/Data/RethinkDbTests.fs | 16 ++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 12 ++++ 7 files changed, 140 insertions(+), 20 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index d8350bd..824fba6 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -35,6 +35,14 @@ type PostgresPageData(log: ILogger) = // 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" @@ -134,7 +142,7 @@ type PostgresPageData(log: ILogger) = ORDER BY LOWER(data->>'{nameof Page.Empty.Title}') LIMIT @pageSize OFFSET @toSkip" [ webLogContains webLogId; "@pageSize", Sql.int 26; "@toSkip", Sql.int ((pageNbr - 1) * 25) ] - fromData + (fun row -> { fromData row with Metadata = []; PriorPermalinks = [] }) /// Restore pages from a backup let restore (pages: Page list) = backgroundTask { @@ -151,12 +159,14 @@ type PostgresPageData(log: ILogger) = () } - /// Save a page - let save (page: Page) = backgroundTask { - log.LogTrace "Page.save" - let! oldPage = findFullById page.Id page.WebLogId - do! save Table.Page { page with Revisions = [] } - do! updatePageRevisions page.Id (match oldPage with Some p -> p.Revisions | None -> []) page.Revisions + /// 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 -> () () } @@ -171,7 +181,7 @@ type PostgresPageData(log: ILogger) = } interface IPageData with - member _.Add page = save page + member _.Add page = add page member _.All webLogId = all webLogId member _.CountAll webLogId = countAll webLogId member _.CountListed webLogId = countListed webLogId @@ -184,5 +194,5 @@ type PostgresPageData(log: ILogger) = member _.FindListed webLogId = findListed webLogId member _.FindPageOfPages webLogId pageNbr = findPageOfPages webLogId pageNbr member _.Restore pages = restore pages - member _.Update page = save page + member _.Update page = update page member _.UpdatePriorPermalinks pageId webLogId permalinks = updatePriorPermalinks pageId webLogId permalinks diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index de75824..0748df5 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -512,9 +512,9 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger { withTable Table.Page getAll [ webLogId ] (nameof Page.Empty.WebLogId) - without [ nameof Page.Empty.Metadata - nameof Page.Empty.PriorPermalinks - nameof Page.Empty.Revisions ] + 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 diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index 1d11140..38f2f32 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -36,6 +36,13 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = // IMPLEMENTATION FUNCTIONS + /// Add a page + 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, metadata, revisions, or prior permalinks) let all webLogId = log.LogTrace "Page.all" @@ -133,18 +140,20 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = [ webLogParam webLogId; SqliteParameter("@pageSize", 26); SqliteParameter("@toSkip", (pageNbr - 1) * 25) ] fromData - /// Save a page - let save (page: Page) = backgroundTask { + /// Update a page + let update (page: Page) = backgroundTask { log.LogTrace "Page.update" - let! oldPage = findFullById page.Id page.WebLogId - do! conn.save Table.Page { page with Revisions = [] } - do! updatePageRevisions page.Id (match oldPage with Some p -> p.Revisions | None -> []) page.Revisions + 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 { log.LogTrace "Page.restore" - for page in pages do do! save page + for page in pages do do! add page } /// Update a page's prior permalinks @@ -158,7 +167,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = } interface IPageData with - member _.Add page = save page + member _.Add page = add page member _.All webLogId = all webLogId member _.CountAll webLogId = countAll webLogId member _.CountListed webLogId = countListed webLogId @@ -171,5 +180,5 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = member _.FindListed webLogId = findListed webLogId member _.FindPageOfPages webLogId pageNbr = findPageOfPages webLogId pageNbr member _.Restore pages = restore pages - member _.Update page = save page + member _.Update page = update page member _.UpdatePriorPermalinks pageId webLogId permalinks = updatePriorPermalinks pageId webLogId permalinks diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index 06a054f..e3a6b75 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -186,3 +186,60 @@ 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 = "

      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 "

      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 "

      I have been updated" "Text is incorrect" + Expect.hasLength pg.Metadata 1 "There should be 1 metadata item on this page" + Expect.equal pg.Metadata[0].Name "Cool" "Meta item 0 name is incorrect" + Expect.equal pg.Metadata[0].Value "true" "Meta item 0 value is incorrect" + Expect.equal pg.PriorPermalinks [ Permalink "a-cool-page.html" ] "Prior permalinks are incorrect" + Expect.hasLength pg.Revisions 2 "There should be 2 revisions" + Expect.equal pg.Revisions[0].AsOf (coolPagePublished + Duration.FromHours 5) "As Of for revision 0 incorrect" + Expect.equal pg.Revisions[0].Text (Html "

      I have been updated") "Text for revision 0 is incorrect" + Expect.equal pg.Revisions[1].AsOf coolPagePublished "As Of for revision 1 is 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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 93e008f..4e6fc0a 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -185,6 +185,22 @@ let pageTests = testList "Page" [ 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 ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbTests.fs b/src/MyWebLog.Tests/Data/RethinkDbTests.fs index 5f5d4d8..63227da 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbTests.fs @@ -184,6 +184,22 @@ let pageTests = testList "Page" [ 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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 4db7194..ead17f5 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -246,6 +246,18 @@ let pageTests = testList "Page" [ finally dispose data } ] + testList "Update" [ + testTask "succeeds when the page exists" { + let data = mkData () + try do! PageDataTests.``Update succeeds when the page exists`` data + finally dispose data + } + testTask "succeeds when the page does not exist" { + let data = mkData () + try do! PageDataTests.``Update succeeds when the page does not exist`` data + finally dispose data + } + ] ] /// Delete the SQLite database -- 2.45.1 From 990b72b1ecae71bc8eb605f65e126e011aba3b37 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 29 Jan 2024 21:20:35 -0500 Subject: [PATCH 070/123] Finish page data tests --- src/MyWebLog.Tests/Data/PageDataTests.fs | 26 ++++++++++++++++++++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 16 ++++++++++++ src/MyWebLog.Tests/Data/RethinkDbTests.fs | 16 ++++++++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 24 ++++++++++++++++++ 4 files changed, 82 insertions(+) diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index e3a6b75..45fda8a 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -243,3 +243,29 @@ let ``Update succeeds when the page does not exist`` (data: IData) = task { 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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 4e6fc0a..2d0b4ba 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -201,6 +201,22 @@ let pageTests = testList "Page" [ 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 ()) + } + testTask "succeeds when a page is not deleted" { + do! PageDataTests.``Delete succeeds when a page is not deleted`` (mkData ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbTests.fs b/src/MyWebLog.Tests/Data/RethinkDbTests.fs index 63227da..5304c12 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbTests.fs @@ -200,6 +200,22 @@ let pageTests = testList "Page" [ 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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index ead17f5..1be47af 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -258,6 +258,30 @@ let pageTests = testList "Page" [ finally dispose data } ] + testList "UpdatePriorPermalinks" [ + testTask "succeeds when the page exists" { + let data = mkData () + try do! PageDataTests.``UpdatePriorPermalinks succeeds when the page exists`` data + finally dispose data + } + testTask "succeeds when the page does not exist" { + let data = mkData () + try do! PageDataTests.``UpdatePriorPermalinks succeeds when the page does not exist`` data + finally dispose data + } + ] + testList "Delete" [ + testTask "succeeds when a page is deleted" { + let data = mkData () + try do! PageDataTests.``Delete succeeds when a page is deleted`` data + finally dispose data + } + testTask "succeeds when a page is not deleted" { + let data = mkData () + try do! PageDataTests.``Delete succeeds when a page is not deleted`` data + finally dispose data + } + ] ] /// Delete the SQLite database -- 2.45.1 From 78c1c5e68e13f07a12a5fe9170b99fb7c3f4dc04 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 30 Jan 2024 19:14:59 -0500 Subject: [PATCH 071/123] Add framework for post tests - SQLite is failing on fresh environment - Remove no equality/no comparison on meta/revision - Rename RethinkDB test file --- src/MyWebLog.Domain/SupportTypes.fs | 4 +- src/MyWebLog.Tests/Data/CategoryDataTests.fs | 3 ++ src/MyWebLog.Tests/Data/PageDataTests.fs | 3 ++ src/MyWebLog.Tests/Data/PostDataTests.fs | 52 +++++++++++++++++++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 18 +++++-- ...ethinkDbTests.fs => RethinkDbDataTests.fs} | 12 ++++- src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 19 ++++++- src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 3 +- src/MyWebLog.Tests/Program.fs | 2 +- 9 files changed, 105 insertions(+), 11 deletions(-) create mode 100644 src/MyWebLog.Tests/Data/PostDataTests.fs rename src/MyWebLog.Tests/Data/{RethinkDbTests.fs => RethinkDbDataTests.fs} (96%) diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 53df258..b4ecde4 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -314,7 +314,7 @@ type MarkupText = /// An item of metadata -[] +[] type MetaItem = { /// The name of the metadata value Name: string @@ -329,7 +329,7 @@ type MetaItem = { /// A revision of a page or post -[] +[] type Revision = { /// When this revision was saved AsOf: Instant diff --git a/src/MyWebLog.Tests/Data/CategoryDataTests.fs b/src/MyWebLog.Tests/Data/CategoryDataTests.fs index 9368545..b1233cd 100644 --- a/src/MyWebLog.Tests/Data/CategoryDataTests.fs +++ b/src/MyWebLog.Tests/Data/CategoryDataTests.fs @@ -1,3 +1,6 @@ +///

      +/// Integration tests for implementations +/// module CategoryDataTests open Expecto diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index 45fda8a..03159b8 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -1,3 +1,6 @@ +/// +/// Integration tests for implementations +/// module PageDataTests open System diff --git a/src/MyWebLog.Tests/Data/PostDataTests.fs b/src/MyWebLog.Tests/Data/PostDataTests.fs new file mode 100644 index 0000000..45f2063 --- /dev/null +++ b/src/MyWebLog.Tests/Data/PostDataTests.fs @@ -0,0 +1,52 @@ +/// +/// Integration tests for implementations +/// +module PostDataTests + +open Expecto +open MyWebLog +open MyWebLog.Data +open NodaTime + +/// The ID of the root web log +let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" + +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 = "

      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 "

      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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 2d0b4ba..7b4dc1c 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -23,19 +23,19 @@ let mkData () = /// The host for the PostgreSQL test database (defaults to localhost) let testHost = - RethinkDbTests.env "PG_HOST" "localhost" + RethinkDbDataTests.env "PG_HOST" "localhost" /// The database name for the PostgreSQL test database (defaults to postgres) let testDb = - RethinkDbTests.env "PG_DB" "postgres" + RethinkDbDataTests.env "PG_DB" "postgres" /// The user ID for the PostgreSQL test database (defaults to postgres) let testUser = - RethinkDbTests.env "PG_USER" "postgres" + RethinkDbDataTests.env "PG_USER" "postgres" /// The password for the PostgreSQL test database (defaults to postgres) let testPw = - RethinkDbTests.env "PG_PW" "postgres" + RethinkDbDataTests.env "PG_PW" "postgres" /// Create a fresh environment from the root backup let freshEnvironment () = task { @@ -219,6 +219,15 @@ let pageTests = testList "Page" [ ] ] +/// Integration tests for the Post implementation in PostgreSQL +let postTests = testList "Post" [ + testTask "Add succeeds" { + // We'll need the root website categories restored for these tests + do! freshEnvironment () + do! PostDataTests.``Add succeeds`` (mkData ()) + } +] + /// Drop the throwaway PostgreSQL database let environmentCleanUp = test "Clean Up" { if db.IsSome then db.Value.Dispose() @@ -230,5 +239,6 @@ let all = [ environmentSetUp categoryTests pageTests + postTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/RethinkDbTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs similarity index 96% rename from src/MyWebLog.Tests/Data/RethinkDbTests.fs rename to src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index 5304c12..6ac7d6e 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -1,4 +1,4 @@ -module RethinkDbTests +module RethinkDbDataTests open System open Expecto @@ -218,6 +218,15 @@ let pageTests = testList "Page" [ ] ] +/// Integration tests for the Post implementation in RethinkDB +let 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 + } +] + /// Drop the throwaway RethinkDB database let environmentCleanUp = testTask "Clean Up" { do! disposeData () @@ -229,5 +238,6 @@ let all = [ environmentSetUp categoryTests pageTests + postTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 1be47af..06dc659 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -14,7 +14,7 @@ let ser = Json.configure (JsonSerializer.CreateDefault()) /// The test database name let dbName = - RethinkDbTests.env "SQLITE_DB" "test-db.db" + RethinkDbDataTests.env "SQLITE_DB" "test-db.db" /// Create a SQLiteData instance for testing let mkData () = @@ -30,13 +30,17 @@ let dispose (data: IData) = let freshEnvironment (data: IData option) = task { let env = match data with - | Some d -> d + | Some d -> + System.Console.WriteLine "Existing data" + d | None -> + System.Console.WriteLine $"No data; deleting {dbName}" File.Delete dbName 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 + return env } /// Set up the environment for the SQLite tests @@ -284,6 +288,16 @@ let pageTests = testList "Page" [ ] ] +/// Integration tests for the Post implementation in SQLite +let postTests = testList "Post" [ + testTask "Add succeeds" { + // We'll need the root website categories restored for these tests + let! data = freshEnvironment None + try do! PostDataTests.``Add succeeds`` data + finally dispose data + } +] + /// Delete the SQLite database let environmentCleanUp = test "Clean Up" { File.Delete dbName @@ -296,5 +310,6 @@ let all = [ environmentSetUp categoryTests pageTests + postTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 1ef9297..e6c8dab 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -12,7 +12,8 @@ - + + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index 43077ee..f5fc99b 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -5,7 +5,7 @@ let allTests = testList "MyWebLog" [ testList "Data" [ ConvertersTests.all UtilsTests.all - RethinkDbTests.all + RethinkDbDataTests.all SQLiteDataTests.all PostgresDataTests.all ] -- 2.45.1 From 24d49e26e52e047c075fd93ccb271d6eec8b0d18 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 30 Jan 2024 22:45:33 -0500 Subject: [PATCH 072/123] Add tests through post curr permalink - Resolve SQLite / RethinkDB env refresh hiccups --- .../Postgres/PostgresPageData.fs | 9 +- .../Postgres/PostgresPostData.fs | 11 ++- src/MyWebLog.Data/RethinkDbData.fs | 26 ++++-- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 2 +- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 11 ++- src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 2 +- src/MyWebLog.Tests/Data/PageDataTests.fs | 43 ++++----- src/MyWebLog.Tests/Data/PostDataTests.fs | 93 +++++++++++++++++++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 33 +++++++ src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 33 +++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 88 ++++++++++++++++-- src/MyWebLog.Tests/root-weblog.json | 4 +- 12 files changed, 298 insertions(+), 57 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs index 824fba6..3c6e023 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -94,10 +94,13 @@ type PostgresPageData(log: ILogger) = } /// Find a page by its permalink for the given web log - let findByPermalink (permalink: Permalink) webLogId = + let findByPermalink (permalink: Permalink) webLogId = backgroundTask { log.LogTrace "Page.findByPermalink" - Find.byContains Table.Page {| webLogDoc webLogId with Permalink = permalink |} - |> tryHead + let! page = + Find.byContains 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 { diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index 6f858af..c41ccee 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -42,9 +42,12 @@ type PostgresPostData(log: ILogger) = 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 = + let findById postId webLogId = backgroundTask { log.LogTrace "Post.findById" - Document.findByIdAndWebLog Table.Post postId webLogId + match! Document.findByIdAndWebLog 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 = @@ -52,12 +55,12 @@ type PostgresPostData(log: ILogger) = Custom.single (selectWithCriteria Table.Post) [ jsonParam "@criteria" {| webLogDoc webLogId with Permalink = permalink |} ] - fromData + (fun row -> { fromData row with PriorPermalinks = [] }) /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { log.LogTrace "Post.findFullById" - match! findById postId webLogId with + match! Document.findByIdAndWebLog Table.Post postId webLogId with | Some post -> let! withRevisions = appendPostRevisions post return Some withRevisions diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 0748df5..5a86813 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -178,6 +178,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger obj) write; withRetryOnce; ignoreResult conn } + do! rethink { withTable table; indexWait; result; withRetryDefault; ignoreResult conn } } /// The batch size for restoration methods @@ -589,20 +590,27 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger 0UL } - member _.FindById postId webLogId = - rethink { - withTable Table.Post - get postId - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] - resultOption; withRetryOptionDefault - } - |> verifyWebLog webLogId _.WebLogId <| conn + member _.FindById postId webLogId = backgroundTask { + let! post = + rethink { + withTable Table.Post + getAll [ postId ] + without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + result; withRetryDefault + } + |> tryFirst <| conn + return + post + |> Option.filter (fun p -> p.WebLogId = webLogId) + |> Option.map (fun p -> { p with Revisions = []; PriorPermalinks = [] }) + } member _.FindByPermalink permalink webLogId = rethink { withTable Table.Post getAll [ [| webLogId :> obj; permalink |] ] (nameof Post.Empty.Permalink) - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||]) + .With(nameof Post.Empty.Revisions, [||])) limit 1 result; withRetryDefault } diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index 38f2f32..e2561fc 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -102,7 +102,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = conn.customSingle $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkParam "@link"}""" (addFieldParam "@link" linkParam [ webLogParam webLogId ]) - fromData + (fun rdr -> { fromData rdr with PriorPermalinks = [] }) /// Find the current permalink within a set of potential prior permalinks for the given web log let findCurrentPermalink (permalinks: Permalink list) webLogId = diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 3a67a9c..62e8826 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -54,9 +54,12 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = (toCount >> int) /// Find a post by its ID for the given web log (excluding revisions) - let findById postId webLogId = + let findById postId webLogId = backgroundTask { log.LogTrace "Post.findById" - Document.findByIdAndWebLog Table.Post postId webLogId conn + match! Document.findByIdAndWebLog 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) let findByPermalink (permalink: Permalink) webLogId = @@ -65,12 +68,12 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = conn.customSingle $"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkParam "@link"}""" (addFieldParam "@link" linkParam [ webLogParam webLogId ]) - fromData + (fun rdr -> { fromData rdr with PriorPermalinks = [] }) /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { log.LogTrace "Post.findFullById" - match! findById postId webLogId with + match! Document.findByIdAndWebLog Table.Post postId webLogId conn with | Some post -> let! post = appendPostRevisions post return Some post diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index 93af895..4c5a797 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -24,7 +24,7 @@ type SQLiteWebLogData(conn: SqliteConnection, log: ILogger) = let delete webLogId = log.LogTrace "WebLog.delete" let webLogMatches = Query.whereByField (Field.EQ "WebLogId" "") "@webLogId" - let subQuery table = $"(SELECT data ->> 'Id' FROM {table} WHERE {webLogMatches}" + let 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}; diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index 03159b8..8a2a95d 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -50,14 +50,9 @@ let ``Add succeeds`` (data: IData) = task { 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.hasLength pg.Metadata 1 "There should have been one meta item properly" - Expect.equal pg.Metadata[0].Name page.Metadata[0].Name "Metadata name not saved properly" - Expect.equal pg.Metadata[0].Value page.Metadata[0].Value "Metadata value not saved properly" - Expect.hasLength pg.PriorPermalinks 1 "There should have been one prior permalink" - Expect.equal pg.PriorPermalinks[0] page.PriorPermalinks[0] "Prior permalink not saved properly" - Expect.hasLength pg.Revisions 1 "There should have been one revision" - Expect.equal pg.Revisions[0].AsOf page.Revisions[0].AsOf "Revision as of not saved properly" - Expect.equal pg.Revisions[0].Text page.Revisions[0].Text "Revision 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 { @@ -95,11 +90,8 @@ let ``FindById succeeds when a page is found`` (data: IData) = task { 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 "

      A Cool Page

      \n

      It really is cool!

      \n" "Text is incorrect" - Expect.hasLength pg.Metadata 2 "There should be 2 metadata items on this page" - Expect.equal pg.Metadata[0].Name "Cool" "Meta item 0 name is incorrect" - Expect.equal pg.Metadata[0].Value "true" "Meta item 0 value is incorrect" - Expect.equal pg.Metadata[1].Name "Warm" "Meta item 1 name is incorrect" - Expect.equal pg.Metadata[1].Value "false" "Meta item 1 value 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" } @@ -119,6 +111,8 @@ let ``FindByPermalink succeeds when a page is found`` (data: IData) = task { 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 { @@ -148,11 +142,11 @@ let ``FindFullById succeeds when a page is found`` (data: IData) = task { 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.hasLength pg.Revisions 1 "There should be 1 revision" - Expect.equal pg.Revisions[0].AsOf coolPagePublished "Revision 0 as-of is incorrect" - Expect.equal pg.Revisions[0].Text (Markdown "# A Cool Page\n\nIt really is cool!") "Revision 0 text is incorrect" - Expect.hasLength pg.PriorPermalinks 1 "There should be 1 prior permalink" - Expect.equal pg.PriorPermalinks[0] (Permalink "a-cool-pg.html") "Prior permalink 0 is incorrect" + 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 { @@ -230,14 +224,13 @@ let ``Update succeeds when the page exists`` (data: IData) = task { 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 "

      I have been updated" "Text is incorrect" - Expect.hasLength pg.Metadata 1 "There should be 1 metadata item on this page" - Expect.equal pg.Metadata[0].Name "Cool" "Meta item 0 name is incorrect" - Expect.equal pg.Metadata[0].Value "true" "Meta item 0 value 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.hasLength pg.Revisions 2 "There should be 2 revisions" - Expect.equal pg.Revisions[0].AsOf (coolPagePublished + Duration.FromHours 5) "As Of for revision 0 incorrect" - Expect.equal pg.Revisions[0].Text (Html "

      I have been updated") "Text for revision 0 is incorrect" - Expect.equal pg.Revisions[1].AsOf coolPagePublished "As Of for revision 1 is incorrect" + Expect.equal + pg.Revisions + [ { AsOf = coolPagePublished + Duration.FromHours 5; Text = Html "

      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 { diff --git a/src/MyWebLog.Tests/Data/PostDataTests.fs b/src/MyWebLog.Tests/Data/PostDataTests.fs index 45f2063..6a129f4 100644 --- a/src/MyWebLog.Tests/Data/PostDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostDataTests.fs @@ -3,6 +3,7 @@ /// module PostDataTests +open System open Expecto open MyWebLog open MyWebLog.Data @@ -11,6 +12,12 @@ open NodaTime /// The ID of the root web log let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" +/// The ID of podcast episode 1 +let episode1 = PostId "osxMfWGlAkyugUbJ1-xD1g" + +/// The published instant for episode 1 +let episode1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:24:01Z") + let ``Add succeeds`` (data: IData) = task { let post = { Id = PostId "a-new-post" @@ -50,3 +57,89 @@ let ``Add succeeds`` (data: IData) = task { 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 "

      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" + Expect.isEmpty it.PriorPermalinks "Prior permalinks should have been empty" + Expect.isEmpty it.Revisions "Revisions should have been empty" +} + +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" + Expect.isEmpty it.PriorPermalinks "Prior permalinks should have been empty" + Expect.isEmpty it.Revisions "Revisions should have been empty" +} + +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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 7b4dc1c..623e108 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -226,6 +226,39 @@ let postTests = testList "Post" [ 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 ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index 6ac7d6e..a370a83 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -225,6 +225,39 @@ let postTests = testList "Post" [ 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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 06dc659..e033a73 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -1,7 +1,7 @@ module SQLiteDataTests open System.IO -open BitBadger.Documents +open BitBadger.Documents.Sqlite open Expecto open Microsoft.Extensions.Logging.Abstractions open MyWebLog @@ -18,25 +18,44 @@ let dbName = /// Create a SQLiteData instance for testing let mkData () = - Sqlite.Configuration.useConnectionString $"Data Source=./{dbName}" - let conn = Sqlite.Configuration.dbConn () + Configuration.useConnectionString $"Data Source=./{dbName}" + let conn = Configuration.dbConn () SQLiteData(conn, NullLogger(), ser) :> IData +// /// Create a SQLiteData instance for testing +// let mkTraceData () = +// Sqlite.Configuration.useConnectionString $"Data Source=./{dbName}" +// let conn = Sqlite.Configuration.dbConn () +// let myLogger = +// LoggerFactory +// .Create(fun builder -> +// builder +// .AddSimpleConsole() +// .SetMinimumLevel(LogLevel.Trace) +// |> ignore) +// .CreateLogger() +// SQLiteData(conn, myLogger, ser) :> IData + /// Dispose the connection associated with the SQLiteData instance let dispose (data: IData) = (data :?> SQLiteData).Conn.Dispose() /// Create a fresh environment from the root backup let freshEnvironment (data: IData option) = task { - let env = + let! env = task { match data with | Some d -> - System.Console.WriteLine "Existing data" - d + return d | None -> - System.Console.WriteLine $"No data; deleting {dbName}" - File.Delete dbName - mkData () + let d = mkData () + // Thank you, kind Internet stranger... https://stackoverflow.com/a/548297 + do! (d :?> SQLiteData).Conn.customNonQuery + "PRAGMA writable_schema = 1; + DELETE FROM sqlite_master WHERE type IN ('table', 'index'); + PRAGMA writable_schema = 0; + VACUUM" [] + return d + } 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 @@ -296,6 +315,57 @@ let postTests = testList "Post" [ try do! PostDataTests.``Add succeeds`` data finally dispose data } + testTask "CountPostsByStatus succeeds" { + let data = mkData () + try do! PostDataTests.``CountByStatus succeeds`` data + finally dispose data + } + testList "FindById" [ + testTask "succeeds when a post is found" { + let data = mkData () + try do! PostDataTests.``FindById succeeds when a post is found`` data + finally dispose data + } + testTask "succeeds when a post is not found (incorrect weblog)" { + let data = mkData () + try do! PostDataTests.``FindById succeeds when a post is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a post is not found (bad post ID)" { + let data = mkData () + try do! PostDataTests.``FindById succeeds when a post is not found (bad post ID)`` data + finally dispose data + } + ] + testList "FindByPermalink" [ + testTask "succeeds when a post is found" { + let data = mkData () + try do! PostDataTests.``FindByPermalink succeeds when a post is found`` data + finally dispose data + } + testTask "succeeds when a post is not found (incorrect weblog)" { + let data = mkData () + try do! PostDataTests.``FindByPermalink succeeds when a post is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a post is not found (no such permalink)" { + let data = mkData () + try do! PostDataTests.``FindByPermalink succeeds when a post is not found (no such permalink)`` data + finally dispose data + } + ] + testList "FindCurrentPermalink" [ + testTask "succeeds when a post is found" { + let data = mkData () + try do! PostDataTests.``FindCurrentPermalink succeeds when a post is found`` data + finally dispose data + } + testTask "succeeds when a post is not found" { + let data = mkData () + try do! PostDataTests.``FindCurrentPermalink succeeds when a post is not found`` data + finally dispose data + } + ] ] /// Delete the SQLite database diff --git a/src/MyWebLog.Tests/root-weblog.json b/src/MyWebLog.Tests/root-weblog.json index 39babe3..a4b45a0 100644 --- a/src/MyWebLog.Tests/root-weblog.json +++ b/src/MyWebLog.Tests/root-weblog.json @@ -272,7 +272,9 @@ "Value": "Low" } ], - "PriorPermalinks": [], + "PriorPermalinks": [ + "2024/ep-1.html" + ], "Revisions": [ { "AsOf": "2024-01-20T22:24:01Z", -- 2.45.1 From 84460b421faa3f7cdfeda44dd0671d0df6735c7a Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 1 Feb 2024 20:17:35 -0500 Subject: [PATCH 073/123] Add post FindFull* tests --- src/MyWebLog.Tests/Data/PostDataTests.fs | 44 +++++++++++++++++++ src/MyWebLog.Tests/Data/PostgresDataTests.fs | 16 +++++++ src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 16 +++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 24 ++++++++++ 4 files changed, 100 insertions(+) diff --git a/src/MyWebLog.Tests/Data/PostDataTests.fs b/src/MyWebLog.Tests/Data/PostDataTests.fs index 6a129f4..e6e4dde 100644 --- a/src/MyWebLog.Tests/Data/PostDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostDataTests.fs @@ -18,6 +18,15 @@ let episode1 = PostId "osxMfWGlAkyugUbJ1-xD1g" /// The published instant for episode 1 let 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 something = PostId "QweKbWQiOkqqrjEdgP9wwg" + +/// The ID of "Test Post 1" post +let testPost1 = PostId "RCsCU2puYEmkpzotoi8p4g" + let ``Add succeeds`` (data: IData) = task { let post = { Id = PostId "a-new-post" @@ -143,3 +152,38 @@ let ``FindCurrentPermalink succeeds when a post is not found`` (data: IData) = t 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 "

      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 4 "There should have been 4 posts returned" + let allPosts = [ testPost1; episode1; episode2; something ] + 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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 623e108..48e8594 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -259,6 +259,22 @@ let postTests = testList "Post" [ 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 ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index a370a83..2765617 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -258,6 +258,22 @@ let postTests = testList "Post" [ 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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index e033a73..484e1a8 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -366,6 +366,30 @@ let postTests = testList "Post" [ finally dispose data } ] + testList "FindFullById" [ + testTask "succeeds when a post is found" { + let data = mkData () + try do! PostDataTests.``FindFullById succeeds when a post is found`` data + finally dispose data + } + testTask "succeeds when a post is not found" { + let data = mkData () + try do! PostDataTests.``FindFullById succeeds when a post is not found`` data + finally dispose data + } + ] + testList "FindFullByWebLog" [ + testTask "succeeds when posts are found" { + let data = mkData () + try do! PostDataTests.``FindFullByWebLog succeeds when posts are found`` data + finally dispose data + } + testTask "succeeds when a posts are not found" { + let data = mkData () + try do! PostDataTests.``FindFullByWebLog succeeds when posts are not found`` data + finally dispose data + } + ] ] /// Delete the SQLite database -- 2.45.1 From 05d49e6ce9c15a50db9cbf2c083b592150931b60 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 2 Feb 2024 22:22:12 -0500 Subject: [PATCH 074/123] Finish post data tests --- src/MyWebLog.Data/Interfaces.fs | 2 +- .../Postgres/PostgresPostData.fs | 69 ++--- src/MyWebLog.Data/RethinkDbData.fs | 45 ++-- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 49 ++-- src/MyWebLog.Tests/Data/PostDataTests.fs | 254 +++++++++++++++++- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 83 +++++- src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 82 ++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 126 +++++++++ src/MyWebLog.Tests/root-weblog.json | 28 +- 9 files changed, 660 insertions(+), 78 deletions(-) diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index 4c4c4c7..6fd9207 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -128,7 +128,7 @@ type IPostData = abstract member FindPageOfCategorizedPosts : WebLogId -> CategoryId list -> pageNbr: int -> postsPerPage: int -> Task - /// 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 /// Find posts to be displayed on a page (excluding revisions and prior permalinks) diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs index c41ccee..7724ca0 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -5,7 +5,7 @@ open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open NodaTime.Text +open NodaTime open Npgsql.FSharp /// PostgreSQL myWebLog post data implementation @@ -20,9 +20,13 @@ type PostgresPostData(log: ILogger) = return { post with Revisions = revisions } } - /// Return a post with no revisions or text + /// Return a post with no revisions or prior permalinks + let postWithoutLinks row = + { fromData row with PriorPermalinks = [] } + + /// Return a post with no revisions, prior permalinks, or text let postWithoutText row = - { fromData row with Text = "" } + { postWithoutLinks row with Text = "" } /// Update a post's revisions let updatePostRevisions (postId: PostId) oldRevs newRevs = @@ -36,6 +40,13 @@ type PostgresPostData(log: ILogger) = // 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" @@ -55,7 +66,7 @@ type PostgresPostData(log: ILogger) = Custom.single (selectWithCriteria Table.Post) [ jsonParam "@criteria" {| webLogDoc webLogId with Permalink = permalink |} ] - (fun row -> { fromData row with PriorPermalinks = [] }) + postWithoutLinks /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { @@ -118,7 +129,7 @@ type PostgresPostData(log: ILogger) = ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catParam ] - fromData + postWithoutLinks /// Get a page of posts for the given web log (excludes text and revisions) let findPageOfPosts webLogId pageNbr postsPerPage = @@ -139,7 +150,7 @@ type PostgresPostData(log: ILogger) = ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ] - fromData + postWithoutLinks /// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks) let findPageOfTaggedPosts webLogId (tag: string) pageNbr postsPerPage = @@ -150,40 +161,32 @@ type PostgresPostData(log: ILogger) = 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 |] ] - fromData + postWithoutLinks /// Find the next newest and oldest post from a publish date for the given web log - let findSurroundingPosts webLogId publishedOn = backgroundTask { + let findSurroundingPosts webLogId (publishedOn: Instant) = backgroundTask { log.LogTrace "Post.findSurroundingPosts" let queryParams () = [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} - "@publishedOn", Sql.string ((InstantPattern.General.Format publishedOn)[..19]) ] - let pubField = nameof Post.Empty.PublishedOn - let! older = - Custom.list - $"{selectWithCriteria Table.Post} - AND SUBSTR(data ->> '{pubField}', 1, 19) < @publishedOn - ORDER BY data ->> '{pubField}' DESC - LIMIT 1" - (queryParams ()) - fromData - let! newer = - Custom.list - $"{selectWithCriteria Table.Post} - AND SUBSTR(data ->> '{pubField}', 1, 19) > @publishedOn - ORDER BY data ->> '{pubField}' - LIMIT 1" - (queryParams ()) - fromData + "@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 } - /// Save a post - let save (post : Post) = backgroundTask { + /// Update a post + let update (post : Post) = backgroundTask { log.LogTrace "Post.save" - let! oldPost = findFullById post.Id post.WebLogId - do! save Table.Post { post with Revisions = [] } - do! updatePostRevisions post.Id (match oldPost with Some p -> p.Revisions | None -> []) post.Revisions + 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 @@ -212,7 +215,7 @@ type PostgresPostData(log: ILogger) = } interface IPostData with - member _.Add post = save post + 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 @@ -229,5 +232,5 @@ type PostgresPostData(log: ILogger) = findPageOfTaggedPosts webLogId tag pageNbr postsPerPage member _.FindSurroundingPosts webLogId publishedOn = findSurroundingPosts webLogId publishedOn member _.Restore posts = restore posts - member _.Update post = save post + member _.Update post = update post member _.UpdatePriorPermalinks postId webLogId permalinks = updatePriorPermalinks postId webLogId permalinks diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 5a86813..fe46841 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -649,7 +649,8 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger obj nameof Post.Empty.Status, Published ] - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||]) + .With(nameof Post.Empty.Revisions, [||])) distinct orderByDescending (nameof Post.Empty.PublishedOn) skip ((pageNbr - 1) * postsPerPage) @@ -660,7 +661,9 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger { withTable Table.Post getAll [ webLogId ] (nameof Post.Empty.WebLogId) - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + 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) skip ((pageNbr - 1) * postsPerPage) @@ -672,7 +675,8 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger obj nameof Post.Empty.Status, Published ] - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||]) + .With(nameof Post.Empty.Revisions, [||])) orderByDescending (nameof Post.Empty.PublishedOn) skip ((pageNbr - 1) * postsPerPage) limit (postsPerPage + 1) @@ -697,7 +702,8 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger row[nameof Post.Empty.PublishedOn].Lt publishedOn :> obj) - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||]) + .With(nameof Post.Empty.Revisions, [||])) orderByDescending (nameof Post.Empty.PublishedOn) limit 1 result; withRetryDefault @@ -708,7 +714,8 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger row[nameof Post.Empty.PublishedOn].Gt publishedOn :> obj) - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] + merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||]) + .With(nameof Post.Empty.Revisions, [||])) orderBy (nameof Post.Empty.PublishedOn) limit 1 result; withRetryDefault @@ -726,22 +733,20 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger + do! rethink { + withTable Table.Post + get post.Id + replace post + write; withRetryDefault; ignoreResult conn + } + | None -> () } - member _.UpdatePriorPermalinks postId webLogId permalinks = backgroundTask { - match! ( - rethink { - withTable Table.Post - get postId - without [ nameof Post.Empty.Revisions; nameof Post.Empty.PriorPermalinks ] - resultOption; withRetryOptionDefault - } - |> verifyWebLog webLogId (_.WebLogId)) conn with + member this.UpdatePriorPermalinks postId webLogId permalinks = backgroundTask { + match! this.FindById postId webLogId with | Some _ -> do! rethink { withTable Table.Post diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 62e8826..cc2063e 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -33,6 +33,14 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = /// The SELECT statement to retrieve posts with a web log ID parameter let postByWebLog = Document.Query.selectByWebLog Table.Post + /// Return a post with no revisions or prior permalinks + let postWithoutLinks rdr = + { fromData rdr with PriorPermalinks = [] } + + /// Return a post with no revisions, prior permalinks, or text + let postWithoutText rdr = + { postWithoutLinks rdr with Text = "" } + /// The SELECT statement to retrieve published posts with a web log ID parameter let publishedPostByWebLog = $"""{postByWebLog} AND {Query.whereByField (Field.EQ statName "") $"'{string Published}'"}""" @@ -44,6 +52,13 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = // IMPLEMENTATION FUNCTIONS + /// Add a post + 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: PostStatus) webLogId = log.LogTrace "Post.countByStatus" @@ -68,7 +83,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = conn.customSingle $"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkParam "@link"}""" (addFieldParam "@link" linkParam [ webLogParam webLogId ]) - (fun rdr -> { fromData rdr with PriorPermalinks = [] }) + postWithoutLinks /// Find a complete post by its ID for the given web log let findFullById postId webLogId = backgroundTask { @@ -123,7 +138,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = ORDER BY {publishField} DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" (webLogParam webLogId :: catParams) - fromData + postWithoutLinks /// Get a page of posts for the given web log (excludes text and revisions) let findPageOfPosts webLogId pageNbr postsPerPage = @@ -133,7 +148,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}' LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ webLogParam webLogId ] - (fun rdr -> { fromData rdr with Text = "" }) + postWithoutText /// Get a page of published posts for the given web log (excludes revisions) let findPageOfPublishedPosts webLogId pageNbr postsPerPage = @@ -143,7 +158,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = ORDER BY {publishField} DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" [ webLogParam webLogId ] - fromData + postWithoutLinks /// Get a page of tagged posts for the given web log (excludes revisions) let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = @@ -154,7 +169,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = ORDER BY {publishField} DESC LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" (webLogParam webLogId :: tagParams) - fromData + postWithoutLinks /// Find the next newest and oldest post from a publish date for the given web log let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask { @@ -163,27 +178,29 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = conn.customSingle $"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1" [ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ] - fromData + postWithoutLinks let! newer = conn.customSingle $"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1" [ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ] - fromData + postWithoutLinks return older, newer } - /// Save a post - let save (post: Post) = backgroundTask { - log.LogTrace "Post.save" - let! oldPost = findFullById post.Id post.WebLogId - do! conn.save Table.Post { post with Revisions = [] } - do! updatePostRevisions post.Id (match oldPost with Some p -> p.Revisions | None -> []) post.Revisions + /// Update a post + let update (post: Post) = backgroundTask { + log.LogTrace "Post.update" + match! findFullById post.Id post.WebLogId with + | Some oldPost -> + do! conn.updateById 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" - for post in posts do do! save post + for post in posts do do! add post } /// Update prior permalinks for a post @@ -196,7 +213,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = } interface IPostData with - member _.Add post = save post + 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 @@ -213,5 +230,5 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) = findPageOfTaggedPosts webLogId tag pageNbr postsPerPage member _.FindSurroundingPosts webLogId publishedOn = findSurroundingPosts webLogId publishedOn member _.Restore posts = restore posts - member _.Update post = save post + member _.Update post = update post member _.UpdatePriorPermalinks postId webLogId permalinks = updatePriorPermalinks postId webLogId permalinks diff --git a/src/MyWebLog.Tests/Data/PostDataTests.fs b/src/MyWebLog.Tests/Data/PostDataTests.fs index e6e4dde..ecf63c8 100644 --- a/src/MyWebLog.Tests/Data/PostDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostDataTests.fs @@ -24,9 +24,31 @@ let episode2 = PostId "l4_Eh4aFO06SqqJjOymNzA" /// The ID of "Something May Happen" post let something = PostId "QweKbWQiOkqqrjEdgP9wwg" +/// The published instant for "Something May Happen" post +let somethingPublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:32:59Z") + +/// The ID of "An Incomplete Thought" post +let incomplete = PostId "VweKbWQiOkqqrjEdgP9wwg" + /// The ID of "Test Post 1" post let testPost1 = PostId "RCsCU2puYEmkpzotoi8p4g" +/// The published instant for "Test Post 1" post +let testPost1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:17:29Z") + +/// The category IDs for "Spitball" (parent) and "Moonshot" +let testCatIds = [ CategoryId "jw6N69YtTEWVHAO33jHU-w"; CategoryId "ScVpyu1e7UiP7bDdge3ZEw" ] + +/// Ensure that a list of posts has text for each post +let 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 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" @@ -109,8 +131,7 @@ let ``FindById succeeds when a post is found`` (data: IData) = task { it.Metadata [ { Name = "Density"; Value = "Non-existent" }; { Name = "Intensity"; Value = "Low" } ] "Metadata is incorrect" - Expect.isEmpty it.PriorPermalinks "Prior permalinks should have been empty" - Expect.isEmpty it.Revisions "Revisions should have been empty" + ensureEmpty [ it ] } let ``FindById succeeds when a post is not found (incorrect weblog)`` (data: IData) = task { @@ -128,8 +149,7 @@ let ``FindByPermalink succeeds when a post is found`` (data: IData) = task { Expect.isSome post "A post should have been returned" let it = post.Value Expect.equal it.Id episode1 "The wrong post was retrieved" - Expect.isEmpty it.PriorPermalinks "Prior permalinks should have been empty" - Expect.isEmpty it.Revisions "Revisions should have been empty" + ensureEmpty [ it ] } let ``FindByPermalink succeeds when a post is not found (incorrect weblog)`` (data: IData) = task { @@ -173,8 +193,8 @@ let ``FindFullById succeeds when a post is not found`` (data: IData) = task { let ``FindFullByWebLog succeeds when posts are found`` (data: IData) = task { let! posts = data.Post.FindFullByWebLog rootId - Expect.hasLength posts 4 "There should have been 4 posts returned" - let allPosts = [ testPost1; episode1; episode2; something ] + 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 @@ -187,3 +207,225 @@ 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 = "

      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 "

      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 "

      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 "

      Updated text here" } + { AsOf = Noda.epoch + Duration.FromMinutes 1L; Text = Html "

      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" +} diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 48e8594..9c9b0ae 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -1,6 +1,5 @@ module PostgresDataTests -open System open BitBadger.Documents open Expecto open Microsoft.Extensions.Logging.Abstractions @@ -275,6 +274,88 @@ let postTests = testList "Post" [ 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 ()) + } + testTask "succeeds when a post is not deleted" { + do! PostDataTests.``Delete succeeds when a post is not deleted`` (mkData ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index 2765617..d33fca5 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -274,6 +274,88 @@ let postTests = testList "Post" [ 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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 484e1a8..2b735c9 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -390,6 +390,132 @@ let postTests = testList "Post" [ finally dispose data } ] + testList "FindPageOfCategorizedPosts" [ + testTask "succeeds when posts are found" { + let data = mkData () + try do! PostDataTests.``FindPageOfCategorizedPosts succeeds when posts are found`` data + finally dispose data + } + testTask "succeeds when finding a too-high page number" { + let data = mkData () + try do! PostDataTests.``FindPageOfCategorizedPosts succeeds when finding a too-high page number`` data + finally dispose data + } + testTask "succeeds when a category has no posts" { + let data = mkData () + try do! PostDataTests.``FindPageOfCategorizedPosts succeeds when a category has no posts`` data + finally dispose data + } + ] + testList "FindPageOfPosts" [ + testTask "succeeds when posts are found" { + let data = mkData () + try do! PostDataTests.``FindPageOfPosts succeeds when posts are found`` data + finally dispose data + } + testTask "succeeds when finding a too-high page number" { + let data = mkData () + try do! PostDataTests.``FindPageOfPosts succeeds when finding a too-high page number`` data + finally dispose data + } + testTask "succeeds when there are no posts" { + let data = mkData () + try do! PostDataTests.``FindPageOfPosts succeeds when there are no posts`` data + finally dispose data + } + ] + testList "FindPageOfPublishedPosts" [ + testTask "succeeds when posts are found" { + let data = mkData () + try do! PostDataTests.``FindPageOfPublishedPosts succeeds when posts are found`` data + finally dispose data + } + testTask "succeeds when finding a too-high page number" { + let data = mkData () + try do! PostDataTests.``FindPageOfPublishedPosts succeeds when finding a too-high page number`` data + finally dispose data + } + testTask "succeeds when there are no posts" { + let data = mkData () + try do! PostDataTests.``FindPageOfPublishedPosts succeeds when there are no posts`` data + finally dispose data + } + ] + testList "FindPageOfTaggedPosts" [ + testTask "succeeds when posts are found" { + let data = mkData () + try do! PostDataTests.``FindPageOfTaggedPosts succeeds when posts are found`` data + finally dispose data + } + testTask "succeeds when posts are found (excluding drafts)" { + let data = mkData () + try do! PostDataTests.``FindPageOfTaggedPosts succeeds when posts are found (excluding drafts)`` data + finally dispose data + } + testTask "succeeds when finding a too-high page number" { + let data = mkData () + try do! PostDataTests.``FindPageOfTaggedPosts succeeds when finding a too-high page number`` data + finally dispose data + } + testTask "succeeds when there are no posts" { + let data = mkData () + try do! PostDataTests.``FindPageOfTaggedPosts succeeds when there are no posts`` data + finally dispose data + } + ] + testList "FindSurroundingPosts" [ + testTask "succeeds when there is no next newer post" { + let data = mkData () + try do! PostDataTests.``FindSurroundingPosts succeeds when there is no next newer post`` data + finally dispose data + } + testTask "succeeds when there is no next older post" { + let data = mkData () + try do! PostDataTests.``FindSurroundingPosts succeeds when there is no next older post`` data + finally dispose data + } + testTask "succeeds when older and newer exist" { + let data = mkData () + try do! PostDataTests.``FindSurroundingPosts succeeds when older and newer exist`` data + finally dispose data + } + ] + testList "Update" [ + testTask "succeeds when the post exists" { + let data = mkData () + try do! PostDataTests.``Update succeeds when the post exists`` data + finally dispose data + } + testTask "succeeds when the post does not exist" { + let data = mkData () + try do! PostDataTests.``Update succeeds when the post does not exist`` data + finally dispose data + } + ] + testList "UpdatePriorPermalinks" [ + testTask "succeeds when the post exists" { + let data = mkData () + try do! PostDataTests.``UpdatePriorPermalinks succeeds when the post exists`` data + finally dispose data + } + testTask "succeeds when the post does not exist" { + let data = mkData () + try do! PostDataTests.``UpdatePriorPermalinks succeeds when the post does not exist`` data + finally dispose data + } + ] + testList "Delete" [ + testTask "succeeds when a post is deleted" { + let data = mkData () + try do! PostDataTests.``Delete succeeds when a post is deleted`` data + finally dispose data + } + testTask "succeeds when a post is not deleted" { + let data = mkData () + try do! PostDataTests.``Delete succeeds when a post is not deleted`` data + finally dispose data + } + ] ] /// Delete the SQLite database diff --git a/src/MyWebLog.Tests/root-weblog.json b/src/MyWebLog.Tests/root-weblog.json index a4b45a0..2b86eda 100644 --- a/src/MyWebLog.Tests/root-weblog.json +++ b/src/MyWebLog.Tests/root-weblog.json @@ -333,13 +333,39 @@ "speculation" ], "Metadata": [], - "PriorPermalinks": [], + "PriorPermalinks": [ + "2024/some-thing.html" + ], "Revisions": [ { "AsOf": "2024-01-20T22:32:59Z", "Text": "HTML:

      Hmm

      " } ] + }, + { + "Id": "VweKbWQiOkqqrjEdgP9wwg", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "Status": "Draft", + "Title": "An Incomplete Thought", + "Permalink": "2024/still-cooking.html", + "UpdatedOn": "2024-01-24T22:35:00Z", + "Text": "

      Think think think", + "CategoryIds": [ + "jw6N69YtTEWVHAO33jHU-w" + ], + "Tags": [ + "speculation" + ], + "Metadata": [], + "PriorPermalinks": [], + "Revisions": [ + { + "AsOf": "2024-01-24T22:35:00Z", + "Text": "HTML:

      Think think think" + } + ] } ], "Uploads": [] -- 2.45.1 From 8183da7d5fc369a53af407824b885ff712eff70d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 3 Feb 2024 11:09:03 -0500 Subject: [PATCH 075/123] Add tag mapping tests --- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 59 +++++++++ src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 59 +++++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 86 ++++++++++++++ src/MyWebLog.Tests/Data/TagMapDataTests.fs | 112 ++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + 5 files changed, 317 insertions(+) create mode 100644 src/MyWebLog.Tests/Data/TagMapDataTests.fs diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 9c9b0ae..a248033 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -358,6 +358,64 @@ let postTests = testList "Post" [ ] ] +let 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 ()) + } + ] +] + /// Drop the throwaway PostgreSQL database let environmentCleanUp = test "Clean Up" { if db.IsSome then db.Value.Dispose() @@ -370,5 +428,6 @@ let all = categoryTests pageTests postTests + tagMapTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index d33fca5..81de83a 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -358,6 +358,64 @@ let postTests = testList "Post" [ ] ] +let 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 + } + ] +] + /// Drop the throwaway RethinkDB database let environmentCleanUp = testTask "Clean Up" { do! disposeData () @@ -370,5 +428,6 @@ let all = categoryTests pageTests postTests + tagMapTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 2b735c9..ca18077 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -518,6 +518,91 @@ let postTests = testList "Post" [ ] ] +let tagMapTests = testList "TagMap" [ + testList "FindById" [ + testTask "succeeds when a tag mapping is found" { + let data = mkData () + try do! TagMapDataTests.``FindById succeeds when a tag mapping is found`` data + finally dispose data + } + testTask "succeeds when a tag mapping is not found (incorrect weblog)" { + let data = mkData () + try do! TagMapDataTests.``FindById succeeds when a tag mapping is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a tag mapping is not found (bad tag map ID)" { + let data = mkData () + try do! TagMapDataTests.``FindById succeeds when a tag mapping is not found (bad tag map ID)`` data + finally dispose data + } + ] + testList "FindByUrlValue" [ + testTask "succeeds when a tag mapping is found" { + let data = mkData () + try do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is found`` data + finally dispose data + } + testTask "succeeds when a tag mapping is not found (incorrect weblog)" { + let data = mkData () + try do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a tag mapping is not found (no such value)" { + let data = mkData () + try do! TagMapDataTests.``FindByUrlValue succeeds when a tag mapping is not found (no such value)`` data + finally dispose data + } + ] + testList "FindByWebLog" [ + testTask "succeeds when tag mappings are found" { + let data = mkData () + try do! TagMapDataTests.``FindByWebLog succeeds when tag mappings are found`` data + finally dispose data + } + testTask "succeeds when no tag mappings are found" { + let data = mkData () + try do! TagMapDataTests.``FindByWebLog succeeds when no tag mappings are found`` data + finally dispose data + } + ] + testList "FindMappingForTags" [ + testTask "succeeds when mappings exist" { + let data = mkData () + try do! TagMapDataTests.``FindMappingForTags succeeds when mappings exist`` data + finally dispose data + } + testTask "succeeds when no mappings exist" { + let data = mkData () + try do! TagMapDataTests.``FindMappingForTags succeeds when no mappings exist`` data + finally dispose data + } + ] + testList "Save" [ + testTask "succeeds when adding a tag mapping" { + let data = mkData () + try do! TagMapDataTests.``Save succeeds when adding a tag mapping`` data + finally dispose data + } + testTask "succeeds when updating a tag mapping" { + let data = mkData () + try do! TagMapDataTests.``Save succeeds when updating a tag mapping`` data + finally dispose data + } + ] + testList "Delete" [ + testTask "succeeds when a tag mapping is deleted" { + let data = mkData () + try do! TagMapDataTests.``Delete succeeds when a tag mapping is deleted`` data + finally dispose data + } + testTask "succeeds when a tag mapping is not deleted" { + let data = mkData () + try do! TagMapDataTests.``Delete succeeds when a tag mapping is not deleted`` data + finally dispose data + } + ] +] + /// Delete the SQLite database let environmentCleanUp = test "Clean Up" { File.Delete dbName @@ -531,5 +616,6 @@ let all = categoryTests pageTests postTests + tagMapTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/TagMapDataTests.fs b/src/MyWebLog.Tests/Data/TagMapDataTests.fs new file mode 100644 index 0000000..f393fa8 --- /dev/null +++ b/src/MyWebLog.Tests/Data/TagMapDataTests.fs @@ -0,0 +1,112 @@ +///

      +/// Integration tests for implementations +/// +module TagMapDataTests + +open Expecto +open MyWebLog +open MyWebLog.Data + +/// The ID of the root web log +let rootId = CategoryDataTests.rootId + +/// The ID of the f# tag +let fSharpId = TagMapId "Icm027noqE-rPHKZA98vAw" + +/// The ID of the ghoti tag +let 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" +} diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index e6c8dab..a4782e6 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -13,6 +13,7 @@ + -- 2.45.1 From b1a0c207fbf1b2f57028e1abc0bc02a6eebf712d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 3 Feb 2024 14:01:13 -0500 Subject: [PATCH 076/123] Add theme tests - Add flags to isolate data impl tests - Make most non-tests private - Add SQLite tests missed in initial development --- .../Postgres/PostgresThemeData.fs | 4 +- src/MyWebLog.Data/RethinkDbData.fs | 64 +++++---- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 8 +- src/MyWebLog.Tests/Data/CategoryDataTests.fs | 2 +- src/MyWebLog.Tests/Data/PageDataTests.fs | 8 +- src/MyWebLog.Tests/Data/PostDataTests.fs | 24 ++-- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 47 +++++++ src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 47 +++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 81 ++++++++++++ src/MyWebLog.Tests/Data/TagMapDataTests.fs | 6 +- src/MyWebLog.Tests/Data/ThemeDataTests.fs | 121 ++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + src/MyWebLog.Tests/Program.fs | 24 +++- 13 files changed, 373 insertions(+), 64 deletions(-) create mode 100644 src/MyWebLog.Tests/Data/ThemeDataTests.fs diff --git a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs index bb7d67d..1f4d089 100644 --- a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs @@ -18,7 +18,9 @@ type PostgresThemeData(log: ILogger) = let all () = log.LogTrace "Theme.all" Custom.list - $"{Query.selectFromTable Table.Theme} WHERE data ->> '{nameof Theme.Empty.Id}' <> 'admin' ORDER BY id" + $"{Query.selectFromTable Table.Theme} + WHERE data ->> '{nameof Theme.Empty.Id}' <> 'admin' + ORDER BY data ->> '{nameof Theme.Empty.Id}'" [] withoutTemplateText diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index fe46841..295f830 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -101,7 +101,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger 0UL } - member _.FindById pageId webLogId = backgroundTask { - let! page = - rethink { - withTable Table.Page - getAll [ pageId ] - without [ nameof Page.Empty.PriorPermalinks; nameof Page.Empty.Revisions ] - result; withRetryDefault - } - |> tryFirst <| conn - return - page - |> Option.filter (fun pg -> pg.WebLogId = webLogId) - |> Option.map (fun pg -> { pg with Revisions = []; PriorPermalinks = [] }) - } + member _.FindById pageId webLogId = + rethink { + withTable Table.Page + getAll [ pageId ] + filter (nameof Page.Empty.WebLogId) webLogId + merge (r.HashMap(nameof Page.Empty.PriorPermalinks, [||]) + .With(nameof Page.Empty.Revisions, [||])) + result; withRetryDefault + } + |> tryFirst <| conn member _.FindByPermalink permalink webLogId = rethink { @@ -590,20 +586,16 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger 0UL } - member _.FindById postId webLogId = backgroundTask { - let! post = - rethink { - withTable Table.Post - getAll [ postId ] - without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ] - result; withRetryDefault - } - |> tryFirst <| conn - return - post - |> Option.filter (fun p -> p.WebLogId = webLogId) - |> Option.map (fun p -> { p with Revisions = []; PriorPermalinks = [] }) - } + member _.FindById postId webLogId = + rethink { + withTable Table.Post + getAll [ postId ] + filter (nameof Post.Empty.WebLogId) webLogId + merge (r.HashMap(nameof Post.Empty.PriorPermalinks, [||]) + .With(nameof Post.Empty.Revisions, [||])) + result; withRetryDefault + } + |> tryFirst <| conn member _.FindByPermalink permalink webLogId = rethink { @@ -848,12 +840,14 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger { - withTable Table.Theme - get themeId - merge withoutTemplateText - resultOption; withRetryOptionDefault conn - } + member _.FindByIdWithoutText themeId = + rethink { + withTable Table.Theme + getAll [ themeId ] + merge withoutTemplateText + result; withRetryDefault + } + |> tryFirst <| conn member this.Delete themeId = backgroundTask { match! this.FindByIdWithoutText themeId with diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index e2561fc..17af376 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -29,6 +29,10 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = return { page with Revisions = revisions } } + /// Create a page with no prior permalinks + let pageWithoutLinks rdr = + { fromData rdr with PriorPermalinks = [] } + /// Update a page's revisions let updatePageRevisions (pageId: PageId) oldRevs newRevs = log.LogTrace "Page.updatePageRevisions" @@ -102,7 +106,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = conn.customSingle $"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkParam "@link"}""" (addFieldParam "@link" linkParam [ webLogParam webLogId ]) - (fun rdr -> { fromData rdr with PriorPermalinks = [] }) + pageWithoutLinks /// Find the current permalink within a set of potential prior permalinks for the given web log let findCurrentPermalink (permalinks: Permalink list) webLogId = @@ -138,7 +142,7 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) = 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) ] - fromData + (fun rdr -> { pageWithoutLinks rdr with Metadata = [] }) /// Update a page let update (page: Page) = backgroundTask { diff --git a/src/MyWebLog.Tests/Data/CategoryDataTests.fs b/src/MyWebLog.Tests/Data/CategoryDataTests.fs index b1233cd..d09fafe 100644 --- a/src/MyWebLog.Tests/Data/CategoryDataTests.fs +++ b/src/MyWebLog.Tests/Data/CategoryDataTests.fs @@ -11,7 +11,7 @@ open MyWebLog.Data let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" /// The ID of the Favorites category -let favoritesId = CategoryId "S5JflPsJ9EG7gA2LD4m92A" +let private favoritesId = CategoryId "S5JflPsJ9EG7gA2LD4m92A" let ``Add succeeds`` (data: IData) = task { let category = diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index 8a2a95d..b8e5370 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -10,16 +10,16 @@ open MyWebLog.Data open NodaTime /// The ID of the root web log -let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" +let private rootId = CategoryDataTests.rootId /// The ID of the "A cool page" page -let coolPageId = PageId "hgc_BLEZ50SoAWLuPNISvA" +let private coolPageId = PageId "hgc_BLEZ50SoAWLuPNISvA" /// The published and updated time of the "A cool page" page -let coolPagePublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z") +let private coolPagePublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:14:28Z") /// The ID of the "Yet Another Page" page -let otherPageId = PageId "KouRjvSmm0Wz6TMD8xf67A" +let private otherPageId = PageId "KouRjvSmm0Wz6TMD8xf67A" let ``Add succeeds`` (data: IData) = task { let page = diff --git a/src/MyWebLog.Tests/Data/PostDataTests.fs b/src/MyWebLog.Tests/Data/PostDataTests.fs index ecf63c8..416327d 100644 --- a/src/MyWebLog.Tests/Data/PostDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostDataTests.fs @@ -10,41 +10,41 @@ open MyWebLog.Data open NodaTime /// The ID of the root web log -let rootId = WebLogId "uSitJEuD3UyzWC9jgOHc8g" +let private rootId = CategoryDataTests.rootId /// The ID of podcast episode 1 -let episode1 = PostId "osxMfWGlAkyugUbJ1-xD1g" +let private episode1 = PostId "osxMfWGlAkyugUbJ1-xD1g" /// The published instant for episode 1 -let episode1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:24:01Z") +let private episode1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:24:01Z") /// The ID of podcast episode 2 -let episode2 = PostId "l4_Eh4aFO06SqqJjOymNzA" +let private episode2 = PostId "l4_Eh4aFO06SqqJjOymNzA" /// The ID of "Something May Happen" post -let something = PostId "QweKbWQiOkqqrjEdgP9wwg" +let private something = PostId "QweKbWQiOkqqrjEdgP9wwg" /// The published instant for "Something May Happen" post -let somethingPublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:32:59Z") +let private somethingPublished = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:32:59Z") /// The ID of "An Incomplete Thought" post -let incomplete = PostId "VweKbWQiOkqqrjEdgP9wwg" +let private incomplete = PostId "VweKbWQiOkqqrjEdgP9wwg" /// The ID of "Test Post 1" post -let testPost1 = PostId "RCsCU2puYEmkpzotoi8p4g" +let private testPost1 = PostId "RCsCU2puYEmkpzotoi8p4g" /// The published instant for "Test Post 1" post -let testPost1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:17:29Z") +let private testPost1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:17:29Z") /// The category IDs for "Spitball" (parent) and "Moonshot" -let testCatIds = [ CategoryId "jw6N69YtTEWVHAO33jHU-w"; CategoryId "ScVpyu1e7UiP7bDdge3ZEw" ] +let private testCatIds = [ CategoryId "jw6N69YtTEWVHAO33jHU-w"; CategoryId "ScVpyu1e7UiP7bDdge3ZEw" ] /// Ensure that a list of posts has text for each post -let ensureHasText (posts: Post list) = +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 ensureEmpty posts = +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})" diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index a248033..6297a8c 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -416,6 +416,52 @@ let tagMapTests = testList "TagMap" [ ] ] +let 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 ()) + } + ] +] + /// Drop the throwaway PostgreSQL database let environmentCleanUp = test "Clean Up" { if db.IsSome then db.Value.Dispose() @@ -429,5 +475,6 @@ let all = pageTests postTests tagMapTests + themeTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index 81de83a..e4d7001 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -416,6 +416,52 @@ let tagMapTests = testList "TagMap" [ ] ] +let 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 + } + ] +] + /// Drop the throwaway RethinkDB database let environmentCleanUp = testTask "Clean Up" { do! disposeData () @@ -429,5 +475,6 @@ let all = pageTests postTests tagMapTests + themeTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index ca18077..2410c91 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -269,6 +269,18 @@ let pageTests = testList "Page" [ finally dispose data } ] + testList "FindPageOfPages" [ + testTask "succeeds when pages are found" { + let data = mkData () + try do! PageDataTests.``FindPageOfPages succeeds when pages are found`` data + finally dispose data + } + testTask "succeeds when a pages are not found" { + let data = mkData () + try do! PageDataTests.``FindPageOfPages succeeds when pages are not found`` data + finally dispose data + } + ] testList "Update" [ testTask "succeeds when the page exists" { let data = mkData () @@ -603,6 +615,74 @@ let tagMapTests = testList "TagMap" [ ] ] +let themeTests = testList "Theme" [ + testTask "All succeeds" { + let data = mkData () + try do! ThemeDataTests.``All succeeds`` data + finally dispose data + } + testList "Exists" [ + testTask "succeeds when the theme exists" { + let data = mkData () + try do! ThemeDataTests.``Exists succeeds when the theme exists`` data + finally dispose data + } + testTask "succeeds when the theme does not exist" { + let data = mkData () + try do! ThemeDataTests.``Exists succeeds when the theme does not exist`` data + finally dispose data + } + ] + testList "FindById" [ + testTask "succeeds when the theme exists" { + let data = mkData () + try do! ThemeDataTests.``FindById succeeds when the theme exists`` data + finally dispose data + } + testTask "succeeds when the theme does not exist" { + let data = mkData () + try do! ThemeDataTests.``FindById succeeds when the theme does not exist`` data + finally dispose data + } + ] + testList "FindByIdWithoutText" [ + testTask "succeeds when the theme exists" { + let data = mkData () + try do! ThemeDataTests.``FindByIdWithoutText succeeds when the theme exists`` data + finally dispose data + } + testTask "succeeds when the theme does not exist" { + let data = mkData () + try do! ThemeDataTests.``FindByIdWithoutText succeeds when the theme does not exist`` data + finally dispose data + } + ] + testList "Save" [ + testTask "succeeds when adding a theme" { + let data = mkData () + try do! ThemeDataTests.``Save succeeds when adding a theme`` data + finally dispose data + } + testTask "succeeds when updating a theme" { + let data = mkData () + try do! ThemeDataTests.``Save succeeds when updating a theme`` data + finally dispose data + } + ] + testList "Delete" [ + testTask "succeeds when a theme is deleted" { + let data = mkData () + try do! ThemeDataTests.``Delete succeeds when a theme is deleted`` data + finally dispose data + } + testTask "succeeds when a theme is not deleted" { + let data = mkData () + try do! ThemeDataTests.``Delete succeeds when a theme is not deleted`` data + finally dispose data + } + ] +] + /// Delete the SQLite database let environmentCleanUp = test "Clean Up" { File.Delete dbName @@ -617,5 +697,6 @@ let all = pageTests postTests tagMapTests + themeTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/TagMapDataTests.fs b/src/MyWebLog.Tests/Data/TagMapDataTests.fs index f393fa8..d075b22 100644 --- a/src/MyWebLog.Tests/Data/TagMapDataTests.fs +++ b/src/MyWebLog.Tests/Data/TagMapDataTests.fs @@ -8,13 +8,13 @@ open MyWebLog open MyWebLog.Data /// The ID of the root web log -let rootId = CategoryDataTests.rootId +let private rootId = CategoryDataTests.rootId /// The ID of the f# tag -let fSharpId = TagMapId "Icm027noqE-rPHKZA98vAw" +let private fSharpId = TagMapId "Icm027noqE-rPHKZA98vAw" /// The ID of the ghoti tag -let fishId = TagMapId "GdryXh-S0kGsNBs2RIacGA" +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 diff --git a/src/MyWebLog.Tests/Data/ThemeDataTests.fs b/src/MyWebLog.Tests/Data/ThemeDataTests.fs new file mode 100644 index 0000000..dd4228c --- /dev/null +++ b/src/MyWebLog.Tests/Data/ThemeDataTests.fs @@ -0,0 +1,121 @@ +/// +/// Integration tests for implementations +/// +module ThemeDataTests + +open Expecto +open MyWebLog +open MyWebLog.Data + +/// The ID of the default theme (restored from root-weblog.json) +let private defaultId = ThemeId "default" + +/// 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 { + let themeId = ThemeId "test-theme" + do! data.Theme.Save + { Id = themeId + Name = "Test Theme" + Version = "evergreen" + Templates = + [ { Name = "index"; Text = "

      {{ values_here }}

      " } + { Name = "single-post"; Text = "

      {{ the_post }}" } ] } + let! saved = data.Theme.FindById themeId + Expect.isSome saved "There should have been a theme returned" + let it = saved.Value + Expect.equal it.Id themeId "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 "

      {{ values_here }}

      " "Template 0 text incorrect" + Expect.equal it.Templates[1].Name "single-post" "Template 1 name incorrect" + Expect.equal it.Templates[1].Text "

      {{ the_post }}" "Template 1 text incorrect" +} + +let ``Save succeeds when updating a theme`` (data: IData) = task { + let themeId = ThemeId "test-theme" + do! data.Theme.Save + { Id = themeId + Name = "Updated Theme" + Version = "still evergreen" + Templates = + [ { Name = "index"; Text = "

      {{ values_there }}

      " } + { Name = "layout"; Text = "" } + { Name = "single-post"; Text = "

      {{ the_post }}" } ] } + let! updated = data.Theme.FindById themeId + Expect.isSome updated "The updated theme should have been returned" + let it = updated.Value + Expect.equal it.Id themeId "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 "

      {{ values_there }}

      " "Template 0 text incorrect" + Expect.equal it.Templates[1].Name "layout" "Template 1 name incorrect" + Expect.equal it.Templates[1].Text "" "Template 1 text incorrect" + Expect.equal it.Templates[2].Name "single-post" "Template 2 name incorrect" + Expect.equal it.Templates[2].Text "

      {{ the_post }}" "Template 2 text incorrect" +} + +let ``Delete succeeds when a theme is deleted`` (data: IData) = task { + let! deleted = data.Theme.Delete (ThemeId "test-theme") + Expect.isTrue deleted "The theme 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" +} diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index a4782e6..7b0f796 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -14,6 +14,7 @@ + diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index f5fc99b..ab848c5 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -1,13 +1,25 @@ 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 + let allTests = testList "MyWebLog" [ - testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] + if not dbOnly then testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ] testList "Data" [ - ConvertersTests.all - UtilsTests.all - RethinkDbDataTests.all - SQLiteDataTests.all - PostgresDataTests.all + 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 ] ] -- 2.45.1 From ff05bc89ed911ab0c217bb293873ec9100f49444 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 3 Feb 2024 15:32:52 -0500 Subject: [PATCH 077/123] Add theme asset tests --- src/MyWebLog.Data/RethinkDbData.fs | 9 +- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 47 +++++++ src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 47 +++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 69 +++++++++ src/MyWebLog.Tests/Data/ThemeDataTests.fs | 131 ++++++++++++++++-- 5 files changed, 291 insertions(+), 12 deletions(-) diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 295f830..1c035e3 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -184,6 +184,9 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger()) + /// Delete assets for the given theme ID let deleteAssetsByTheme themeId = rethink { withTable Table.ThemeAsset @@ -876,7 +879,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger { withTable Table.ThemeAsset - without [ nameof ThemeAsset.Empty.Data ] + merge (r.HashMap(nameof ThemeAsset.Empty.Data, emptyFile)) result; withRetryDefault conn } @@ -891,7 +894,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger { withTable Table.ThemeAsset filter (matchAssetByThemeId themeId) - without [ nameof ThemeAsset.Empty.Data ] + merge (r.HashMap(nameof ThemeAsset.Empty.Data, emptyFile)) result; withRetryDefault conn } @@ -950,7 +953,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger 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 } diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 6297a8c..6e1c6ab 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -462,6 +462,52 @@ let themeTests = testList "Theme" [ ] ] +let 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 ()) + } + ] +] + /// Drop the throwaway PostgreSQL database let environmentCleanUp = test "Clean Up" { if db.IsSome then db.Value.Dispose() @@ -476,5 +522,6 @@ let all = postTests tagMapTests themeTests + themeAssetTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index e4d7001..867d542 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -462,6 +462,52 @@ let themeTests = testList "Theme" [ ] ] +let 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 + } + ] +] + /// Drop the throwaway RethinkDB database let environmentCleanUp = testTask "Clean Up" { do! disposeData () @@ -476,5 +522,6 @@ let all = postTests tagMapTests themeTests + themeAssetTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 2410c91..7e7dba7 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -683,6 +683,74 @@ let themeTests = testList "Theme" [ ] ] +let themeAssetTests = testList "ThemeAsset" [ + testList "Save" [ + testTask "succeeds when adding an asset" { + let data = mkData () + try do! ThemeDataTests.Asset.``Save succeeds when adding an asset`` data + finally dispose data + } + testTask "succeeds when updating an asset" { + let data = mkData () + try do! ThemeDataTests.Asset.``Save succeeds when updating an asset`` data + finally dispose data + } + ] + testTask "All succeeds" { + let data = mkData () + try do! ThemeDataTests.Asset.``All succeeds`` data + finally dispose data + } + testList "FindById" [ + testTask "succeeds when an asset is found" { + let data = mkData () + try do! ThemeDataTests.Asset.``FindById succeeds when an asset is found`` data + finally dispose data + } + testTask "succeeds when an asset is not found" { + let data = mkData () + try do! ThemeDataTests.Asset.``FindById succeeds when an asset is not found`` data + finally dispose data + } + ] + testList "FindByTheme" [ + testTask "succeeds when assets exist" { + let data = mkData () + try do! ThemeDataTests.Asset.``FindByTheme succeeds when assets exist`` data + finally dispose data + } + testTask "succeeds when assets do not exist" { + let data = mkData () + try do! ThemeDataTests.Asset.``FindByTheme succeeds when assets do not exist`` data + finally dispose data + } + ] + testList "FindByThemeWithData" [ + testTask "succeeds when assets exist" { + let data = mkData () + try do! ThemeDataTests.Asset.``FindByThemeWithData succeeds when assets exist`` data + finally dispose data + } + testTask "succeeds when assets do not exist" { + let data = mkData () + try do! ThemeDataTests.Asset.``FindByThemeWithData succeeds when assets do not exist`` data + finally dispose data + } + ] + testList "DeleteByTheme" [ + testTask "succeeds when assets are deleted" { + let data = mkData () + try do! ThemeDataTests.Asset.``DeleteByTheme succeeds when assets are deleted`` data + finally dispose data + } + testTask "succeeds when no assets are deleted" { + let data = mkData () + try do! ThemeDataTests.Asset.``DeleteByTheme succeeds when no assets are deleted`` data + finally dispose data + } + ] +] + /// Delete the SQLite database let environmentCleanUp = test "Clean Up" { File.Delete dbName @@ -698,5 +766,6 @@ let all = postTests tagMapTests themeTests + themeAssetTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/ThemeDataTests.fs b/src/MyWebLog.Tests/Data/ThemeDataTests.fs index dd4228c..5233187 100644 --- a/src/MyWebLog.Tests/Data/ThemeDataTests.fs +++ b/src/MyWebLog.Tests/Data/ThemeDataTests.fs @@ -3,13 +3,24 @@ /// 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 @@ -64,18 +75,17 @@ let ``FindByIdWithoutText succeeds when the theme does not exist`` (data: IData) } let ``Save succeeds when adding a theme`` (data: IData) = task { - let themeId = ThemeId "test-theme" do! data.Theme.Save - { Id = themeId + { Id = testId Name = "Test Theme" Version = "evergreen" Templates = [ { Name = "index"; Text = "

      {{ values_here }}

      " } { Name = "single-post"; Text = "

      {{ the_post }}" } ] } - let! saved = data.Theme.FindById themeId + let! saved = data.Theme.FindById testId Expect.isSome saved "There should have been a theme returned" let it = saved.Value - Expect.equal it.Id themeId "ID was incorrect" + 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" @@ -86,19 +96,18 @@ let ``Save succeeds when adding a theme`` (data: IData) = task { } let ``Save succeeds when updating a theme`` (data: IData) = task { - let themeId = ThemeId "test-theme" do! data.Theme.Save - { Id = themeId + { Id = testId Name = "Updated Theme" Version = "still evergreen" Templates = [ { Name = "index"; Text = "

      {{ values_there }}

      " } { Name = "layout"; Text = "" } { Name = "single-post"; Text = "

      {{ the_post }}" } ] } - let! updated = data.Theme.FindById themeId + let! updated = data.Theme.FindById testId Expect.isSome updated "The updated theme should have been returned" let it = updated.Value - Expect.equal it.Id themeId "ID was incorrect" + 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" @@ -111,11 +120,115 @@ let ``Save succeeds when updating a theme`` (data: IData) = task { } let ``Delete succeeds when a theme is deleted`` (data: IData) = task { - let! deleted = data.Theme.Delete (ThemeId "test-theme") + // 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" } + +///

      +/// Integration tests for implementations +/// +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" + } -- 2.45.1 From 34315a1aca4b1a63bba3f508b6bd1f9ba3254748 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 3 Feb 2024 17:38:41 -0500 Subject: [PATCH 078/123] Add upload tests --- .../Postgres/PostgresUploadData.fs | 3 +- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 74 +++++++++++---- src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 68 ++++++++++--- src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 90 +++++++++++++++--- src/MyWebLog.Tests/Data/UploadDataTests.fs | 95 +++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + src/MyWebLog.Tests/root-weblog.json | 10 +- 7 files changed, 295 insertions(+), 46 deletions(-) create mode 100644 src/MyWebLog.Tests/Data/UploadDataTests.fs diff --git a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs index bfacbc9..1ceda0f 100644 --- a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs @@ -1,6 +1,5 @@ namespace MyWebLog.Data.Postgres -open BitBadger.Documents open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog @@ -41,7 +40,7 @@ type PostgresUploadData(log: ILogger) = (webLogIdParam webLogId :: idParam) (fun row -> row.string "path") if Option.isSome path then - do! Custom.nonQuery (Query.Delete.byId Table.Upload) idParam + do! Custom.nonQuery $"DELETE FROM {Table.Upload} WHERE id = @id" idParam return Ok path.Value else return Error $"Upload ID {uploadId} not found" } diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 6e1c6ab..9e5c11e 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -11,33 +11,33 @@ open Npgsql open ThrowawayDb.Postgres /// JSON serializer -let ser = Json.configure (JsonSerializer.CreateDefault()) +let private ser = Json.configure (JsonSerializer.CreateDefault()) /// The throwaway database (deleted when disposed) -let mutable db: ThrowawayDatabase option = None +let mutable private db: ThrowawayDatabase option = None /// Create a PostgresData instance for testing -let mkData () = +let private mkData () = PostgresData(NullLogger(), ser) :> IData /// The host for the PostgreSQL test database (defaults to localhost) -let testHost = +let private testHost = RethinkDbDataTests.env "PG_HOST" "localhost" /// The database name for the PostgreSQL test database (defaults to postgres) -let testDb = +let private testDb = RethinkDbDataTests.env "PG_DB" "postgres" /// The user ID for the PostgreSQL test database (defaults to postgres) -let testUser = +let private testUser = RethinkDbDataTests.env "PG_USER" "postgres" /// The password for the PostgreSQL test database (defaults to postgres) -let testPw = +let private testPw = RethinkDbDataTests.env "PG_PW" "postgres" /// Create a fresh environment from the root backup -let freshEnvironment () = task { +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 @@ -50,12 +50,12 @@ let freshEnvironment () = task { } /// Set up the environment for the PostgreSQL tests -let environmentSetUp = testTask "creating database" { +let private environmentSetUp = testTask "creating database" { do! freshEnvironment () } /// Integration tests for the Category implementation in PostgreSQL -let categoryTests = testList "Category" [ +let private categoryTests = testList "Category" [ testTask "Add succeeds" { do! CategoryDataTests.``Add succeeds`` (mkData ()) } @@ -117,7 +117,7 @@ let categoryTests = testList "Category" [ ] /// Integration tests for the Page implementation in PostgreSQL -let pageTests = testList "Page" [ +let private pageTests = testList "Page" [ testTask "Add succeeds" { do! PageDataTests.``Add succeeds`` (mkData ()) } @@ -219,7 +219,7 @@ let pageTests = testList "Page" [ ] /// Integration tests for the Post implementation in PostgreSQL -let postTests = testList "Post" [ +let private postTests = testList "Post" [ testTask "Add succeeds" { // We'll need the root website categories restored for these tests do! freshEnvironment () @@ -358,7 +358,7 @@ let postTests = testList "Post" [ ] ] -let tagMapTests = testList "TagMap" [ +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 ()) @@ -416,7 +416,7 @@ let tagMapTests = testList "TagMap" [ ] ] -let themeTests = testList "Theme" [ +let private themeTests = testList "Theme" [ testTask "All succeeds" { do! ThemeDataTests.``All succeeds`` (mkData ()) } @@ -462,7 +462,7 @@ let themeTests = testList "Theme" [ ] ] -let themeAssetTests = testList "ThemeAsset" [ +let private themeAssetTests = testList "ThemeAsset" [ testList "Save" [ testTask "succeeds when adding an asset" { do! ThemeDataTests.Asset.``Save succeeds when adding an asset`` (mkData ()) @@ -508,8 +508,49 @@ let themeAssetTests = testList "ThemeAsset" [ ] ] +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 ()) + } + ] +] + /// Drop the throwaway PostgreSQL database -let environmentCleanUp = test "Clean Up" { +let private environmentCleanUp = test "Clean Up" { if db.IsSome then db.Value.Dispose() } @@ -523,5 +564,6 @@ let all = tagMapTests themeTests themeAssetTests + uploadTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index 867d542..2897ea2 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -18,14 +18,14 @@ let env name value = /// The data configuration for the test database -let dataCfg = +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 data: IData option = None +let mutable private data: IData option = None /// Dispose the existing data -let disposeData () = task { +let private disposeData () = task { if data.IsSome then let conn = (data.Value :?> RethinkDbData).Conn do! rethink { dbDrop dataCfg.Database; write; withRetryOnce; ignoreResult conn } @@ -34,13 +34,13 @@ let disposeData () = task { } /// Create a new data implementation instance -let newData () = +let private newData () = let log = NullLogger() let conn = dataCfg.CreateConnection log RethinkDbData(conn, dataCfg, log) /// Create a fresh environment from the root backup -let freshEnvironment () = task { +let private freshEnvironment () = task { do! disposeData () data <- Some (newData ()) do! data.Value.StartUp() @@ -49,13 +49,13 @@ let freshEnvironment () = task { } /// Set up the environment for the RethinkDB tests -let environmentSetUp = testTask "creating database" { +let private environmentSetUp = testTask "creating database" { let _ = Json.configure Converter.Serializer do! freshEnvironment () } /// Integration tests for the Category implementation in RethinkDB -let categoryTests = testList "Category" [ +let private categoryTests = testList "Category" [ testTask "Add succeeds" { do! CategoryDataTests.``Add succeeds`` data.Value } @@ -117,7 +117,7 @@ let categoryTests = testList "Category" [ ] /// Integration tests for the Page implementation in RethinkDB -let pageTests = testList "Page" [ +let private pageTests = testList "Page" [ testTask "Add succeeds" { do! PageDataTests.``Add succeeds`` data.Value } @@ -219,7 +219,7 @@ let pageTests = testList "Page" [ ] /// Integration tests for the Post implementation in RethinkDB -let postTests = testList "Post" [ +let private postTests = testList "Post" [ testTask "Add succeeds" { // We'll need the root website categories restored for these tests do! freshEnvironment () @@ -358,7 +358,7 @@ let postTests = testList "Post" [ ] ] -let tagMapTests = testList "TagMap" [ +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 @@ -416,7 +416,7 @@ let tagMapTests = testList "TagMap" [ ] ] -let themeTests = testList "Theme" [ +let private themeTests = testList "Theme" [ testTask "All succeeds" { do! ThemeDataTests.``All succeeds`` data.Value } @@ -462,7 +462,7 @@ let themeTests = testList "Theme" [ ] ] -let themeAssetTests = testList "ThemeAsset" [ +let private themeAssetTests = testList "ThemeAsset" [ testList "Save" [ testTask "succeeds when adding an asset" { do! ThemeDataTests.Asset.``Save succeeds when adding an asset`` data.Value @@ -508,8 +508,49 @@ let themeAssetTests = testList "ThemeAsset" [ ] ] +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 + } + ] +] + /// Drop the throwaway RethinkDB database -let environmentCleanUp = testTask "Clean Up" { +let private environmentCleanUp = testTask "Clean Up" { do! disposeData () } @@ -523,5 +564,6 @@ let all = tagMapTests themeTests themeAssetTests + uploadTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 7e7dba7..828a07b 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -10,20 +10,20 @@ open MyWebLog.Data open Newtonsoft.Json /// JSON serializer -let ser = Json.configure (JsonSerializer.CreateDefault()) +let private ser = Json.configure (JsonSerializer.CreateDefault()) /// The test database name -let dbName = +let private dbName = RethinkDbDataTests.env "SQLITE_DB" "test-db.db" /// Create a SQLiteData instance for testing -let mkData () = +let private mkData () = Configuration.useConnectionString $"Data Source=./{dbName}" let conn = Configuration.dbConn () SQLiteData(conn, NullLogger(), ser) :> IData // /// Create a SQLiteData instance for testing -// let mkTraceData () = +// let private mkTraceData () = // Sqlite.Configuration.useConnectionString $"Data Source=./{dbName}" // let conn = Sqlite.Configuration.dbConn () // let myLogger = @@ -37,11 +37,11 @@ let mkData () = // SQLiteData(conn, myLogger, ser) :> IData /// Dispose the connection associated with the SQLiteData instance -let dispose (data: IData) = +let private dispose (data: IData) = (data :?> SQLiteData).Conn.Dispose() /// Create a fresh environment from the root backup -let freshEnvironment (data: IData option) = task { +let private freshEnvironment (data: IData option) = task { let! env = task { match data with | Some d -> @@ -63,7 +63,7 @@ let freshEnvironment (data: IData option) = task { } /// Set up the environment for the SQLite tests -let environmentSetUp = testList "Environment" [ +let private environmentSetUp = testList "Environment" [ testTask "creating database" { let data = mkData () try do! freshEnvironment (Some data) @@ -72,7 +72,7 @@ let environmentSetUp = testList "Environment" [ ] /// Integration tests for the Category implementation in SQLite -let categoryTests = testList "Category" [ +let private categoryTests = testList "Category" [ testTask "Add succeeds" { let data = mkData () try do! CategoryDataTests.``Add succeeds`` data @@ -166,7 +166,7 @@ let categoryTests = testList "Category" [ ] /// Integration tests for the Page implementation in SQLite -let pageTests = testList "Page" [ +let private pageTests = testList "Page" [ testTask "Add succeeds" { let data = mkData () try do! PageDataTests.``Add succeeds`` data @@ -320,7 +320,7 @@ let pageTests = testList "Page" [ ] /// Integration tests for the Post implementation in SQLite -let postTests = testList "Post" [ +let private postTests = testList "Post" [ testTask "Add succeeds" { // We'll need the root website categories restored for these tests let! data = freshEnvironment None @@ -530,7 +530,7 @@ let postTests = testList "Post" [ ] ] -let tagMapTests = testList "TagMap" [ +let private tagMapTests = testList "TagMap" [ testList "FindById" [ testTask "succeeds when a tag mapping is found" { let data = mkData () @@ -615,7 +615,7 @@ let tagMapTests = testList "TagMap" [ ] ] -let themeTests = testList "Theme" [ +let private themeTests = testList "Theme" [ testTask "All succeeds" { let data = mkData () try do! ThemeDataTests.``All succeeds`` data @@ -683,7 +683,7 @@ let themeTests = testList "Theme" [ ] ] -let themeAssetTests = testList "ThemeAsset" [ +let private themeAssetTests = testList "ThemeAsset" [ testList "Save" [ testTask "succeeds when adding an asset" { let data = mkData () @@ -751,8 +751,69 @@ let themeAssetTests = testList "ThemeAsset" [ ] ] +let private uploadTests = testList "Upload" [ + testTask "Add succeeds" { + let data = mkData () + try do! UploadDataTests.``Add succeeds`` data + finally dispose data + } + testList "FindByPath" [ + testTask "succeeds when an upload is found" { + let data = mkData () + try do! UploadDataTests.``FindByPath succeeds when an upload is found`` data + finally dispose data + } + testTask "succeeds when an upload is not found (incorrect weblog)" { + let data = mkData () + try do! UploadDataTests.``FindByPath succeeds when an upload is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when an upload is not found (bad path)" { + let data = mkData () + try do! UploadDataTests.``FindByPath succeeds when an upload is not found (bad path)`` data + finally dispose data + } + ] + testList "FindByWebLog" [ + testTask "succeeds when uploads exist" { + let data = mkData () + try do! UploadDataTests.``FindByWebLog succeeds when uploads exist`` data + finally dispose data + } + testTask "succeeds when no uploads exist" { + let data = mkData () + try do! UploadDataTests.``FindByWebLog succeeds when no uploads exist`` data + finally dispose data + } + ] + testList "FindByWebLogWithData" [ + testTask "succeeds when uploads exist" { + let data = mkData () + try do! UploadDataTests.``FindByWebLogWithData succeeds when uploads exist`` data + finally dispose data + } + testTask "succeeds when no uploads exist" { + let data = mkData () + try do! UploadDataTests.``FindByWebLogWithData succeeds when no uploads exist`` data + finally dispose data + } + ] + testList "Delete" [ + testTask "succeeds when an upload is deleted" { + let data = mkData () + try do! UploadDataTests.``Delete succeeds when an upload is deleted`` data + finally dispose data + } + testTask "succeeds when an upload is not deleted" { + let data = mkData () + try do! UploadDataTests.``Delete succeeds when an upload is not deleted`` data + finally dispose data + } + ] +] + /// Delete the SQLite database -let environmentCleanUp = test "Clean Up" { +let private environmentCleanUp = test "Clean Up" { File.Delete dbName Expect.isFalse (File.Exists dbName) "The test SQLite database should have been deleted" } @@ -767,5 +828,6 @@ let all = tagMapTests themeTests themeAssetTests + uploadTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/UploadDataTests.fs b/src/MyWebLog.Tests/Data/UploadDataTests.fs new file mode 100644 index 0000000..636a9f6 --- /dev/null +++ b/src/MyWebLog.Tests/Data/UploadDataTests.fs @@ -0,0 +1,95 @@ +/// +/// Integration tests for implementations +/// +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" +} diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 7b0f796..c8a9ef1 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -15,6 +15,7 @@ + diff --git a/src/MyWebLog.Tests/root-weblog.json b/src/MyWebLog.Tests/root-weblog.json index 2b86eda..ccf1b6a 100644 --- a/src/MyWebLog.Tests/root-weblog.json +++ b/src/MyWebLog.Tests/root-weblog.json @@ -368,5 +368,13 @@ ] } ], - "Uploads": [] + "Uploads": [ + { + "Id": "XweKbWQiOkqqrjEdgP9wwg", + "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", + "Path": "2022/06/favicon.ico", + "UpdatedOn": "2022-06-23T21:15:40Z", + "Data": "AAABAAQAEBAAAAEACACrAgAARgAAABgYAAABABgA8QQAAPECAAAgIAAAAQAYAJ8HAADiBwAAQEAAAAEAGAC3FQAAgQ8AAIlQTkcNChoKAAAADUlIRFIAAAAQAAAAEAgGAAAAH/P/YQAAAnJJREFUOI2Nkb1rU2EUxn/nvDc3uTGxqdaPtipVo2L8GLQUcRAVRVAEEfwLFFyquLgI0sHNQZFuDoIUCi46iCgqrh0Lgk5KbWuTkFTz1SSmt/e+DrcVpUM98JyXl8N5eM7zyMRE3qoKooIAD0efk93rsGdgPXuyA6xVTr7QRo0gIqiAtS6eF6daraC6a22CQqmDqkQQwQ8cPC9OvVpERNYmKJZ8RAWjkYpFP0Y87lILLKr6HwrKS6jIHxWtTgw37hKErCKo1Wv4vk/Pxp6/TwgxKqiCqLDQdoi7MYIQrLVUKj8pFOZoNBf48O4tmUyG02fOUa/XeP/2NU5x3mKWl1Us7uJHEvGTdDqLlMslxseeUirk8X2fhJcglU7z4tk4jXqDzq82TnF+OQEFYyxnuyaYm06zb3cPjx7cZ+j4cbLZLO12m2IxT35mllq1yoq9YrZPWpFIAQBBhdGRr1y5fImu9RmMMQBYLKUfRX7O/6BaqzHzbZowDBDZ8dlGVFGzfpM3Yz5fvkzxfWqSwPfp6s4QBAH92/oZOnYMz/Ow1hKGIQ4msbId1ZJgTIWDh4/Qv9kjl8v9Gb15/Yrhq9e4fvMGBw4dolGr4FiTWLkmeoyh9avOppRLs9n6J8rzFy5y5Ogg9+7ewVrLho0bUNTjH5gUzZbixl0skcF/o7e3j9HHT/CSSebLJVS1RXe6ys6+IoO5AqdO5PGSHq7rImJQ1VWIOQ53Ru6RTK3D+fTSx5gYYjxEDCKKvyQYJ4aog6gigLUgEqUhCFu3bGX41m0cqylCMdjAkp+bZXZminK5TLPZondTetkDiyJYLEr0xwr79x/gNzoU7W4mtXWQAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAEuElEQVRIiZ2Uy4scVRTGf+fcW1X9mGmT6WRIJqPmpdFEBUMwIELEB1kEdZFFcOlCUBE3gq5cCAE3+Qtc+EREd6IbcSPBB75FUYwzmUwmiZlJMv2Yqe7prqp7r4vumYxGBVNwoYq6nN/9vvudI19/fTGICCIgIthImZ1t88ZbJ9m9p0PwGZvrCYfuO8D1PLbZyhARVARRMEbpdBzGxjjXpVqtEEJBURREUfT/Aa1WhuhVBcYInY5HNcZ5oVKpglui3+8Tx/F1KGgXiA6Kq4JRJe16EIt3QqVSpru0TK/Xo1arXQdgqRjYI6AqqHrSjscT4ZwZ2CJCv99HRP4/oNV26NAeFUGM0Ot5nDM4b7DWEkRwzl0nYMkPAas2CVkeyJzivCWKDAQhBPlXQHelS/CeanXkb39kAFgtLhpQEZyDLDc4b7GRBRF8CGuANE1RI4BwaWGBH374lhAChw8fIQSP94E8zzh9egrbHCpQ0QFIIQToZYrzhsiagbwA3W4HBC5fnmdu7ixpmrK42KDZuEJSKjE19RuI0Gw0mJ2Z5szpaWxrGRQQCcO4BjT0oD9L1nXE0TYExQdPo9lg6tRvXDg/x+zpGVa6XcqVChvGNlIql/n1l5/ppintZosL58+hKtjW0tCe1SQJlLXF7fEnjJst9Hqb2TZxA520wffffMHcubPMzcxgjSXr9ymKAjOrVEZrVMol0qUlBEFVcR5sc0nWADq8g5SEejlmnMssXJim3WwxdeoUCwvzHLz3Xo4de5yxsTpFXjC/8AfT01PMTE9zfu4cnW4Xo2btviS++fsgg/ta6wfnHdaf55FDZ3jwUIXdO3cxtrFOqVSivmkT9fqmtZz08y5n584yf3GexStXaCwu0lhs4JwDAjb3djVRgCBACBFZuJE01Ng6qVxaXOannz5lud0ispakVGK0NsrWyW3cvf9uNtbrJEmJiclJXFHQ7/cJIRBCwKLx+tgSYJB7B7lLKJcjen1FTJUtE1W6nQ7GGHwQvvr8S95+7XX23rmP+w7dz/bt2/HOkSQJIQS8c1g0Yp2Eq6+FkLsIY4Sx+mY67QV2bt/Chg0bCMOeyPYfYH7+Ih99+AEnjh/nrv37eezoUcbHx+l2OqTLbWz4JwACquQuxntHFFsQJc9zkiRZ25UkCSOjozz9zLN8dvIk77/7Nj9+9x0Tk5PsuW0P45vHsEi8rvY6iBqKEFP4HpXIIqp4H64ZFwKUyxUeeOhhduzcyYlXjjNz6nfO/D6FsRZFI5C/LY3AxDg/mKg2sojoun65dllr2X3Lrbz40suYyA7SWOQoGnN1DYqLRqAJLsQUhRJFFtHByPgviKqyY8cOnnv+BTSyJKUEO76xSTXJqZQdI+WC0aqjNhKolj27bhJGayMYtaiaNRWr1oS/GDX4Msawb+8dPPHkU7z3zpvYj1/NUGMwJkLUoqoABIQQwHtQoxhjBn0ybMbhpnW15Wo+xHLgwEEuXVrA2qT2F+nOe5xzeF/gnSMEj6oly3JEysjwAITBkEUCghAkIEHWOEkSc+TIo1hrDVmW02q3WF5u0Wq2SNNlVlZWWOn1yPoZBAeh4OaJe1CR4YHDsO8HxRUdFh/KEiFJSvwJAgAKftfyeo4AAAAASUVORK5CYIKJUE5HDQoaCgAAAA1JSERSAAAAIAAAACAIBgAAAHN6evQAAAdmSURBVFiFpZdrjF1VFcd/a+99z3105k5n2qGBIa1t0UBFAn3ED9AgtrQJoRCI8UGUT4ookRgNglETEhITP2iCMUJMIOKjgIiKgFS0RNsglnFKFZsUMh2gpe1M27kz0/uYe89r+eGce8+9M1N87eRmn7Pv3mv/13/999rryOjoKRURjAEQREAk6X0/ZutHHuHzXyiwfHCAXM7jwMu/4+v33p3MAZS0db2IgGr3uKTjmo2nf7paLUTSzY3Q86yAmDxhKFhrESv09Q8QhiGe53Xsd9nrPIhotrlkyDLYSe9q9RCEzHNSNgRyziLiEUYB1lqMGEp9ZaIoQqRna3rpyNCIgJJtnJAhnTmuWgt7aO/u83kolEoE/jmsNYgIff3nAbCIjqWGZdEUV6uHiEn+aG9OyoLvK/3lEn5QxVoLQN+ygfMD+B+aq9VjEDAdz+kY9zyl1LeMwKcDwFpLFMW0Bau0Q6xouk4UNI1zMqSoprro0QC4aj3CCKkODCKagEDI+VAsevihwVqLokiiUsQkBowqbQMdGYhiMF1+Zsy233sYyDzXJBQmYcFaxcvn8H2TMeBcEoKO7d5QtKH06PE9Q9CIOmdaDIhK5yg6J+Q8RyuwGGsQwPM8ZmZnGRm56D0Nd3C1T2CHHXpOi6vWQYgxRtIwaAeQtYq1Dj+wOGdRVfL5AmfPnPq3Ipybm+PdE8dQVdavu4RisZSAysJPo9FYGIL2SVAExVgBsfiBwZpEA17e48TJ6R4AYRhy+vQUMzMzjIyM0N9f5smnfs7xiQka802++KUvc8n69xOGIcYYxsff5MCrr/DawTFcrZHE3Qhg0hh2AYrU4gcO5yyxKoVCgbNnMwD79v+Za66+mpE1F3J6epIX9+5BEFavXsPWrVvxWz5RFHDs+Fv0lfs5efIkr42N8e7bb+ElGkg2b4u0EwIBYyCIWrQCEg3ESs45KtMVqtVz7N+/j8/cfjtP7N7N4z99DM85rEkSVhhHtIKA/sFBhoeHQZUzU1M0G3X6S32IEVQVV6snLpvUY7rzgU7y4dJjTBZjZiu3MrTyIqwxTM+cIV/IM7RikE987BZiP6BvWQmUznFzkqNYKBJHETt27uTRhx+mlC9QKpQI4wiiRKGyZvOoZrRLD/05jnHzBY9SzAlsuJxLNlyOs5bLLt3A0089yQvPPcvOm27i4OgB5qYr9PeXqddrNOoNcjmHcy4JlbUQhonROBMhgKzYMKrSThQpE+3LyRplvfkqHygrb4YtNFa8nMOJEEUxcRxTazb55G2f5o477qRQKIIqlZkKv//DC+x98UUO/+N18s5hTHdi6gLgrRnTtsemKwRGIAgBqgyX9vPAvSNct+1agmbExNGjzDcaDK9axcaNm8h7+UWG54M6zVaL2coMR944wltHJzhx7Dinp6bwfb+TJEQuPrQoabUV3i4eyqWz/Og7wugrf+TGXddz1ZUbsZhML8ZgJMmWsUT4fotWq8n8fJNWq0UYhqgqJhVo234cRYis/ud5smYWqLyd5iffCyj1Lefc7CyHDu7ntdE/YTTGWYvneTjnyBeLlAeXc9327Xx02zaq1RqtZpM4jpfcIY4jRNYc0YUbLp45yxPfr1IeWAnAbGWaWmWCwcEBTk1NUqtWKQ8MYIxhbPRV3jh8mDCO+Phtn2LTli2sWrVqEQiN4/Raf994L4AlcGjzHL/44RkGhy5EAedyHNj3a2695dbk2k2LQElLsPlWk2ef+RXP//YZSvk8F69byz333YeXzxNFEVEUEQY+vt/CyuBX7kcMKjYtCBf8xEAQc9P1cwwsX55USoUCfz/4Mhs3XpVdZNI+PpBzjg9e/iGu3LSZ8fFx3hkf5/lnn6NRbxDFMYW8R9BqcnZqEqfGLRn3nmY85urCamfRWHHGoJqJ9Xxt3dp13P/At3nooR8w9spfeGnPHl7as4cgjlm7fi1bNl+BQ1xPNbtksx5z1RjnDFGkGGtRNf9RWSYi3HXX3ey99DJ2//gRjBjyRjg+8TbvTLydAli0asGDUeaq4KyD9OrO5wvZcT0/9E7bvn0HQRDw9OM/Q8TgxKAoDrMQwBKmrOFczWCtoGIRY8gXSx0PF69YGtINN9xIFEU8/5tfJlWTxjjEy0oVVSBOem33CnFEtW4wxuDSj5ZisYSqnicMSbJRtPsbBAR27bqZycmTHD40Bqq45cWjDPW36F/WYrAcMViOGRqIGR6yDA85Vg4ZigVHubwKMRYjYMRQLC3rMLCQu/aegkHTIlfblaKBz332Th588LtMnXgHOfj6GyrGYo1DjEOMQcSCQqwZCYkXWdL821/3c+01V6XFalJFaRuGauZ1G1ynhE+YCcOQb33zazibG+jMUBLms0Vd13PbSuqxcW4BA11aaI8tiE6n6EHI5XLcc883cO1yO1uXxM9YizXJBWOM6Vw4URRwemqSE+8eR+SK/+sLaeXwMM5ag6oyPz9Po1GnOd+gUjnLqZMnOD01xZkzU1SmK8zMzNBo1EFhxYoL2LljK866/+ooLjXrXzMv8sJi1rtuAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAEAAAABACAYAAACqaXHeAAAVfklEQVR4nL2beZRlRX3HP1V3eUu/fv1ezwxMz0JkURhgGGBmUHQgJiyGgB5jgnpOEojE9ahDxEMAVyIqUTxoAggHEnCJEkhU0CRoouYYhkEGFJgVRgaYpRdmuqf3fstdKn/UXere97pnjCfWnJp7X9Wv6tZv+/5+Vfe2+OUvX1EAQkB6FUf1W0rB29/5A3bv3sqfXVlj+cploBRxEUIwPLSPY+ohl156Kb/tIgB1BAK73Q7S30IvOr7PM66UZlpfNW2p5AAOga+wpESp7CN7eiocOrQnkbCI+pXQCwQ9r4gfED0XZdAozUhKEtGpiMWkQ8SXhHGhcs8ivtcddqsdGkzqCWPijBDiSYRI1iiFoFB0UVgEQYgQAqUUQggEAoXCth1GR8eSORNBmIoQ+ZvoefFqDQaSh2fuI65RqQLNecxnJXcShNIWkNV63grmcwNtDYWihcIh8EFKmXmaRGLZNuPjExlmVay5aE6lTC1G/CAizalUJUIhI412Y8m8jxWgrUklLdq4onsEdrsdpprNMXhkwQhc1wEsvKCNlAJCmVmPZVuMj08kQjQFmgol/2DzIjJs5TXaKQSzNTdvMmMsBLDbnopoVPahkfNlta+yQhIC17VR2KjQ05Pm1mJbNuPj4/Mu8kglC2Sp5eThrRvgdQdB3SpjF9UuEHfkzf7IVuAWLBQ2oRKgQu0GRrEdh6np6cTK4qJQkY8nkAQoRIxYKVqRozD0mM6mW1JKkaPuFIKmt9tt1aHt7oKIr7HF6IaCaxMqmzCUmCAUz2NJG8uyyZuGyNlywlR2eJdFdyv5ubu3dyt22wtT8gRJ499meycoAriuBTi0PQ1mQsrMY6W0cWyHiYkJ6rUaSggdmmLtiOgustUY4FIIixpUBIYiig6oFAyT0BdRqzQq6O4udhDNEYXBmEEdcIXUyKmvecZVRiCWo12g1dLIakkZxW0VCUBSKvcwNjZGvV5PIleMwwmLWfwzWU8eHiN3PECkpNmxXUDP5Dt9nsD2PJVIyhTEkd1C9zmOBcKh3YokLjS5REa0kr5aP2NjY5x00kmZ5chYQ8lQgRIqXaW52nyGk7CW6jcZa4B2EkKVyopD6Da71dYuECnbEIJJroxkSNtgvC7LtgBJs6UxQIpcLiAEtXo/o6OjBj50YSBZ1zw4kAuRmTliwzBTPnKm3yUBQyQgaBheAnLMc00TGADbkoCk1ZYoEWq3SZYmEEJQqy1mdHQ0v/IuXHbvXTCfN6cQ3ZvnHyN0HtDBtPGjOxCmQpOxAFoSoSILMJ4uhKDev5jR0X2JCcdzJhYe5/G5RXfG9TxFF2/J9ySbgu5ysNttZeKKZkpoDJYmshpmbwpKCAFC0ogwQOY2RDISwN49v8w8I3PbzTyN36KjZSGaXM/CBobdivKAvKmn92pBKxAydgFLQ46IhZJO1L9oCZNTU8mChNJgl5p3NK9SOkzSLd9LQUxFCZOKgCwGT5HggdL7DWFYR2JlKgVcwPb8MMOcvjcQ07COzqvCtgUIi2ZLJ5dJHmCYXr1/Ca1mk1AprAgku+VzyU7TaO+mfZFZl0jbErJsSt5BZ5DabS9l2hwYm31Mrd1Bu0WiMYEGPdui0bQQQpt8nrNyuUyj0YAwBMvKHpqQ7vUh05X2mqYQz2seEHQhTYbE61XpBCK2EJ0IdWZ+CXPRWNN3RfT0dAenKJUcGlMSKUVi/qZmhQDLdgiVwjYflDusyK8hw3Gu3XEdtm3bSrPR5KRXn0Sl0ttBmh1iPihWtMBut03/N6wg0xYDXjpt3I5QFEsOjcOSIABt4bnVKnALZcIwzLaLDr6OqmzdupUf/Nt3WbtuHZVKhX+8727OP+/3OOvMs+cflPU1PK/N4bGxOAzGzOp8XsYpsNTEWcvIuopSioJrg7RoNBVCSCOJSgcWi6WUaUPtca6mkixXm6tKcCI1EwV8/+HvIS3FkmOO5T8feQTbtvnTK67gW9/8JmeuORMprXhiMjE3Ki+/9CL/8p0H2bv3JXzPj84DTPDJxf/OMwHDKoR2a9e1AUmjGSCif1m7hlKphzAMO/oSMBTw4ot72LlzBxOT4ziOQ+AH+L5HrVanUumlXu/nZz/7b0589Yns3r6dWrUCCHZs38HAsmVZ/BBgWTZDg4MMDg2yc8c2JqYnOPbYpWw4bwOokOED+2MQjHw6QnZTACmCdg+HQQi2Y4G0aTYDjQPGmYD2JkWpp4JSYWRlgjivUEowNTXJLbfczCmnnsJ1N1yPEIJWs0Xb8/B9HxUqdu3cya9+9SvOXreW3c8/T1vB3pFDWFIysWULrVaLb3zjPprNBgcPHuTQoYM0Gg1OX72aDRs28K53X4Xnedx155386JH/YGDRInqKhXwUoIu2IwGZoYc0eZIW2JYWQKPRRghhRIKEmr5qPzMzs/T2VjNYcuedt7Fs+TLuuOMuVq48joA2jz76KJs3b2ZkZISp8Un8IKBYKtLb20t/vc6fX3klK1esYMXKlbRaLaamppiZmUEpvRstFAr0VqvU63X279vHk089xS1f/CJ7du/GFnBMrYbv+wDZvUB35smAlZARR5GSrUDpdFjYEQYIhMieCgHU+hcxPDzMwMAAAIcOHeSrd97ODTd8jHVrz2F2dpaHv/89PnvT3+C1WlSKJWx99q6tKIowfhjy7w89RDOyjv5FixgYGGDFccdpRURlcHCQF3bvZm5ujmpPmUqpTNlxUCh8z0+iqt32RYdpZ10g9YUkLBo+nJi8dJlr6oVKY0MUE1erfQwNDbF27VoefPB+/NDj3nu/Tl+1j/u+9g/cf/+3mR4bo2w7iB690Ew8j1DSlhKnVKK3XCYIQ6bm5hgfH2f7tm0sqddTABeC3mKRarGIQhEEAUqphPH4UEa22pBWRasNbY/06inavqLtQdvXbboKfF8QTH2b1Ytv5NyT/5WpiWGkEJEVRDViolgssX//Pu644+9ZedxKbv7cLezbt5e3/tFl3P7lW/FnZim6biaC5LIJ4mMWpRRhVC0hWHXqKv7pgQewSyUE2gUFEIYhQRASBtE1VKgwRIWKQIX6BOuUN2xJEybDCrKhL23L5ALtRzi//1EGesqEwFMjhygtfxVvvPCt9FYXJ+NtC+7/1p1UKzZf+fJt1Gp1bvnSF/jOg/+MJSWzzSYC6Cv3pGwamZ8wbpJ74xIqRX3pUjZu3Mg1GzdSr1RIjCYqmXBrivWEc55UyfEXhpknV5H5bQrH9b7H+YueYEW1igJavs8+x2X1urWMjo9T7lmMLSEIW1xwwYWcs/51jI6NcuPffIItmzbp7FBKbrvjdp7b9Ry33XorlWIpk+123c9mCRACZnyfguMgggCZHHpnS3IOaZTovYCZB8RXkfutn2z+tpw/ZN/Ej1lSKuM6NpYQLF16LO945zvo6eujt9wPKMIwwPN8vvmtr/HlL32JeqVCpVyhiaI1O8vTTz/D3XfdRbVYRhHSVirZUscRxYp3n5EWE2wAVAhFIZFBSMZVYksyiPNiEUtOe1JlmDYRPy8MQ/rxEdrxhb9mVcGj4DrUK2V+PjqKVSrQ01PBth1CFK1mi7FDB1FBSKlYjFaiaIUhQRCAUszMznLcq36HK/7iKtacsYZKpYoKQ5rNJodGD3H48GF27NjG1mefYce2bfieT6lQoFQooLe2YZJNHvkIyRBA32ueVPkXiok75Ew+7x4gCFtPcHr1bvqlRVPAopNfzcTEBIHvoYIQv90i8IN0c4VAhSGBUoRBgF0ssmRggI0fvprXn7vhiAsOCfDDNlueeIJNjz7G5s2bmZ2epjkzC2GIFKLj5cyCAigd/5Ra2Oy7mH/U2GgEeAH0lfZRlT+mrzLMu654A+//4AeYmpjUyUZgMfLKEI9t2sSWJ3/O+OFx+mp9nHbaai688CJOPOEkFi1azNGWtt9krjmH53v4no/veUxMTjI5Mclzu3bx+OOPs+XxnyNQuLZDwbGxpBW5kuiYT9grf2GcX+XNXxi7wKyA/EDheeZMFsf0Pstl5z1BqRjwnve+l9ec/Bpcq5SeE/6GRSnFXGuatufhtds6VfZ8giAgCAKklFi2heu47Nq5k+HhYfbs2cP44cO02u2sZygVnWCteHpBj0nDYVZ6+XACFot6tnHjR0v016t898HbWbPmDK772PWEPhSc4m/EfNtv0vZaBBGg+p6H53n4vmY+DMMo0VFHhQEqDPXmTKx4Jj1S6bAQMf9k0R4hLRa10i4+/RHBCSe8CpRi1/an2LZ1M2eeeRoXXXwxfjtI0uRioYi0JK5boFwqUa/Xcd1C5hEhPs12Ez/wUKFObMIgwA98PM8n8H18XzMfqlDvnDs108m8UqB0dmgjrIWpO91mng5JEDoEQRspJWEYsmr1ek5dvZ6DI3u59pprGRkZoug6CAVBGKKAUOkMLYgiQqFYZGDpUk49/XROOvFE1p2zjoGBZTiugxCSwI9M3g8IgkjrSh0183rpIomlQhy349cJGgv0Scr2Hm68eprTTj853ftHxbItvvPAfcxMDrH7+V0UbJuC4+h3iXFRsUB06uoHAX4QUCiVOGZgKedueAOXX345rlug0WhozUemD0cvAC00PdYSfR+6Md616y2e+D9WiRTTnL9+lmXLjo0+eyGSst4hzsxMI8IWn/nM53CKJeZaTYTrYrkFhG1jFQr0VPso9vbSU6tRKJf0mUOrTXNmhm1PP8O9997LyCuvsGjxYnp6yli2nVrBUTAe3SQWc2QX6CjzWYEgCPTBJ3SJxUKxdOlyXnz+KRzX5c2XvYU3X/YWnbEFAUEY6peVjpNEmyAIaDab7N+/l9tu+wpzh9ss6avxi02PsWXTYzilIn9wySW87fI/QQrZeeaYZz4SlFIqspwQS9Q23pjXpKG6X6NKlJrjgtdOMzCwOLsjjGq5VOaJzT/hwgsuyIhTSIllWViWldmSSylxXZfFi5dw6aVvZvnKlewfGmRiYgLXshBBwNZnt/L9hx8mCEOWr1hBpVLpEETMfKjinWFAEPj4vo9EWGSrTCvGfQdd57gwdFHRoZqUMlOFEFTrdSYnJyOZRRvexEW0ONL8QySyjW9e99rXc/Pnb+Hqa65lxvMIlKJcKOAi+OFDD/Geq67ih4880sG8UoogDJIzxna7SavZpDk3h1RCkq1WthJXaVSR/R2N1V+KSFBRSir0gUlcBYJWq526kbm5ICeEpC89U4hv1q5bzz333Mv6Decx227Fo6mVynzt7nv49Cc/yU9/8hPCMKRY0KE1DEJ8v007Ynx2ZoqZ6UlkRuNCHqW5d7EUJAiH6Tm9G4mBTyTalDr65PbyuYOHDMRkdyimqKC30sv73/dBPnXjZ2kLkQBcuVDglZf38vV77uHtb/tjPnvTTWzb+ixTU1Na660mM9PTTE1OMDE+hp0c7plF5LdUC4U/k8xmtmFpAcj4C5E8TfzewDizzxClQtBwar74zu7nBbBq1al89at3c8cdf8f2Z5+haDsopSg6LkXH5fmtW9nx9DMUesr0VqusWXMGa1avotVoMDs73c0CYhA0NNsl5HWtwmF2zkJ/YhMfTcUWkJp4p1C7CzhvAd3oBNDT08N1132cN15wESoC0hhMLcui4DjQ9pgZHeO/HvkRf/uFW/npzzYxfvgwNke9UTkKKxAW03MRBuS+FImvth2d+xnfL4j4UC7zCEPzxldf5meucd4vhUQJ+Mt3v4/168/h5s/fRG/B2HsY85YKLih4Yddudu9+Id7/ddOqZdSjSZAkSMnMnE2KAQIZmXx82FKp9OJ5XicOdsg3hw05USa/jEMcAaxZcxbXXf8JGr4fvazNz6rXYkmJFSozDC4Ehl3cpCM0aqHNRBiQhD8p0oqgr1ZnaGgoy70wbQQDDKMoIOahTZg330oLzjprLZ/81GeYarUQ+XWI1B2lFPNgwBGZnUdo0mZ6NisAsyKg2ldjcHAwmwdETMcxXySaIsGNrrSJFXTIk1NWreL6Gz5Bw/OwbUsfikiJtGT07iJa17yA1lEXsoS0zsxZQGgYUDYb7OurceDAgYzddzusSZ0rC5qiS1/yf2wF0ZCzzzqbK696Lw3Pw7J1timjrDO2jBwIHmW4m68Ii6k5GxFZQCdL0NdXY/DlnR0HLcnHKLnPvbJH2Z0EWSHE4JgK4eKLLkaFAQ98+xv0FAqEoQ7vYfThZM4FxBHqkVzDZmrWikzVDH8pEPbV6hwYPNBFeLlrjsFOwm4thjAMsje96RLOWvdamr6H7dhYtoUTXY/sAgZzXTGAAFQL1AyEk4RzUktXSoQV+3+aDvfVDAwQIhFWDGoJoCE63Cehj3wgblNGlEnGmuMRbPzwRzjn9eejBDiOjR1XwhaEPoQBqEC/ZVBh9DsEO8Ap+JSLPuWCT6mkr+WCT7kYUCqGlAoK14FSUeE6AiEXRS8pU3SKtVKr9UcYYGhNGAqLh8zrjabJg5kdJtfoDbbOGFRC/K4rr+KvnnmaQAW4jq0d5sxL/kf194XUq4r+WkilpKhXFfU+RX9VUXBTn7NsB9t2sC0Hy3GwLP23AJZt4ziubrd1FDAPKEwznp2d4fc3nM5zzz2XLtAUUv4TL2G8IFPxTNn0OD7XF2S/D8x+YJ0mU9d89GqKMiAIFeKxJ3cq/W1f7KtRrp7cSyyZfveTAagupzCdH0Rn+6S0WHv6crZv347jODmKHAL+P5WXXn6Rj99wLcevXIYsl/soFasUi70UCj24hRKOW9QatW0sS8dv05RMhpKMz9j3z1dB5+1SSmZnZ7ssLW/e8xQhOmlM1zHCqsiTCDjh+BP46LXXMzkzixRGliStzuQlf6hhMnu0fZlkCFg6sJxGo6HXKUzAIsno6Ap+cWyhs98ETwMEySkgBty1Z6+nUu3H7jDZbtLNSHABE++iqXxRKJYtX6ktoMOt8gGty+y/iYcY6xFC8IEPfAg7n7CIeQYcYb6OlS3Ut2zZSuYac9kFRZ8Dpq94DfxK+rOv8rtuGOnS2VF03/HHn4Cdbluz+CoSSI77FgI38wzQ0tWSWNJCSMH01CRjo4cYPfQKExPjTEwcZnpqmryMulmYyPR3ZEmZNczbuUC7HftNXGR+AZH/KaUIAp8gCKO3Mj5+EBCGPr7nMzR4gP0H9jJ4YC8v73mB/fv2Mji4j5HhQUBg2w69vTWWDizjjb97LmecsSZZTvTZYLLXV/qBKWcq+kYxyStU7g/Dos/l049KDdWJ5A+ulSFNgSYWz710OIll09PTjAwPcfDgMAdHhjl4cISDr4wwMjzI+PgYjUZDv0+zXWzHxZIujlPALRTprdbp6enFcQv09JSp12v01/uo1ar09vZSq/ZSqZQ49pg6PWV3Hu389sv/AjBdvhBnmBuqAAAAAElFTkSuQmCC" + } + ] } \ No newline at end of file -- 2.45.1 From ac9df44904f498e17b61100254d09a790a5ec82d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 3 Feb 2024 18:17:26 -0500 Subject: [PATCH 079/123] Add user add/find-by-[email|id] tests --- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 29 +++++++ src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 29 +++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 43 ++++++++++ .../Data/WebLogUserDataTests.fs | 86 +++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + 5 files changed, 188 insertions(+) create mode 100644 src/MyWebLog.Tests/Data/WebLogUserDataTests.fs diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 9e5c11e..87c45fc 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -549,6 +549,34 @@ let private uploadTests = testList "Upload" [ ] ] +let private webLogUserTests = testList "WebLogUser" [ + testTask "Add succeeds" { + 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 ()) + } + ] +] + /// Drop the throwaway PostgreSQL database let private environmentCleanUp = test "Clean Up" { if db.IsSome then db.Value.Dispose() @@ -565,5 +593,6 @@ let all = themeTests themeAssetTests uploadTests + webLogUserTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index 2897ea2..ac8195a 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -549,6 +549,34 @@ let private uploadTests = testList "Upload" [ ] ] +let private webLogUserTests = testList "WebLogUser" [ + testTask "Add succeeds" { + 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 + } + ] +] + /// Drop the throwaway RethinkDB database let private environmentCleanUp = testTask "Clean Up" { do! disposeData () @@ -565,5 +593,6 @@ let all = themeTests themeAssetTests uploadTests + webLogUserTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 828a07b..0f800c7 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -812,6 +812,48 @@ let private uploadTests = testList "Upload" [ ] ] +let private webLogUserTests = testList "WebLogUser" [ + testTask "Add succeeds" { + let data = mkData () + try do! WebLogUserDataTests.``Add succeeds`` data + finally dispose data + } + testList "FindByEmail" [ + testTask "succeeds when a user is found" { + let data = mkData () + try do! WebLogUserDataTests.``FindByEmail succeeds when a user is found`` data + finally dispose data + } + testTask "succeeds when a user is not found (incorrect weblog)" { + let data = mkData () + try do! WebLogUserDataTests.``FindByEmail succeeds when a user is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a user is not found (bad email)" { + let data = mkData () + try do! WebLogUserDataTests.``FindByEmail succeeds when a user is not found (bad email)`` data + finally dispose data + } + ] + testList "FindById" [ + testTask "succeeds when a user is found" { + let data = mkData () + try do! WebLogUserDataTests.``FindById succeeds when a user is found`` data + finally dispose data + } + testTask "succeeds when a user is not found (incorrect weblog)" { + let data = mkData () + try do! WebLogUserDataTests.``FindById succeeds when a user is not found (incorrect weblog)`` data + finally dispose data + } + testTask "succeeds when a user is not found (bad ID)" { + let data = mkData () + try do! WebLogUserDataTests.``FindById succeeds when a user is not found (bad ID)`` data + finally dispose data + } + ] +] + /// Delete the SQLite database let private environmentCleanUp = test "Clean Up" { File.Delete dbName @@ -829,5 +871,6 @@ let all = themeTests themeAssetTests uploadTests + webLogUserTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/WebLogUserDataTests.fs b/src/MyWebLog.Tests/Data/WebLogUserDataTests.fs new file mode 100644 index 0000000..e3deb6b --- /dev/null +++ b/src/MyWebLog.Tests/Data/WebLogUserDataTests.fs @@ -0,0 +1,86 @@ +/// +/// Integration tests for implementations +/// +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" +} diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index c8a9ef1..407c213 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -16,6 +16,7 @@ + -- 2.45.1 From 16f7396664cb1b7a8ee6d3ef3b781126f40fbd9d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 3 Feb 2024 19:45:29 -0500 Subject: [PATCH 080/123] Finish user tests --- .../Postgres/PostgresWebLogUserData.fs | 19 ++-- .../SQLite/SQLiteWebLogUserData.fs | 21 ++-- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 48 +++++++++ src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 48 +++++++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 73 +++++++++++++- .../Data/WebLogUserDataTests.fs | 98 +++++++++++++++++++ src/MyWebLog.Tests/root-weblog.json | 2 +- 7 files changed, 292 insertions(+), 17 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs index d919d12..8ccf5be 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -10,6 +10,11 @@ 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" @@ -52,7 +57,7 @@ type PostgresWebLogUserData(log: ILogger) = /// 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 id" "id" userIds + let idSql, idParams = inClause $"AND data ->> '{nameof WebLogUser.Empty.Id}'" "id" userIds let! users = Custom.list $"{selectWithCriteria Table.WebLogUser} {idSql}" @@ -80,13 +85,13 @@ type PostgresWebLogUserData(log: ILogger) = | false -> () } - /// Save a user - let save (user: WebLogUser) = - log.LogTrace "WebLogUser.save" - save Table.WebLogUser user + /// Update a user + let update (user: WebLogUser) = + log.LogTrace "WebLogUser.update" + Update.byId Table.WebLogUser user.Id user interface IWebLogUserData with - member _.Add user = save user + 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 @@ -94,4 +99,4 @@ type PostgresWebLogUserData(log: ILogger) = member _.FindNames webLogId userIds = findNames webLogId userIds member _.Restore users = restore users member _.SetLastSeen userId webLogId = setLastSeen userId webLogId - member _.Update user = save user + member _.Update user = update user diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index f87b6c4..35a9cd5 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -10,6 +10,11 @@ open MyWebLog.Data /// SQLite myWebLog user data implementation type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = + /// Add a user + let add user = + log.LogTrace "WebLogUser.add" + conn.insert Table.WebLogUser user + /// Find a user by their ID for the given web log let findById userId webLogId = log.LogTrace "WebLogUser.findById" @@ -58,15 +63,10 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = let user = fromData rdr { Name = string user.Id; Value = user.DisplayName }) - /// Save a user - let save user = - log.LogTrace "WebLogUser.update" - conn.save Table.WebLogUser user - /// Restore users from a backup let restore users = backgroundTask { log.LogTrace "WebLogUser.restore" - for user in users do do! save user + for user in users do do! add user } /// Set a user's last seen date/time to now @@ -77,8 +77,13 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = | None -> () } + /// Update a user + let update (user: WebLogUser) = + log.LogTrace "WebLogUser.update" + conn.updateById Table.WebLogUser user.Id user + interface IWebLogUserData with - member _.Add user = save user + 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 @@ -86,4 +91,4 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) = member _.FindNames webLogId userIds = findNames webLogId userIds member _.Restore users = restore users member _.SetLastSeen userId webLogId = setLastSeen userId webLogId - member _.Update user = save user + member _.Update user = update user diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 87c45fc..5fe858d 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -551,6 +551,8 @@ let private uploadTests = testList "Upload" [ 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" [ @@ -575,6 +577,52 @@ let private webLogUserTests = testList "WebLogUser" [ 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 ()) + } + ] ] /// Drop the throwaway PostgreSQL database diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index ac8195a..604648a 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -551,6 +551,8 @@ let private uploadTests = testList "Upload" [ 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" [ @@ -575,6 +577,52 @@ let private webLogUserTests = testList "WebLogUser" [ 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 + } + ] ] /// Drop the throwaway RethinkDB database diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index 0f800c7..babc8fa 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -814,7 +814,8 @@ let private uploadTests = testList "Upload" [ let private webLogUserTests = testList "WebLogUser" [ testTask "Add succeeds" { - let data = mkData () + // This restore ensures all the posts and pages exist + let! data = freshEnvironment None try do! WebLogUserDataTests.``Add succeeds`` data finally dispose data } @@ -852,6 +853,76 @@ let private webLogUserTests = testList "WebLogUser" [ finally dispose data } ] + testList "FindByWebLog" [ + testTask "succeeds when users exist" { + let data = mkData () + try do! WebLogUserDataTests.``FindByWebLog succeeds when users exist`` data + finally dispose data + } + testTask "succeeds when no users exist" { + let data = mkData () + try do! WebLogUserDataTests.``FindByWebLog succeeds when no users exist`` data + finally dispose data + } + ] + testList "FindNames" [ + testTask "succeeds when users exist" { + let data = mkData () + try do! WebLogUserDataTests.``FindNames succeeds when users exist`` data + finally dispose data + } + testTask "succeeds when users do not exist" { + let data = mkData () + try do! WebLogUserDataTests.``FindNames succeeds when users do not exist`` data + finally dispose data + } + ] + testList "SetLastSeen" [ + testTask "succeeds when the user exists" { + let data = mkData () + try do! WebLogUserDataTests.``SetLastSeen succeeds when the user exists`` data + finally dispose data + } + testTask "succeeds when the user does not exist" { + let data = mkData () + try do! WebLogUserDataTests.``SetLastSeen succeeds when the user does not exist`` data + finally dispose data + } + ] + testList "Update" [ + testTask "succeeds when the user exists" { + let data = mkData () + try do! WebLogUserDataTests.``Update succeeds when the user exists`` data + finally dispose data + } + testTask "succeeds when the user does not exist" { + let data = mkData () + try do! WebLogUserDataTests.``Update succeeds when the user does not exist`` data + finally dispose data + } + ] + testList "Delete" [ + testTask "fails when the user is the author of a page" { + let data = mkData () + try do! WebLogUserDataTests.``Delete fails when the user is the author of a page`` data + finally dispose data + } + testTask "fails when the user is the author of a post" { + let data = mkData () + try do! WebLogUserDataTests.``Delete fails when the user is the author of a post`` data + finally dispose data + } + testTask "succeeds when the user is not an author" { + let data = mkData () + try do! WebLogUserDataTests.``Delete succeeds when the user is not an author`` data + finally dispose data + } + testTask "succeeds when the user does not exist" { + let data = mkData () + try do! WebLogUserDataTests.``Delete succeeds when the user does not exist`` data + finally dispose data + } + ] ] /// Delete the SQLite database diff --git a/src/MyWebLog.Tests/Data/WebLogUserDataTests.fs b/src/MyWebLog.Tests/Data/WebLogUserDataTests.fs index e3deb6b..ab5aa1f 100644 --- a/src/MyWebLog.Tests/Data/WebLogUserDataTests.fs +++ b/src/MyWebLog.Tests/Data/WebLogUserDataTests.fs @@ -84,3 +84,101 @@ 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" +} diff --git a/src/MyWebLog.Tests/root-weblog.json b/src/MyWebLog.Tests/root-weblog.json index ccf1b6a..9c820c8 100644 --- a/src/MyWebLog.Tests/root-weblog.json +++ b/src/MyWebLog.Tests/root-weblog.json @@ -285,7 +285,7 @@ { "Id": "l4_Eh4aFO06SqqJjOymNzA", "WebLogId": "uSitJEuD3UyzWC9jgOHc8g", - "AuthorId": "5EM2rimH9kONpmd2zQkiVA", + "AuthorId": "iIRNLSeY0EanxRPyqGuwVg", "Status": "Published", "Title": "Episode 2", "Permalink": "2024/episode-2.html", -- 2.45.1 From f25426db5c64e316ad637b64195e8259f0872636 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 3 Feb 2024 21:53:03 -0500 Subject: [PATCH 081/123] Add web log tests - Add post-delete rev checks to pg/sqlite --- .../Postgres/PostgresWebLogData.fs | 4 +- src/MyWebLog.Domain/SupportTypes.fs | 2 +- src/MyWebLog.Tests/Data/PageDataTests.fs | 2 +- src/MyWebLog.Tests/Data/PostDataTests.fs | 2 +- src/MyWebLog.Tests/Data/PostgresDataTests.fs | 80 ++++++- src/MyWebLog.Tests/Data/RethinkDbDataTests.fs | 58 +++++ src/MyWebLog.Tests/Data/SQLiteDataTests.fs | 111 +++++++++- src/MyWebLog.Tests/Data/WebLogDataTests.fs | 198 ++++++++++++++++++ src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 1 + 9 files changed, 450 insertions(+), 8 deletions(-) create mode 100644 src/MyWebLog.Tests/Data/WebLogDataTests.fs diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index 921fd67..5ec39d4 100644 --- a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -25,7 +25,9 @@ type PostgresWebLogData(log: ILogger) = Custom.nonQuery $"""DELETE FROM {Table.PostComment} WHERE data ->> '{nameof Comment.Empty.PostId}' - IN (SELECT id FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"}); + 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} diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index b4ecde4..34179fc 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -446,7 +446,7 @@ type PostId = /// A redirection for a previously valid URL -[] +[] type RedirectRule = { /// The From string or pattern From: string diff --git a/src/MyWebLog.Tests/Data/PageDataTests.fs b/src/MyWebLog.Tests/Data/PageDataTests.fs index b8e5370..4d71130 100644 --- a/src/MyWebLog.Tests/Data/PageDataTests.fs +++ b/src/MyWebLog.Tests/Data/PageDataTests.fs @@ -13,7 +13,7 @@ open NodaTime let private rootId = CategoryDataTests.rootId /// The ID of the "A cool page" page -let private coolPageId = PageId "hgc_BLEZ50SoAWLuPNISvA" +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") diff --git a/src/MyWebLog.Tests/Data/PostDataTests.fs b/src/MyWebLog.Tests/Data/PostDataTests.fs index 416327d..8fdffdb 100644 --- a/src/MyWebLog.Tests/Data/PostDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostDataTests.fs @@ -19,7 +19,7 @@ let private episode1 = PostId "osxMfWGlAkyugUbJ1-xD1g" let private episode1Published = Instant.FromDateTimeOffset(DateTimeOffset.Parse "2024-01-20T22:24:01Z") /// The ID of podcast episode 2 -let private episode2 = PostId "l4_Eh4aFO06SqqJjOymNzA" +let episode2 = PostId "l4_Eh4aFO06SqqJjOymNzA" /// The ID of "Something May Happen" post let private something = PostId "QweKbWQiOkqqrjEdgP9wwg" diff --git a/src/MyWebLog.Tests/Data/PostgresDataTests.fs b/src/MyWebLog.Tests/Data/PostgresDataTests.fs index 5fe858d..690559f 100644 --- a/src/MyWebLog.Tests/Data/PostgresDataTests.fs +++ b/src/MyWebLog.Tests/Data/PostgresDataTests.fs @@ -1,6 +1,6 @@ module PostgresDataTests -open BitBadger.Documents +open BitBadger.Documents.Postgres open Expecto open Microsoft.Extensions.Logging.Abstractions open MyWebLog @@ -42,7 +42,7 @@ let private freshEnvironment () = task { db <- Some (ThrowawayDatabase.Create $"Host={testHost};Database={testDb};User ID={testUser};Password={testPw}") let source = NpgsqlDataSourceBuilder db.Value.ConnectionString let _ = source.UseNodaTime() - Postgres.Configuration.useDataSource (source.Build()) + 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 @@ -211,6 +211,12 @@ let private pageTests = testList "Page" [ 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 ()) @@ -351,6 +357,12 @@ let private postTests = testList "Post" [ 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 ()) @@ -625,6 +637,69 @@ let private webLogUserTests = testList "WebLogUser" [ ] ] +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() @@ -642,5 +717,6 @@ let all = themeAssetTests uploadTests webLogUserTests + webLogTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs index 604648a..19cf1cf 100644 --- a/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs +++ b/src/MyWebLog.Tests/Data/RethinkDbDataTests.fs @@ -625,6 +625,63 @@ let private webLogUserTests = testList "WebLogUser" [ ] ] +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 () @@ -642,5 +699,6 @@ let all = themeAssetTests uploadTests webLogUserTests + webLogTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs index babc8fa..50e74bf 100644 --- a/src/MyWebLog.Tests/Data/SQLiteDataTests.fs +++ b/src/MyWebLog.Tests/Data/SQLiteDataTests.fs @@ -308,7 +308,14 @@ let private pageTests = testList "Page" [ testList "Delete" [ testTask "succeeds when a page is deleted" { let data = mkData () - try do! PageDataTests.``Delete succeeds when a page is deleted`` data + try + do! PageDataTests.``Delete succeeds when a page is deleted`` data + let! revisions = + (data :?> SQLiteData).Conn.customScalar + "SELECT COUNT(*) AS it FROM page_revision WHERE page_id = @id" + [ idParam PageDataTests.coolPageId ] + toCount + Expect.equal revisions 0L "All revisions for the page should have been deleted" finally dispose data } testTask "succeeds when a page is not deleted" { @@ -519,7 +526,14 @@ let private postTests = testList "Post" [ testList "Delete" [ testTask "succeeds when a post is deleted" { let data = mkData () - try do! PostDataTests.``Delete succeeds when a post is deleted`` data + try + do! PostDataTests.``Delete succeeds when a post is deleted`` data + let! revisions = + (data :?> SQLiteData).Conn.customScalar + "SELECT COUNT(*) AS it FROM post_revision WHERE post_id = @id" + [ idParam PostDataTests.episode2 ] + toCount + Expect.equal revisions 0L "All revisions for the post should have been deleted" finally dispose data } testTask "succeeds when a post is not deleted" { @@ -925,6 +939,98 @@ let private webLogUserTests = testList "WebLogUser" [ ] ] +let private webLogTests = testList "WebLog" [ + testTask "Add succeeds" { + let data = mkData () + try do! WebLogDataTests.``Add succeeds`` data + finally dispose data + } + testTask "All succeeds" { + let data = mkData () + try do! WebLogDataTests.``All succeeds`` data + finally dispose data + } + testList "FindByHost" [ + testTask "succeeds when a web log is found" { + let data = mkData () + try do! WebLogDataTests.``FindByHost succeeds when a web log is found`` data + finally dispose data + } + testTask "succeeds when a web log is not found" { + let data = mkData () + try do! WebLogDataTests.``FindByHost succeeds when a web log is not found`` data + finally dispose data + } + ] + testList "FindById" [ + testTask "succeeds when a web log is found" { + let data = mkData () + try do! WebLogDataTests.``FindById succeeds when a web log is found`` data + finally dispose data + } + testTask "succeeds when a web log is not found" { + let data = mkData () + try do! WebLogDataTests.``FindById succeeds when a web log is not found`` data + finally dispose data + } + ] + testList "UpdateRedirectRules" [ + testTask "succeeds when the web log exists" { + let data = mkData () + try do! WebLogDataTests.``UpdateRedirectRules succeeds when the web log exists`` data + finally dispose data + } + testTask "succeeds when the web log does not exist" { + let data = mkData () + try do! WebLogDataTests.``UpdateRedirectRules succeeds when the web log does not exist`` data + finally dispose data + } + ] + testList "UpdateRssOptions" [ + testTask "succeeds when the web log exists" { + let data = mkData () + try do! WebLogDataTests.``UpdateRssOptions succeeds when the web log exists`` data + finally dispose data + } + testTask "succeeds when the web log does not exist" { + let data = mkData () + try do! WebLogDataTests.``UpdateRssOptions succeeds when the web log does not exist`` data + finally dispose data + } + ] + testList "UpdateSettings" [ + testTask "succeeds when the web log exists" { + let data = mkData () + try do! WebLogDataTests.``UpdateSettings succeeds when the web log exists`` data + finally dispose data + } + testTask "succeeds when the web log does not exist" { + let data = mkData () + try do! WebLogDataTests.``UpdateSettings succeeds when the web log does not exist`` data + finally dispose data + } + ] + testList "Delete" [ + testTask "succeeds when the web log exists" { + let data = mkData () + try + do! WebLogDataTests.``Delete succeeds when the web log exists`` data + let! revisions = + (data :?> SQLiteData).Conn.customScalar + "SELECT (SELECT COUNT(*) FROM page_revision) + (SELECT COUNT(*) FROM post_revision) AS it" + [] + toCount + Expect.equal revisions 0L "All revisions should be deleted" + finally dispose data + } + testTask "succeeds when the web log does not exist" { + let data = mkData () + try do! WebLogDataTests.``Delete succeeds when the web log does not exist`` data + finally dispose data + } + ] +] + /// Delete the SQLite database let private environmentCleanUp = test "Clean Up" { File.Delete dbName @@ -943,5 +1049,6 @@ let all = themeAssetTests uploadTests webLogUserTests + webLogTests environmentCleanUp ] |> testSequenced diff --git a/src/MyWebLog.Tests/Data/WebLogDataTests.fs b/src/MyWebLog.Tests/Data/WebLogDataTests.fs new file mode 100644 index 0000000..f87a486 --- /dev/null +++ b/src/MyWebLog.Tests/Data/WebLogDataTests.fs @@ -0,0 +1,198 @@ +/// +/// Integration tests for implementations +/// +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" +} diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 407c213..35b206e 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -17,6 +17,7 @@ + -- 2.45.1 From d378f690e422da68fc7d71fb0824fb2af65b7737 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 5 Feb 2024 22:28:07 -0500 Subject: [PATCH 082/123] Add chapter source fields (#6) --- src/MyWebLog.Domain/ViewModels.fs | 23 ++++++++-- src/MyWebLog.Tests/Domain/ViewModelsTests.fs | 47 +++++++++++++++++++- src/admin-theme/_edit-common.liquid | 6 +++ src/admin-theme/post-edit.liquid | 32 ++++++++++++- src/admin-theme/wwwroot/admin.js | 30 +++++++++++-- 5 files changed, 127 insertions(+), 11 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index f0036ee..fdec2ca 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -648,6 +648,9 @@ type EditPostModel = { /// The explicit rating for this episode (optional, defaults to podcast setting) Explicit: string + /// The chapter source ("internal" for chapters defined here, "external" for a file link, "none" if none defined) + ChapterSource: string + /// The URL for the chapter file for the episode (may be permalink; optional) ChapterFile: string @@ -713,6 +716,9 @@ type EditPostModel = { ImageUrl = defaultArg episode.ImageUrl "" Subtitle = defaultArg episode.Subtitle "" Explicit = defaultArg (episode.Explicit |> Option.map string) "" + ChapterSource = if Option.isSome episode.Chapters then "internal" + elif Option.isSome episode.ChapterFile then "external" + else "none" ChapterFile = defaultArg episode.ChapterFile "" ChapterType = defaultArg episode.ChapterType "" ContainsWaypoints = defaultArg episode.ChapterWaypoints false @@ -773,10 +779,19 @@ type EditPostModel = { ImageUrl = noneIfBlank this.ImageUrl Subtitle = noneIfBlank this.Subtitle Explicit = noneIfBlank this.Explicit |> Option.map ExplicitRating.Parse - Chapters = match post.Episode with Some e -> e.Chapters | None -> None - ChapterFile = noneIfBlank this.ChapterFile - ChapterType = noneIfBlank this.ChapterType - ChapterWaypoints = if this.ContainsWaypoints then Some true else None + Chapters = if this.ChapterSource = "internal" then + match post.Episode with + | Some e when Option.isSome e.Chapters -> e.Chapters + | Some _ + | None -> Some [] + else None + ChapterFile = if this.ChapterSource = "external" then noneIfBlank this.ChapterFile + else None + ChapterType = if this.ChapterSource = "external" then noneIfBlank this.ChapterType + else None + ChapterWaypoints = if this.ChapterSource = "none" then None + elif this.ContainsWaypoints then Some true + else None TranscriptUrl = noneIfBlank this.TranscriptUrl TranscriptType = noneIfBlank this.TranscriptType TranscriptLang = noneIfBlank this.TranscriptLang diff --git a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs index 6bc7ecf..969cf90 100644 --- a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs @@ -621,7 +621,7 @@ let editPostModelTests = testList "EditPostModel" [ ImageUrl = Some "uploads/podcast-cover.jpg" Subtitle = Some "Narration" Explicit = Some Clean - Chapters = None // for future implementation + Chapters = None ChapterFile = Some "uploads/1970/01/chapters.txt" ChapterType = Some "chapters" ChapterWaypoints = Some true @@ -661,6 +661,7 @@ let editPostModelTests = testList "EditPostModel" [ Expect.equal model.ImageUrl "" "ImageUrl not filled properly" Expect.equal model.Subtitle "" "Subtitle not filled properly" Expect.equal model.Explicit "" "Explicit not filled properly" + Expect.equal model.ChapterSource "none" "ChapterSource not filled properly" Expect.equal model.ChapterFile "" "ChapterFile not filled properly" Expect.equal model.ChapterType "" "ChapterType not filled properly" Expect.isFalse model.ContainsWaypoints "ContainsWaypoints should not have been set" @@ -673,7 +674,7 @@ let editPostModelTests = testList "EditPostModel" [ Expect.equal model.EpisodeNumber "" "EpisodeNumber not filled properly" Expect.equal model.EpisodeDescription "" "EpisodeDescription not filled properly" } - test "succeeds for full post" { + test "succeeds for full post with external chapters" { let model = EditPostModel.FromPost { WebLog.Empty with TimeZone = "Etc/GMT+1" } fullPost Expect.equal model.PostId "a-post" "PostId not filled properly" Expect.equal model.Title "A Post" "Title not filled properly" @@ -704,6 +705,7 @@ let editPostModelTests = testList "EditPostModel" [ Expect.equal model.ImageUrl "uploads/podcast-cover.jpg" "ImageUrl not filled properly" Expect.equal model.Subtitle "Narration" "Subtitle not filled properly" Expect.equal model.Explicit "clean" "Explicit not filled properly" + Expect.equal model.ChapterSource "external" "ChapterSource not filled properly" Expect.equal model.ChapterFile "uploads/1970/01/chapters.txt" "ChapterFile not filled properly" Expect.equal model.ChapterType "chapters" "ChapterType not filled properly" Expect.isTrue model.ContainsWaypoints "ContainsWaypoints should have been set" @@ -716,6 +718,19 @@ let editPostModelTests = testList "EditPostModel" [ Expect.equal model.EpisodeNumber "322" "EpisodeNumber not filled properly" Expect.equal model.EpisodeDescription "Episode 322" "EpisodeDescription not filled properly" } + test "succeeds for full post with internal chapters" { + let model = + EditPostModel.FromPost + { WebLog.Empty with TimeZone = "Etc/GMT+1" } + { fullPost with + Episode = + Some + { fullPost.Episode.Value with + Chapters = Some [] + ChapterFile = None + ChapterType = None } } + Expect.equal model.ChapterSource "internal" "ChapterSource not filled properly" + } ] testList "IsNew" [ test "succeeds for a new post" { @@ -747,6 +762,7 @@ let editPostModelTests = testList "EditPostModel" [ ImageUrl = "updated-cover.png" Subtitle = "Talking" Explicit = "no" + ChapterSource = "external" ChapterFile = "updated-chapters.txt" ChapterType = "indexes" TranscriptUrl = "updated-transcript.txt" @@ -787,6 +803,7 @@ let editPostModelTests = testList "EditPostModel" [ Expect.equal ep.ImageUrl (Some "updated-cover.png") "ImageUrl not filled properly" Expect.equal ep.Subtitle (Some "Talking") "Subtitle not filled properly" Expect.equal ep.Explicit (Some No) "ExplicitRating not filled properly" + Expect.isNone ep.Chapters "Chapters should have had no value" Expect.equal ep.ChapterFile (Some "updated-chapters.txt") "ChapterFile not filled properly" Expect.equal ep.ChapterType (Some "indexes") "ChapterType not filled properly" Expect.equal ep.ChapterWaypoints (Some true) "ChapterWaypoints should have been set" @@ -840,6 +857,32 @@ let editPostModelTests = testList "EditPostModel" [ Expect.isNone ep.EpisodeNumber "EpisodeNumber not filled properly" Expect.isNone ep.EpisodeDescription "EpisodeDescription not filled properly" } + test "succeeds for a podcast episode with internal chapters" { + let minModel = + { updatedModel with + ChapterSource = "internal" + ChapterFile = "" + ChapterType = "" } + let post = minModel.UpdatePost fullPost (Noda.epoch + Duration.FromDays 500) + Expect.isSome post.Episode "There should have been a podcast episode" + let ep = post.Episode.Value + Expect.equal ep.Chapters (Some []) "Chapters not filled properly" + Expect.isNone ep.ChapterFile "ChapterFile not filled properly" + Expect.isNone ep.ChapterType "ChapterType not filled properly" + } + test "succeeds for a podcast episode with no chapters" { + let minModel = { updatedModel with ChapterSource = "none" } + let post = + minModel.UpdatePost + { fullPost with Episode = Some { fullPost.Episode.Value with Chapters = Some [] } } + (Noda.epoch + Duration.FromDays 500) + Expect.isSome post.Episode "There should have been a podcast episode" + let ep = post.Episode.Value + Expect.isNone ep.Chapters "Chapters not filled properly" + Expect.isNone ep.ChapterFile "ChapterFile not filled properly" + Expect.isNone ep.ChapterType "ChapterType not filled properly" + Expect.isNone ep.ChapterWaypoints "ChapterWaypoints not filled properly" + } test "succeeds for no podcast episode and no template" { let post = { updatedModel with IsEpisode = false; Template = "" }.UpdatePost fullPost Noda.epoch Expect.isNone post.Template "Template not filled properly" diff --git a/src/admin-theme/_edit-common.liquid b/src/admin-theme/_edit-common.liquid index 214de29..e72622b 100644 --- a/src/admin-theme/_edit-common.liquid +++ b/src/admin-theme/_edit-common.liquid @@ -13,6 +13,12 @@ Manage Permalinks • Manage Revisions + {% if model.chapter_source == "internal" %} + + • + Manage Chapters + + {% endif %} {%- endunless -%}
      diff --git a/src/admin-theme/post-edit.liquid b/src/admin-theme/post-edit.liquid index 4582fcc..03dcdd7 100644 --- a/src/admin-theme/post-edit.liquid +++ b/src/admin-theme/post-edit.liquid @@ -107,13 +107,43 @@
      +
      +
      +
      Chapters
      +
      + + +
      +
      + + +
      +
      + + +
      +
      +
      +
      + + +
      +
      +
      -
      Optional; relative URL served from this web log
      +
      Relative URL served from this web log
      diff --git a/src/admin-theme/wwwroot/admin.js b/src/admin-theme/wwwroot/admin.js index 308b78a..9575a54 100644 --- a/src/admin-theme/wwwroot/admin.js +++ b/src/admin-theme/wwwroot/admin.js @@ -212,15 +212,37 @@ this.Admin = { this.nextPermalink++ }, + /** + * Set the chapter type for a podcast episode + * @param {"none"|"internal"|"external"} src The source for chapters for this episode + */ + setChapterSource(src) { + document.getElementById("containsWaypoints").disabled = src === "none" + const isDisabled = src === "none" || src === "internal" + const chapterFile = document.getElementById("chapterFile") + chapterFile.disabled = isDisabled + chapterFile.required = !isDisabled + document.getElementById("chapterType").disabled = isDisabled + const link = document.getElementById("chapterEditLink") + if (link) link.style.display = src === "none" || src === "external" ? "none" : "" + }, + /** * Enable or disable podcast fields */ toggleEpisodeFields() { const disabled = !document.getElementById("isEpisode").checked - ;[ "media", "mediaType", "length", "duration", "subtitle", "imageUrl", "explicit", "chapterFile", "chapterType", - "transcriptUrl", "transcriptType", "transcriptLang", "transcriptCaptions", "seasonNumber", "seasonDescription", - "episodeNumber", "episodeDescription" - ].forEach(it => document.getElementById(it).disabled = disabled) + let fields = [ + "media", "mediaType", "length", "duration", "subtitle", "imageUrl", "explicit", "transcriptUrl", "transcriptType", + "transcriptLang", "transcriptCaptions", "seasonNumber", "seasonDescription", "episodeNumber", "episodeDescription" + ] + if (disabled) { + fields.push("chapterFile", "chapterType", "containsWaypoints") + } else { + const src = [...document.getElementsByName("ChapterSource")].filter(it => it.checked)[0].value + this.setChapterSource(src) + } + fields.forEach(it => document.getElementById(it).disabled = disabled) }, /** -- 2.45.1 From 90bca34be30163758fae45cf55a82e78496d22f8 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 7 Feb 2024 21:59:43 -0500 Subject: [PATCH 083/123] WIP on chapter list page (#6) --- src/MyWebLog.Domain/ViewModels.fs | 59 +++++++++++++++++++++++++++++++ src/MyWebLog/DotLiquidBespoke.fs | 17 ++++----- src/MyWebLog/Handlers/Post.fs | 15 ++++++++ src/MyWebLog/Handlers/Routes.fs | 1 + src/admin-theme/chapters.liquid | 38 ++++++++++++++++++++ 5 files changed, 122 insertions(+), 8 deletions(-) create mode 100644 src/admin-theme/chapters.liquid diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index fdec2ca..8352ce9 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -3,6 +3,7 @@ open System open MyWebLog open NodaTime +open NodaTime.Text /// Helper functions for view models [] @@ -71,6 +72,45 @@ type DisplayCategory = { PostCount: int } +/// A display version of an episode chapter +type DisplayChapter = { + /// The start time of the chapter (HH:MM:SS.FF format) + StartTime: string + + /// The title of the chapter + Title: string + + /// An image to display for this chapter + ImageUrl: string + + /// Whether this chapter should be displayed in podcast players + IsHidden: bool + + /// The end time of the chapter (HH:MM:SS.FF format) + EndTime: string + + /// The name of a location + LocationName: string + + /// The geographic coordinates of the location + LocationGeo: string + + /// An OpenStreetMap query for this location + LocationOsm: string +} with + + /// Create a display chapter from a chapter + static member FromChapter (chapter: Chapter) = + let pattern = DurationPattern.CreateWithInvariantCulture("H:mm:ss.ff") + { StartTime = pattern.Format(chapter.StartTime) + Title = defaultArg chapter.Title "" + ImageUrl = defaultArg chapter.ImageUrl "" + IsHidden = defaultArg chapter.IsHidden false + EndTime = chapter.EndTime |> Option.map pattern.Format |> Option.defaultValue "" + LocationName = chapter.Location |> Option.map (fun l -> l.Name) |> Option.defaultValue "" + LocationGeo = chapter.Location |> Option.map (fun l -> l.Geo) |> Option.flatten |> Option.defaultValue "" + LocationOsm = chapter.Location |> Option.map (fun l -> l.Osm) |> Option.flatten |> Option.defaultValue "" } + /// A display version of a custom feed definition type DisplayCustomFeed = { @@ -984,6 +1024,25 @@ type LogOnModel = { { EmailAddress = ""; Password = ""; ReturnTo = None } +/// View model to manage chapters +[] +type ManageChaptersModel = { + /// The post ID for the chapters being edited + Id: string + + /// The title of the post for which chapters are being edited + Title: string + + Chapters: Chapter array +} with + + /// Create a model from a post and its episode's chapters + static member Create (post: Post) = + { Id = string post.Id + Title = post.Title + Chapters = Array.ofList post.Episode.Value.Chapters.Value } + + /// View model to manage permalinks [] type ManagePermalinksModel = { diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index d5edcca..9ef5b45 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -227,14 +227,15 @@ let register () = typeof; typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof; typeof // View models - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index c5d6bec..ca68ebb 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -371,6 +371,21 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu | _, None -> return! Error.notFound next ctx } +// GET /admin/post/{id}/chapters +let chapters 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! + hashForPage "Manage Chapters" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (ManageChaptersModel.Create post) + |> adminView "chapters" 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() diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 996553c..7028f04 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -129,6 +129,7 @@ let router : HttpHandler = choose [ routef "/%s/permalinks" Post.editPermalinks routef "/%s/revision/%s/preview" Post.previewRevision routef "/%s/revisions" Post.editRevisions + routef "/%s/chapters" Post.chapters ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ route "" >=> Admin.WebLog.settings diff --git a/src/admin-theme/chapters.liquid b/src/admin-theme/chapters.liquid new file mode 100644 index 0000000..fa8a38a --- /dev/null +++ b/src/admin-theme/chapters.liquid @@ -0,0 +1,38 @@ +

      {{ page_title }}

      +
      + + + +
      +
      +
      +

      + {{ model.title }}
      + + + « Back to Edit Post + + +

      +
      +
      +
      Start
      +
      Title
      +
      Image?
      +
      Location?
      +
      + {% for chapter in model.chapters %} +
      +
      {{ chapter.start_time }}
      +
      {{ chapter.title }}
      +
      {% if chapter.image_url == "" %}N{% else %}Y{% endif %}
      +
      {% if chapter.location %}Y{% else %}N{% endif %}
      +
      + {% endfor %} +
      + {% assign new_link = "admin/post/" | append: model.id | append: "/chapter/new" | relative_link %} + Add a New Chapter +
      +
      + +
      -- 2.45.1 From 12b23eab46d8daf729b2ca3b4712f1e8af27fb02 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 8 Feb 2024 22:48:46 -0500 Subject: [PATCH 084/123] WIP on chapter edit page (#6) --- src/MyWebLog.Domain/SupportTypes.fs | 11 ++- src/MyWebLog.Domain/ViewModels.fs | 94 +++++++++++++++++--- src/MyWebLog.Tests/Domain/ViewModelsTests.fs | 58 ++++++++++++ src/MyWebLog.Tests/Program.fs | 18 ++-- src/MyWebLog/DotLiquidBespoke.fs | 18 ++-- src/MyWebLog/Handlers/Post.fs | 23 +++++ src/MyWebLog/Handlers/Routes.fs | 1 + src/admin-theme/chapter-edit.liquid | 84 +++++++++++++++++ src/admin-theme/chapters.liquid | 8 +- 9 files changed, 284 insertions(+), 31 deletions(-) create mode 100644 src/admin-theme/chapter-edit.liquid diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 34179fc..acbb7d9 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -190,7 +190,16 @@ type Chapter = { /// A location that applies to a chapter Location: Location option -} +} with + + /// An empty chapter + static member Empty = + { StartTime = Duration.Zero + Title = None + ImageUrl = None + IsHidden = None + EndTime = None + Location = None } open NodaTime.Text diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 8352ce9..1a9ff82 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -72,9 +72,10 @@ type DisplayCategory = { PostCount: int } + /// A display version of an episode chapter type DisplayChapter = { - /// The start time of the chapter (HH:MM:SS.FF format) + /// The start time of the chapter (H:mm:ss.FF format) StartTime: string /// The title of the chapter @@ -86,7 +87,7 @@ type DisplayChapter = { /// Whether this chapter should be displayed in podcast players IsHidden: bool - /// The end time of the chapter (HH:MM:SS.FF format) + /// The end time of the chapter (H:mm:ss.FF format) EndTime: string /// The name of a location @@ -101,15 +102,15 @@ type DisplayChapter = { /// Create a display chapter from a chapter static member FromChapter (chapter: Chapter) = - let pattern = DurationPattern.CreateWithInvariantCulture("H:mm:ss.ff") - { StartTime = pattern.Format(chapter.StartTime) + let pattern = DurationPattern.CreateWithInvariantCulture "H:mm:ss.FF" + { StartTime = pattern.Format chapter.StartTime Title = defaultArg chapter.Title "" ImageUrl = defaultArg chapter.ImageUrl "" IsHidden = defaultArg chapter.IsHidden false - EndTime = chapter.EndTime |> Option.map pattern.Format |> Option.defaultValue "" - LocationName = chapter.Location |> Option.map (fun l -> l.Name) |> Option.defaultValue "" - LocationGeo = chapter.Location |> Option.map (fun l -> l.Geo) |> Option.flatten |> Option.defaultValue "" - LocationOsm = chapter.Location |> Option.map (fun l -> l.Osm) |> Option.flatten |> Option.defaultValue "" } + EndTime = chapter.EndTime |> Option.map pattern.Format |> Option.defaultValue "" + LocationName = chapter.Location |> Option.map _.Name |> Option.defaultValue "" + LocationGeo = chapter.Location |> Option.map _.Geo |> Option.flatten |> Option.defaultValue "" + LocationOsm = chapter.Location |> Option.map _.Osm |> Option.flatten |> Option.defaultValue "" } /// A display version of a custom feed definition @@ -360,6 +361,78 @@ type EditCategoryModel = { this.CategoryId = "new" +/// View model to add/edit an episode chapter +type EditChapterModel = { + /// The ID of the post to which the chapter belongs + PostId: string + + /// The index in the chapter list (-1 means new) + Index: int + + /// The start time of the chapter (H:mm:ss.FF format) + StartTime: string + + /// The title of the chapter + Title: string + + /// An image to display for this chapter + ImageUrl: string + + /// Whether this chapter should be displayed in podcast players + IsHidden: bool + + /// The end time of the chapter (HH:MM:SS.FF format) + EndTime: string + + /// The name of a location + LocationName: string + + /// The geographic coordinates of the location + LocationGeo: string + + /// An OpenStreetMap query for this location + LocationOsm: string +} with + + /// Create a display chapter from a chapter + static member FromChapter (postId: PostId) idx chapter = + let it = DisplayChapter.FromChapter chapter + { PostId = string postId + Index = idx + StartTime = it.StartTime + Title = it.Title + ImageUrl = it.ImageUrl + IsHidden = it.IsHidden + EndTime = it.EndTime + LocationName = it.LocationName + LocationGeo = it.LocationGeo + LocationOsm = it.LocationOsm } + + /// Create a chapter from the values in this model + member this.ToChapter () = + let parseDuration name value = + let pattern = + match value |> Seq.fold (fun count chr -> if chr = ':' then count + 1 else count) 0 with + | 0 -> "S" + | 1 -> "MM:ss" + | 2 -> "H:mm:ss" + | _ -> invalidArg name "Max time format is H:mm:ss" + |> function + | it -> DurationPattern.CreateWithInvariantCulture $"{it}.FFFFFFFFF" + let result = pattern.Parse value + if result.Success then result.Value else raise result.Exception + let location = + match noneIfBlank this.LocationName with + | None -> None + | Some name -> Some { Name = name; Geo = noneIfBlank this.LocationGeo; Osm = noneIfBlank this.LocationOsm } + { StartTime = parseDuration (nameof this.StartTime) this.StartTime + Title = noneIfBlank this.Title + ImageUrl = noneIfBlank this.ImageUrl + IsHidden = if this.IsHidden then Some true else None + EndTime = noneIfBlank this.EndTime |> Option.map (parseDuration (nameof this.EndTime)) + Location = location } + + /// View model to edit a custom RSS feed [] type EditCustomFeedModel = { @@ -1033,14 +1106,15 @@ type ManageChaptersModel = { /// The title of the post for which chapters are being edited Title: string - Chapters: Chapter array + /// The chapters for the post + Chapters: DisplayChapter array } with /// Create a model from a post and its episode's chapters static member Create (post: Post) = { Id = string post.Id Title = post.Title - Chapters = Array.ofList post.Episode.Value.Chapters.Value } + Chapters = post.Episode.Value.Chapters.Value |> List.map DisplayChapter.FromChapter |> Array.ofList } /// View model to manage permalinks diff --git a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs index 969cf90..0915383 100644 --- a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs @@ -33,6 +33,39 @@ let addBaseToRelativeUrlsTests = testList "PublicHelpers.addBaseToRelativeUrls" } ] +/// Unit tests for the DisplayChapter type +let displayChapterTests = testList "DisplayChapter.FromChapter" [ + test "succeeds for a minimally-filled chapter" { + let chapter = DisplayChapter.FromChapter { Chapter.Empty with StartTime = Duration.FromSeconds 322L } + Expect.equal chapter.StartTime "0:05:22" "Start time not filled/formatted properly" + Expect.equal chapter.Title "" "Title not filled properly" + Expect.equal chapter.ImageUrl "" "Image URL not filled properly" + Expect.isFalse chapter.IsHidden "Is hidden flag not filled properly" + Expect.equal chapter.EndTime "" "End time not filled properly" + Expect.equal chapter.LocationName "" "Location name not filled properly" + Expect.equal chapter.LocationGeo "" "Location geo URL not filled properly" + Expect.equal chapter.LocationOsm "" "Location OSM query not filled properly" + } + test "succeeds for a fully-filled chapter" { + let chapter = + DisplayChapter.FromChapter + { StartTime = Duration.FromSeconds 7201.43242 + Title = Some "My Test Chapter" + ImageUrl = Some "two-hours-in.jpg" + IsHidden = Some true + EndTime = Some (Duration.FromSeconds 7313.788) + Location = Some { Name = "Over Here"; Geo = Some "geo:23432"; Osm = Some "SF98fFSu-8" } } + Expect.equal chapter.StartTime "2:00:01.43" "Start time not filled/formatted properly" + Expect.equal chapter.Title "My Test Chapter" "Title not filled properly" + Expect.equal chapter.ImageUrl "two-hours-in.jpg" "Image URL not filled properly" + Expect.isTrue chapter.IsHidden "Is hidden flag not filled properly" + Expect.equal chapter.EndTime "2:01:53.78" "End time not filled/formatted properly" + Expect.equal chapter.LocationName "Over Here" "Location name not filled properly" + Expect.equal chapter.LocationGeo "geo:23432" "Location geo URL not filled properly" + Expect.equal chapter.LocationOsm "SF98fFSu-8" "Location OSM query not filled properly" + } +] + /// Unit tests for the DisplayCustomFeed type let displayCustomFeedTests = testList "DisplayCustomFeed.FromFeed" [ test "succeeds for a feed for an existing category" { @@ -1071,6 +1104,29 @@ let editUserModelTests = testList "EditUserModel" [ ] ] +/// Unit tests for the ManageChaptersModel type +let manageChaptersModelTests = testList "ManageChaptersModel.Create" [ + test "succeeds" { + let model = + ManageChaptersModel.Create + { Post.Empty with + Id = PostId "test-post" + Title = "Look at all these chapters" + Episode = Some + { Episode.Empty with + Chapters = Some + [ { Chapter.Empty with StartTime = Duration.FromSeconds 18L } + { Chapter.Empty with StartTime = Duration.FromSeconds 36L } + { Chapter.Empty with StartTime = Duration.FromSeconds 180.7 } ] } } + Expect.equal model.Id "test-post" "ID not filled properly" + Expect.equal model.Title "Look at all these chapters" "Title not filled properly" + Expect.hasLength model.Chapters 3 "There should be three chapters" + Expect.equal model.Chapters[0].StartTime "0:00:18" "First chapter not filled properly" + Expect.equal model.Chapters[1].StartTime "0:00:36" "Second chapter not filled properly" + Expect.equal model.Chapters[2].StartTime "0:03:00.7" "Third chapter not filled properly" + } +] + /// Unit tests for the ManagePermalinksModel type let managePermalinksModelTests = testList "ManagePermalinksModel" [ test "FromPage succeeds" { @@ -1285,6 +1341,7 @@ let userMessageTests = testList "UserMessage" [ /// All tests in the Domain.ViewModels file let all = testList "ViewModels" [ addBaseToRelativeUrlsTests + displayChapterTests displayCustomFeedTests displayPageTests displayRevisionTests @@ -1300,6 +1357,7 @@ let all = testList "ViewModels" [ editRssModelTests editTagMapModelTests editUserModelTests + manageChaptersModelTests managePermalinksModelTests manageRevisionsModelTests postListItemTests diff --git a/src/MyWebLog.Tests/Program.fs b/src/MyWebLog.Tests/Program.fs index ab848c5..b2ed6a9 100644 --- a/src/MyWebLog.Tests/Program.fs +++ b/src/MyWebLog.Tests/Program.fs @@ -12,15 +12,19 @@ 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 ] - 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 - ] + 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 + ] ] [] diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 9ef5b45..eac2c53 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -227,15 +227,15 @@ let register () = typeof; typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof; typeof // View models - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index ca68ebb..0b1c670 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -386,6 +386,29 @@ let chapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> tas | 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! + hashForPage (if index = -1 then "Add a Chapter" else "Edit Chapter") + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (EditChapterModel.FromChapter post.Id index chap) + |> adminBareView "chapter-edit" next ctx + | None -> 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() diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 7028f04..5262fc2 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -129,6 +129,7 @@ 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.chapters ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ diff --git a/src/admin-theme/chapter-edit.liquid b/src/admin-theme/chapter-edit.liquid new file mode 100644 index 0000000..172236f --- /dev/null +++ b/src/admin-theme/chapter-edit.liquid @@ -0,0 +1,84 @@ +

      {% if model.index < 0 %}Add{% else %}Edit{% endif %} Chapter

      +
      + + +
      +
      +
      + + +
      +
      +
      +
      + + +
      +
      +
      +
      +
      +
      + + +
      +
      +
      +
      + + +
      +
      +
      +
      + + +
      +
      +
      +
      +
      +
      + + +
      +
      +
      +
      + + +
      +
      +
      +
      + + +
      +
      +
      +
      + + +
      +
      +
      +
      +
      + {% if model.index < 0 -%} + + + {% else -%} + + {% endif %} + {% assign cancel_link = "admin/post/" | append: model.post_id | append: "/chapters" | relative_link %} + Cancel +
      +
      +
      diff --git a/src/admin-theme/chapters.liquid b/src/admin-theme/chapters.liquid index fa8a38a..a61ab41 100644 --- a/src/admin-theme/chapters.liquid +++ b/src/admin-theme/chapters.liquid @@ -1,6 +1,6 @@

      {{ page_title }}

      -
      +
      @@ -29,9 +29,9 @@
      {% if chapter.location %}Y{% else %}N{% endif %}
      {% endfor %} -
      - {% assign new_link = "admin/post/" | append: model.id | append: "/chapter/new" | relative_link %} - Add a New Chapter +
      + {% assign new_link = "admin/post/" | append: model.id | append: "/chapter/-1" | relative_link %} + Add a New Chapter
      -- 2.45.1 From 14632473a629db4b7eaf1ba8f8af1614a55fcb66 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 10 Feb 2024 20:46:14 -0500 Subject: [PATCH 085/123] WIP on chapter edit form (#6) --- src/admin-theme/chapter-edit.liquid | 79 +++++++++++++++++------------ 1 file changed, 47 insertions(+), 32 deletions(-) diff --git a/src/admin-theme/chapter-edit.liquid b/src/admin-theme/chapter-edit.liquid index 172236f..bb13c16 100644 --- a/src/admin-theme/chapter-edit.liquid +++ b/src/admin-theme/chapter-edit.liquid @@ -1,71 +1,86 @@ -

      {% if model.index < 0 %}Add{% else %}Edit{% endif %} Chapter

      +

      {% if model.index < 0 %}Add{% else %}Edit{% endif %} Chapter

      +

      Times may be entered as seconds; minutes and seconds; or hours, minutes and seconds. Fractional + seconds are supported to two decimal places.

      -
      +
      - +
      -
      -
      - - -
      -
      -
      -
      -
      -
      - - -
      -
      -
      -
      - - -
      -
      -
      +
      + Optional; ends when next starts
      +
      +
      + + + Optional +
      +
      +
      +
      + + + Optional; a separate image to display while this chapter is playing +
      +
      +
      +
      + + +
      + Not displayed, but may update image and location +
      -
      -
      +
      +
      -
      +
      -
      +
      + + Optional; + see spec +
      -
      +
      - + + + Optional; get ID, + see spec +
      -- 2.45.1 From d3c89dae5fc4b85dfa59ca98acac6c6d466c4dad Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 11 Feb 2024 13:29:54 -0500 Subject: [PATCH 086/123] WIP on chapter edit form (#6) --- src/MyWebLog.Domain/ViewModels.fs | 6 +++++- src/admin-theme/chapter-edit.liquid | 24 +++++++++++++++--------- src/admin-theme/wwwroot/admin.js | 12 ++++++++++++ 3 files changed, 32 insertions(+), 10 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 1a9ff82..098ee5c 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -392,6 +392,9 @@ type EditChapterModel = { /// An OpenStreetMap query for this location LocationOsm: string + + /// Whether to add another chapter after adding this one + AddAnother: bool } with /// Create a display chapter from a chapter @@ -406,7 +409,8 @@ type EditChapterModel = { EndTime = it.EndTime LocationName = it.LocationName LocationGeo = it.LocationGeo - LocationOsm = it.LocationOsm } + LocationOsm = it.LocationOsm + AddAnother = false } /// Create a chapter from the values in this model member this.ToChapter () = diff --git a/src/admin-theme/chapter-edit.liquid b/src/admin-theme/chapter-edit.liquid index bb13c16..d5e73a0 100644 --- a/src/admin-theme/chapter-edit.liquid +++ b/src/admin-theme/chapter-edit.liquid @@ -1,7 +1,9 @@

      {% if model.index < 0 %}Add{% else %}Edit{% endif %} Chapter

      Times may be entered as seconds; minutes and seconds; or hours, minutes and seconds. Fractional seconds are supported to two decimal places. - +{% assign post_url = "admin/post/" | append: model.post_id | append: "/chapter/" | append: model.index | relative_link %} + +

      @@ -45,24 +47,25 @@
      + {%- if model.location_name != "" -%}{% assign has_loc = true %}{% else %}{% assign has_loc = false %}{% endif -%}
      - +
      + placeholder="Location Name" required{% unless has_loc %} disabled{% endunless %}>
      + placeholder="Location Geo URL"{% unless has_loc %} disabled{% endunless %}> Optional; @@ -74,7 +77,7 @@
      + placeholder="Location OSM Query"{% unless has_loc %} disabled{% endunless %}> Optional; get ID, @@ -87,11 +90,14 @@
      {% if model.index < 0 -%} - - +
      + + +
      {% else -%} - + {% endif %} + {% assign cancel_link = "admin/post/" | append: model.post_id | append: "/chapters" | relative_link %} Cancel
      diff --git a/src/admin-theme/wwwroot/admin.js b/src/admin-theme/wwwroot/admin.js index 9575a54..4867539 100644 --- a/src/admin-theme/wwwroot/admin.js +++ b/src/admin-theme/wwwroot/admin.js @@ -305,6 +305,18 @@ this.Admin = { document.getElementById("transcriptType").required = document.getElementById("transcriptUrl").value.trim() !== "" }, + /** + * Enable/disable fields based on whether chapter location checkbox is checked + */ + checkChapterLocation() { + const isDisabled = !document.getElementById("has_location").checked + ;["location_name", "location_geo", "location_osm"].forEach(it => { + const elt = document.getElementById(it) + elt.disabled = isDisabled + if (isDisabled) elt.value = "" + }) + }, + /** * Show messages that may have come with an htmx response * @param {string} messages The messages from the response -- 2.45.1 From 6a5285ca544aa9c2dacc60a1b0b2d5f2c2eabb53 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 3 Mar 2024 22:23:43 -0500 Subject: [PATCH 087/123] WIP on saving chapters (#6) --- src/MyWebLog.Domain/ViewModels.fs | 1 + src/MyWebLog/Handlers/Post.fs | 31 +++++++++++++++++++++++++++++++ src/MyWebLog/Handlers/Routes.fs | 1 + 3 files changed, 33 insertions(+) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 098ee5c..afb672b 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -362,6 +362,7 @@ type EditCategoryModel = { /// View model to add/edit an episode chapter +[] type EditChapterModel = { /// The ID of the post to which the chapter belongs PostId: string diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 0b1c670..282e9fb 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -409,6 +409,37 @@ let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex | 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.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! form = ctx.BindFormAsync() + let chapters = post.Episode.Value.Chapters.Value + if index = -1 || (index >= 0 && index < List.length chapters) then + let updatedPost = + { post with + Episode = Some { + post.Episode.Value with + Chapters = + form.ToChapter() :: (if index = -1 then chapters else chapters |> List.removeAt index) + |> List.sortBy _.StartTime + |> Some } } + do! data.Post.Update updatedPost + do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } + // TODO: handle "add another", only return chapter list vs. entire page with title + return! + hashForPage "Manage Chapters" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (ManageChaptersModel.Create updatedPost) + |> adminView "chapters" 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() diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 5262fc2..8216f07 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -178,6 +178,7 @@ let router : HttpHandler = choose [ subRoute "/post" (choose [ route "/save" >=> Post.save route "/permalinks" >=> Post.savePermalinks + routef "/%s/chapter/%i" Post.saveChapter routef "/%s/delete" Post.delete routef "/%s/revision/%s/delete" Post.deleteRevision routef "/%s/revision/%s/restore" Post.restoreRevision -- 2.45.1 From 43a700eead18a2d78fa050ff87e85336961d2a50 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 9 Mar 2024 22:58:55 -0500 Subject: [PATCH 088/123] WIP on chapter flow (#6) - WIP with Giraffe View Engine for admin views - Added app context to DotLiquid hash; will remove individual fields in v3 --- src/MyWebLog.Domain/ViewModels.fs | 4 +- src/MyWebLog/AdminViews/Admin.fs | 77 ++++++++++ src/MyWebLog/AdminViews/Helpers.fs | 222 ++++++++++++++++++++++++++++ src/MyWebLog/AdminViews/Post.fs | 185 +++++++++++++++++++++++ src/MyWebLog/AdminViews/User.fs | 91 ++++++++++++ src/MyWebLog/DotLiquidBespoke.fs | 20 +-- src/MyWebLog/Handlers/Admin.fs | 19 +-- src/MyWebLog/Handlers/Helpers.fs | 99 ++++++++++--- src/MyWebLog/Handlers/Post.fs | 46 +++--- src/MyWebLog/Handlers/User.fs | 11 +- src/MyWebLog/MyWebLog.fsproj | 4 + src/admin-theme/chapter-edit.liquid | 105 ------------- src/admin-theme/chapters.liquid | 38 ----- src/admin-theme/dashboard.liquid | 59 -------- src/admin-theme/log-on.liquid | 30 ---- 15 files changed, 698 insertions(+), 312 deletions(-) create mode 100644 src/MyWebLog/AdminViews/Admin.fs create mode 100644 src/MyWebLog/AdminViews/Helpers.fs create mode 100644 src/MyWebLog/AdminViews/Post.fs create mode 100644 src/MyWebLog/AdminViews/User.fs delete mode 100644 src/admin-theme/chapter-edit.liquid delete mode 100644 src/admin-theme/chapters.liquid delete mode 100644 src/admin-theme/dashboard.liquid delete mode 100644 src/admin-theme/log-on.liquid diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index afb672b..7f4829a 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -1112,14 +1112,14 @@ type ManageChaptersModel = { Title: string /// The chapters for the post - Chapters: DisplayChapter array + Chapters: Chapter list } with /// Create a model from a post and its episode's chapters static member Create (post: Post) = { Id = string post.Id Title = post.Title - Chapters = post.Episode.Value.Chapters.Value |> List.map DisplayChapter.FromChapter |> Array.ofList } + Chapters = post.Episode.Value.Chapters.Value } /// View model to manage permalinks diff --git a/src/MyWebLog/AdminViews/Admin.fs b/src/MyWebLog/AdminViews/Admin.fs new file mode 100644 index 0000000..e42d68f --- /dev/null +++ b/src/MyWebLog/AdminViews/Admin.fs @@ -0,0 +1,77 @@ +module MyWebLog.AdminViews.Admin + +open Giraffe.ViewEngine +open MyWebLog.ViewModels + +/// The main dashboard +let dashboard (model: DashboardModel) app = [ + h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " • 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 "  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 "  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 "  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/category/new/edit"); _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" ] + ] + ] + ] +] diff --git a/src/MyWebLog/AdminViews/Helpers.fs b/src/MyWebLog/AdminViews/Helpers.fs new file mode 100644 index 0000000..7a6bcdb --- /dev/null +++ b/src/MyWebLog/AdminViews/Helpers.fs @@ -0,0 +1,222 @@ +[] +module MyWebLog.AdminViews.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 +[] +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 + +/// The pattern for a long date +let longDatePattern = + InstantPattern.CreateWithInvariantCulture "MMMM d, yyyy" + +/// Create a long date +let longDate = + longDatePattern.Format >> txt + +/// The pattern for a short time +let shortTimePattern = + InstantPattern.CreateWithInvariantCulture "h:mmtt" + +/// Create a short time +let shortTime instant = + txt (shortTimePattern.Format(instant).ToLower()) + +/// 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 " « Admin « "; 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…" ] ] + 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 + ] diff --git a/src/MyWebLog/AdminViews/Post.fs b/src/MyWebLog/AdminViews/Post.fs new file mode 100644 index 0000000..b1d4994 --- /dev/null +++ b/src/MyWebLog/AdminViews/Post.fs @@ -0,0 +1,185 @@ +module MyWebLog.AdminViews.Post + +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" + +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" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "start_time"; _name "StartTime"; _class "form-control"; _required + _autofocus; _placeholder "Start Time" + if model.Index >= 0 then _value model.StartTime ] + label [ _for "start_time" ] [ raw "Start Time" ] + ] + ] + div [ _class "col-6 col-lg-3 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "end_time"; _name "EndTime"; _class "form-control"; _value model.EndTime + _placeholder "End Time" ] + label [ _for "end_time" ] [ raw "End Time" ] + span [ _class "form-text" ] [ raw "Optional; ends when next starts" ] + ] + ] + div [ _class "col-12 col-lg-6 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "title"; _name "Title"; _class "form-control"; _value model.Title + _placeholder "Title" ] + label [ _for "title" ] [ raw "Chapter Title" ] + span [ _class "form-text" ] [ raw "Optional" ] + ] + ] + div [ _class "col-12 col-lg-6 offset-xl-1 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "image_url"; _name "ImageUrl"; _class "form-control" + _value model.ImageUrl; _placeholder "Image URL" ] + label [ _for "image_url" ] [ raw "Image URL" ] + 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-4 mb-3 align-self-end d-flex flex-column" ] [ + div [ _class "form-check form-switch mb-3" ] [ + input [ _type "checkbox"; _id "is_hidden"; _name "IsHidden"; _class "form-check-input" + _value "true" + if model.IsHidden then _checked ] + label [ _for "is_hidden" ] [ raw "Hidden Chapter" ] + ] + span [ _class "form-text" ] [ raw "Not displayed, but may update image and location" ] + ] + ] + div [ _class "row" ] [ + let hasLoc = model.LocationName <> "" + div [ _class "col-12 col-md-4 col-lg-3 offset-lg-1 mb-3 align-self-end" ] [ + div [ _class "form-check form-switch mb-3" ] [ + input [ _type "checkbox"; _id "has_location"; _class "form-check-input"; _value "true" + if hasLoc then _checked + _onclick "Admin.checkChapterLocation()" ] + label [ _for "has_location" ] [ raw "Associate Location" ] + ] + ] + div [ _class "col-12 col-md-8 col-lg-6 offset-lg-1 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "location_name"; _name "LocationName"; _class "form-control" + _value model.LocationName; _placeholder "Location Name"; _required + if not hasLoc then _disabled ] + label [ _for "location_name" ] [ raw "Name" ] + ] + ] + div [ _class "col-6 col-lg-4 offset-lg-2 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "location_geo"; _name "LocationGeo"; _class "form-control" + _value model.LocationGeo; _placeholder "Location Geo URL" + if not hasLoc then _disabled ] + label [ _for "location_geo" ] [ raw "Geo URL" ] + em [ _class "form-text" ] [ + raw "Optional; " + a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/location/location.md#geo-recommended" + _target "_blank"; _rel "noopener" ] [ + raw "see spec" + ] + ] + ] + ] + div [ _class "col-6 col-lg-4 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "location_osm"; _name "LocationOsm"; _class "form-control" + _value model.LocationOsm; _placeholder "Location OSM Query" + if not hasLoc then _disabled ] + label [ _for "location_osm" ] [ raw "OpenStreetMap ID" ] + em [ _class "form-text" ] [ + raw "Optional; " + a [ _href "https://www.openstreetmap.org/"; _target "_blank"; _rel "noopener" ] [ raw "get ID" ] + raw ", " + a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/location/location.md#osm-recommended" + _target "_blank"; _rel "noopener" ] [ + raw "see spec" + ] + ] + ] + ] + ] + div [ _class "row" ] [ + div [ _class "col" ] [ + let cancelLink = relUrl app $"admin/post/{model.PostId}/chapters" + if model.Index < 0 then + div [ _class "form-check form-switch mb-3" ] [ + input [ _type "checkbox"; _id "add_another"; _name "AddAnother"; _class "form-check-input" + _value "true"; _checked ] + label [ _for "add_another" ] [ raw "Add Another New Chapter" ] + ] + else + input [ _type "hidden"; _name "AddAnother"; _value "false" ] + button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save" ] + 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 "outerHTML" ] [ + antiCsrf app + input [ _type "hidden"; _name "Id"; _value model.Id ] + div [ _class "row mwl-table-heading" ] [ + div [ _class "col" ] [ raw "Start" ] + div [ _class "col" ] [ raw "Title" ] + div [ _class "col" ] [ raw "Image?" ] + div [ _class "col" ] [ raw "Location?" ] + ] + yield! model.Chapters |> List.mapi (fun idx chapter -> + div [ _class "row pb-3 mwl-table-detail"; _id $"chapter{idx}" ] [ + div [ _class "col" ] [ txt (startTimePattern.Format chapter.StartTime) ] + div [ _class "col" ] [ txt (defaultArg chapter.Title "") ] + div [ _class "col" ] [ raw (if Option.isSome chapter.ImageUrl then "Y" else "N") ] + div [ _class "col" ] [ raw (if Option.isSome chapter.Location then "Y" else "N") ] + ]) + div [ _class "row pb-3"; _id "chapter-1" ] [ + if withNew then + yield! chapterEdit (EditChapterModel.FromChapter (PostId model.Id) -1 Chapter.Empty) app + else + let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1" + div [ _class "row pb-3 mwl-table-detail" ] [ + div [ _class "col-12" ] [ + a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1" ] [ + 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 "« Back to Edit Post" + ] + ] + ] + yield! chapterList withNew model app + ] +] diff --git a/src/MyWebLog/AdminViews/User.fs b/src/MyWebLog/AdminViews/User.fs new file mode 100644 index 0000000..3e58130 --- /dev/null +++ b/src/MyWebLog/AdminViews/User.fs @@ -0,0 +1,91 @@ +module MyWebLog.AdminViews.User + +open Giraffe.ViewEngine +open Giraffe.ViewEngine.Htmx +open MyWebLog +open MyWebLog.ViewModels + +/// Page to display the log on page +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" ] [ + div [ _class "form-floating" ] [ + input [ _type "email"; _id "email"; _name "EmailAddress"; _class "form-control"; _autofocus + _required ] + label [ _for "email" ] [ rawText "E-mail Address" ] + ] + ] + 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" ] [ rawText "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 badge = "ms-2 badge bg" + 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 "this"; _hxSwap "outerHTML show:window:top" ] [ + antiCsrf app + for user in model do + div [ _class "row mwl-table-detail"; _id $"user_{user.Id}" ] [ + div [ _class $"col-12 col-md-4 col-xl-3 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 urlBase = $"admin/settings/user/{user.Id}" + small [] [ + a [ _href (relUrl app $"{urlBase}/edit"); _hxTarget $"#user_{user.Id}" + _hxSwap $"innerHTML show:#user_{user.Id}:top" ] [ + raw "Edit" + ] + if app.UserId.Value <> user.Id then + let delLink = relUrl app $"{urlBase}/delete" + span [ _class "text-muted" ] [ raw " • " ] + a [ _href delLink; _hxPost delLink; _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 "col-12 col-md-4 col-xl-4" ] [ + 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" ] [ longDate user.CreatedOn ] + div [ _class "col-12 col-md-4 col-xl-3" ] [ + match user.LastSeenOn with + | Some it -> longDate it; raw " at "; shortTime it + | None -> raw "--" + ] + ] + ] + ] + |> List.singleton \ No newline at end of file diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index eac2c53..ea60ec0 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -6,6 +6,7 @@ open System.IO open System.Web open DotLiquid open Giraffe.ViewEngine +open MyWebLog.AdminViews.Helpers open MyWebLog.ViewModels /// Extensions on the DotLiquid Context object @@ -227,15 +228,16 @@ let register () = typeof; typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof; typeof // View models - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof; typeof; typeof + typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 91904fd..cd92a9a 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -20,17 +20,14 @@ module Dashboard = let! listed = getCount data.Page.CountListed let! cats = getCount data.Category.CountAll let! topCats = getCount data.Category.CountTopLevel - return! - hashForPage "Dashboard" - |> addToHash ViewContext.Model { - Posts = posts - Drafts = drafts - Pages = pages - ListedPages = listed - Categories = cats - TopLevelCategories = topCats - } - |> adminView "dashboard" next ctx + let model = + { Posts = posts + Drafts = drafts + Pages = pages + ListedPages = listed + Categories = cats + TopLevelCategories = topCats } + return! adminPage "Dashboard" false (AdminViews.Admin.dashboard model) next ctx } // GET /admin/administration diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 49a1f5f..70ad2c5 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -3,6 +3,8 @@ module private MyWebLog.Handlers.Helpers open System.Text.Json open Microsoft.AspNetCore.Http +open MyWebLog.AdminViews +open MyWebLog.AdminViews.Helpers /// Session extensions to get and set objects type ISession with @@ -25,6 +27,10 @@ module ViewContext = [] let AntiCsrfTokens = "csrf" + /// The unified application view context + [] + let AppViewContext = "app" + /// The categories for this web log [] let Categories = "categories" @@ -185,32 +191,62 @@ 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 array; messages ] + 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 -> 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 - else - 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) + |> 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? @@ -258,7 +294,7 @@ module Error = (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 @@ -334,6 +370,21 @@ let adminView template = let adminBareView template = bareForTheme adminTheme template +/// Display a page for an admin endpoint +let adminPage pageTitle includeCsrf (content: AppViewContext -> XmlNode list) : HttpHandler = fun next ctx -> 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 (content: AppViewContext -> XmlNode list) : HttpHandler = fun next ctx -> task { + let! messages = getCurrentMessages ctx + let appCtx = generateViewContext pageTitle messages includeCsrf ctx + return! 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 diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 282e9fb..c34fa05 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -379,10 +379,7 @@ let chapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> tas && Option.isSome post.Episode.Value.Chapters && canEdit post.AuthorId ctx -> return! - hashForPage "Manage Chapters" - |> withAntiCsrf ctx - |> addToHash ViewContext.Model (ManageChaptersModel.Create post) - |> adminView "chapters" next ctx + adminPage "Manage Chapters" true (AdminViews.Post.chapters false (ManageChaptersModel.Create post)) next ctx | Some _ | None -> return! Error.notFound next ctx } @@ -401,10 +398,9 @@ let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex match chapter with | Some chap -> return! - hashForPage (if index = -1 then "Add a Chapter" else "Edit Chapter") - |> withAntiCsrf ctx - |> addToHash ViewContext.Model (EditChapterModel.FromChapter post.Id index chap) - |> adminBareView "chapter-edit" next ctx + adminPage + (if index = -1 then "Add a Chapter" else "Edit Chapter") true + (AdminViews.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)) next ctx | None -> return! Error.notFound next ctx | Some _ | None -> return! Error.notFound next ctx } @@ -419,23 +415,23 @@ let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex && canEdit post.AuthorId ctx -> let! form = ctx.BindFormAsync() let chapters = post.Episode.Value.Chapters.Value - if index = -1 || (index >= 0 && index < List.length chapters) then - let updatedPost = - { post with - Episode = Some { - post.Episode.Value with - Chapters = - form.ToChapter() :: (if index = -1 then chapters else chapters |> List.removeAt index) - |> List.sortBy _.StartTime - |> Some } } - do! data.Post.Update updatedPost - do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } - // TODO: handle "add another", only return chapter list vs. entire page with title - return! - hashForPage "Manage Chapters" - |> withAntiCsrf ctx - |> addToHash ViewContext.Model (ManageChaptersModel.Create updatedPost) - |> adminView "chapters" next ctx + if index >= -1 && index < List.length chapters then + try + let chapter = form.ToChapter() + let existing = if index = -1 then chapters else chapters |> List.removeAt index + 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! + adminPage + "Manage Chapters" true + (AdminViews.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)) next ctx + with + | ex -> return! Error.notFound next ctx // TODO: return error else return! Error.notFound next ctx | Some _ | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 979ad9e..454bf9f 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -36,10 +36,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 (AdminViews.User.logOn { LogOnModel.Empty with ReturnTo = returnTo }) next ctx open System.Security.Claims @@ -96,11 +93,7 @@ let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" // GET /admin/settings/users let all : HttpHandler = fun next ctx -> task { let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id - return! - hashForPage "User Administration" - |> withAntiCsrf ctx - |> addToHash "users" (users |> List.map (DisplayUser.FromUser ctx.WebLog) |> Array.ofList) - |> adminBareView "user-list-body" next ctx + return! adminBarePage "User Administration" true (AdminViews.User.userList users) next ctx } /// Show the edit user page diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 076a51b..57bc9e5 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -9,6 +9,10 @@ + + + + diff --git a/src/admin-theme/chapter-edit.liquid b/src/admin-theme/chapter-edit.liquid deleted file mode 100644 index d5e73a0..0000000 --- a/src/admin-theme/chapter-edit.liquid +++ /dev/null @@ -1,105 +0,0 @@ -

      {% if model.index < 0 %}Add{% else %}Edit{% endif %} Chapter

      -

      Times may be entered as seconds; minutes and seconds; or hours, minutes and seconds. Fractional - seconds are supported to two decimal places. -{% assign post_url = "admin/post/" | append: model.post_id | append: "/chapter/" | append: model.index | relative_link %} - - - - -

      -
      -
      - - -
      -
      -
      -
      - - - Optional; ends when next starts -
      -
      -
      -
      - - - Optional -
      -
      -
      -
      - - - Optional; a separate image to display while this chapter is playing -
      -
      -
      -
      - - -
      - Not displayed, but may update image and location -
      -
      -
      - {%- if model.location_name != "" -%}{% assign has_loc = true %}{% else %}{% assign has_loc = false %}{% endif -%} -
      -
      - - -
      -
      -
      -
      - - -
      -
      -
      -
      - - - - Optional; - see spec - -
      -
      -
      -
      - - - - Optional; get ID, - see spec - -
      -
      -
      -
      -
      - {% if model.index < 0 -%} -
      - - -
      - {% else -%} - - {% endif %} - - {% assign cancel_link = "admin/post/" | append: model.post_id | append: "/chapters" | relative_link %} - Cancel -
      -
      - diff --git a/src/admin-theme/chapters.liquid b/src/admin-theme/chapters.liquid deleted file mode 100644 index a61ab41..0000000 --- a/src/admin-theme/chapters.liquid +++ /dev/null @@ -1,38 +0,0 @@ -

      {{ page_title }}

      -
      -
      - - -
      -
      -
      -

      - {{ model.title }}
      - - - « Back to Edit Post - - -

      -
      -
      -
      Start
      -
      Title
      -
      Image?
      -
      Location?
      -
      - {% for chapter in model.chapters %} -
      -
      {{ chapter.start_time }}
      -
      {{ chapter.title }}
      -
      {% if chapter.image_url == "" %}N{% else %}Y{% endif %}
      -
      {% if chapter.location %}Y{% else %}N{% endif %}
      -
      - {% endfor %} -
      - {% assign new_link = "admin/post/" | append: model.id | append: "/chapter/-1" | relative_link %} - Add a New Chapter -
      -
      -
      -
      diff --git a/src/admin-theme/dashboard.liquid b/src/admin-theme/dashboard.liquid deleted file mode 100644 index 782a8c3..0000000 --- a/src/admin-theme/dashboard.liquid +++ /dev/null @@ -1,59 +0,0 @@ -

      {{ web_log.name }} • Dashboard

      -
      -
      -
      -
      -
      Posts
      -
      -
      - Published {{ model.posts }} -   Drafts {{ model.drafts }} -
      - {% if is_author %} - View All - Write a New Post - {% endif %} -
      -
      -
      -
      -
      -
      Pages
      -
      -
      - All {{ model.pages }} -   Shown in Page List {{ model.listed_pages }} -
      - {% if is_author %} - View All - Create a New Page - {% endif %} -
      -
      -
      -
      -
      -
      -
      -
      Categories
      -
      -
      - All {{ model.categories }} -   Top Level {{ model.top_level_categories }} -
      - {% if is_web_log_admin %} - View All - Add a New Category - {% endif %} -
      -
      -
      -
      - {% if is_web_log_admin %} -
      -
      - Modify Settings -
      -
      - {% endif %} -
      diff --git a/src/admin-theme/log-on.liquid b/src/admin-theme/log-on.liquid deleted file mode 100644 index d6880ac..0000000 --- a/src/admin-theme/log-on.liquid +++ /dev/null @@ -1,30 +0,0 @@ -

      Log On to {{ web_log.name }}

      -
      -
      - - {% if model.return_to %} - - {% endif %} -
      -
      -
      -
      - - -
      -
      -
      -
      - - -
      -
      -
      -
      -
      - -
      -
      -
      -
      -
      -- 2.45.1 From 641a7499cc6ddde9536096c97a0b32109f2710af Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 10 Mar 2024 17:13:15 -0400 Subject: [PATCH 089/123] Complete chapter edit page (#6) first cut, anyway... --- src/MyWebLog.Domain/ViewModels.fs | 2 +- src/MyWebLog/DotLiquidBespoke.fs | 2 +- src/MyWebLog/Handlers/Admin.fs | 2 +- src/MyWebLog/Handlers/Helpers.fs | 3 +- src/MyWebLog/Handlers/Post.fs | 35 +++++++++++++++---- src/MyWebLog/Handlers/Routes.fs | 5 +++ src/MyWebLog/Handlers/User.fs | 4 +-- src/MyWebLog/MyWebLog.fsproj | 8 ++--- src/MyWebLog/{AdminViews => Views}/Admin.fs | 2 +- src/MyWebLog/{AdminViews => Views}/Helpers.fs | 2 +- src/MyWebLog/{AdminViews => Views}/Post.fs | 31 ++++++++++++---- src/MyWebLog/{AdminViews => Views}/User.fs | 2 +- 12 files changed, 72 insertions(+), 26 deletions(-) rename src/MyWebLog/{AdminViews => Views}/Admin.fs (99%) rename src/MyWebLog/{AdminViews => Views}/Helpers.fs (99%) rename src/MyWebLog/{AdminViews => Views}/Post.fs (87%) rename src/MyWebLog/{AdminViews => Views}/User.fs (99%) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 7f4829a..5a2afcd 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -419,7 +419,7 @@ type EditChapterModel = { let pattern = match value |> Seq.fold (fun count chr -> if chr = ':' then count + 1 else count) 0 with | 0 -> "S" - | 1 -> "MM:ss" + | 1 -> "M:ss" | 2 -> "H:mm:ss" | _ -> invalidArg name "Max time format is H:mm:ss" |> function diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index ea60ec0..660c215 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -6,8 +6,8 @@ open System.IO open System.Web open DotLiquid open Giraffe.ViewEngine -open MyWebLog.AdminViews.Helpers open MyWebLog.ViewModels +open MyWebLog.Views /// Extensions on the DotLiquid Context object type Context with diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index cd92a9a..6b962e5 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -27,7 +27,7 @@ module Dashboard = ListedPages = listed Categories = cats TopLevelCategories = topCats } - return! adminPage "Dashboard" false (AdminViews.Admin.dashboard model) next ctx + return! adminPage "Dashboard" false (Views.Admin.dashboard model) next ctx } // GET /admin/administration diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 70ad2c5..ad3b611 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -3,8 +3,7 @@ module private MyWebLog.Handlers.Helpers open System.Text.Json open Microsoft.AspNetCore.Http -open MyWebLog.AdminViews -open MyWebLog.AdminViews.Helpers +open MyWebLog.Views /// Session extensions to get and set objects type ISession with diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index c34fa05..d735bd7 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -379,7 +379,7 @@ let chapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> tas && Option.isSome post.Episode.Value.Chapters && canEdit post.AuthorId ctx -> return! - adminPage "Manage Chapters" true (AdminViews.Post.chapters false (ManageChaptersModel.Create post)) next ctx + adminPage "Manage Chapters" true (Views.Post.chapters false (ManageChaptersModel.Create post)) next ctx | Some _ | None -> return! Error.notFound next ctx } @@ -398,9 +398,9 @@ let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex match chapter with | Some chap -> return! - adminPage + adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") true - (AdminViews.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)) next ctx + (Views.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)) next ctx | None -> return! Error.notFound next ctx | Some _ | None -> return! Error.notFound next ctx } @@ -418,7 +418,7 @@ let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex if index >= -1 && index < List.length chapters then try let chapter = form.ToChapter() - let existing = if index = -1 then chapters else chapters |> List.removeAt index + let existing = if index = -1 then chapters else List.removeAt index chapters let updatedPost = { post with Episode = Some @@ -429,9 +429,32 @@ let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex return! adminPage "Manage Chapters" true - (AdminViews.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)) next ctx + (Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)) next ctx with - | ex -> return! Error.notFound next ctx // TODO: return error + | 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! + adminPage + "Manage Chapters" true (Views.Post.chapterList false (ManageChaptersModel.Create updatedPost)) next + ctx else return! Error.notFound next ctx | Some _ | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 8216f07..1729db9 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -216,6 +216,11 @@ let router : HttpHandler = choose [ routef "/%s/delete" Upload.deleteFromDb ]) ] + DELETE >=> validateCsrf >=> choose [ + subRoute "/post" (choose [ + routef "/%s/chapter/%i" Post.deleteChapter + ]) + ] ]) GET_HEAD >=> routexp "/category/(.*)" Post.pageOfCategorizedPosts GET_HEAD >=> routef "/page/%i" Post.pageOfPosts diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 454bf9f..b360df5 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -36,7 +36,7 @@ let logOn returnUrl : HttpHandler = fun next ctx -> match returnUrl with | Some _ -> returnUrl | None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None - adminPage "Log On" true (AdminViews.User.logOn { LogOnModel.Empty with ReturnTo = returnTo }) next ctx + adminPage "Log On" true (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo }) next ctx open System.Security.Claims @@ -93,7 +93,7 @@ let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" // GET /admin/settings/users let all : HttpHandler = fun next ctx -> task { let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id - return! adminBarePage "User Administration" true (AdminViews.User.userList users) next ctx + return! adminBarePage "User Administration" true (Views.User.userList users) next ctx } /// Show the edit user page diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 57bc9e5..c795441 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -9,10 +9,10 @@ - - - - + + + + diff --git a/src/MyWebLog/AdminViews/Admin.fs b/src/MyWebLog/Views/Admin.fs similarity index 99% rename from src/MyWebLog/AdminViews/Admin.fs rename to src/MyWebLog/Views/Admin.fs index e42d68f..335d4ce 100644 --- a/src/MyWebLog/AdminViews/Admin.fs +++ b/src/MyWebLog/Views/Admin.fs @@ -1,4 +1,4 @@ -module MyWebLog.AdminViews.Admin +module MyWebLog.Views.Admin open Giraffe.ViewEngine open MyWebLog.ViewModels diff --git a/src/MyWebLog/AdminViews/Helpers.fs b/src/MyWebLog/Views/Helpers.fs similarity index 99% rename from src/MyWebLog/AdminViews/Helpers.fs rename to src/MyWebLog/Views/Helpers.fs index 7a6bcdb..0c90f15 100644 --- a/src/MyWebLog/AdminViews/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -1,5 +1,5 @@ [] -module MyWebLog.AdminViews.Helpers +module MyWebLog.Views.Helpers open Microsoft.AspNetCore.Antiforgery open Giraffe.ViewEngine diff --git a/src/MyWebLog/AdminViews/Post.fs b/src/MyWebLog/Views/Post.fs similarity index 87% rename from src/MyWebLog/AdminViews/Post.fs rename to src/MyWebLog/Views/Post.fs index b1d4994..f64eb48 100644 --- a/src/MyWebLog/AdminViews/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -1,4 +1,4 @@ -module MyWebLog.AdminViews.Post +module MyWebLog.Views.Post open Giraffe.ViewEngine open Giraffe.ViewEngine.Htmx @@ -9,6 +9,7 @@ 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" ] @@ -128,6 +129,7 @@ let chapterEdit (model: EditChapterModel) app = [ else input [ _type "hidden"; _name "AddAnother"; _value "false" ] button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save" ] + raw "   " a [ _href cancelLink; _hxGet cancelLink; _class "btn btn-secondary"; _hxTarget "body" ] [ raw "Cancel" ] ] ] @@ -146,20 +148,37 @@ let chapterList withNew (model: ManageChaptersModel) app = div [ _class "col" ] [ raw "Location?" ] ] yield! model.Chapters |> List.mapi (fun idx chapter -> - div [ _class "row pb-3 mwl-table-detail"; _id $"chapter{idx}" ] [ + div [ _class "row mwl-table-detail"; _id $"chapter{idx}" ] [ div [ _class "col" ] [ txt (startTimePattern.Format chapter.StartTime) ] - div [ _class "col" ] [ txt (defaultArg chapter.Title "") ] + div [ _class "col" ] [ + txt (defaultArg chapter.Title ""); br [] + small [] [ + if withNew then + raw " " + else + let chapterUrl = relUrl app $"admin/post/{model.Id}/chapter/{idx}" + a [ _href chapterUrl; _hxGet chapterUrl; _hxTarget $"#chapter{idx}" + _hxSwap $"innerHTML show:#chapter{idx}:top" ] [ + raw "Edit" + ] + span [ _class "text-muted" ] [ raw " • " ] + a [ _href chapterUrl; _hxDelete chapterUrl; _class "text-danger" ] [ + raw "Delete" + ] + ] + ] div [ _class "col" ] [ raw (if Option.isSome chapter.ImageUrl then "Y" else "N") ] div [ _class "col" ] [ raw (if Option.isSome chapter.Location then "Y" else "N") ] ]) div [ _class "row pb-3"; _id "chapter-1" ] [ + let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1" if withNew then - yield! chapterEdit (EditChapterModel.FromChapter (PostId model.Id) -1 Chapter.Empty) app + span [ _hxGet newLink; _hxTarget "#chapter-1"; _hxTrigger "load"; _hxSwap "show:#chapter-1:top" ] [] else - let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1" div [ _class "row pb-3 mwl-table-detail" ] [ div [ _class "col-12" ] [ - a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1" ] [ + a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1" + _hxSwap "show:#chapter-1:top" ] [ raw "Add a New Chapter" ] ] diff --git a/src/MyWebLog/AdminViews/User.fs b/src/MyWebLog/Views/User.fs similarity index 99% rename from src/MyWebLog/AdminViews/User.fs rename to src/MyWebLog/Views/User.fs index 3e58130..d395825 100644 --- a/src/MyWebLog/AdminViews/User.fs +++ b/src/MyWebLog/Views/User.fs @@ -1,4 +1,4 @@ -module MyWebLog.AdminViews.User +module MyWebLog.Views.User open Giraffe.ViewEngine open Giraffe.ViewEngine.Htmx -- 2.45.1 From 81039579ea0abdfb2f9bb7a173cdfb47c2697981 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 10 Mar 2024 21:07:30 -0400 Subject: [PATCH 090/123] WIP on ?chapters handler for posts (#6) - Do not show drafts if users are not logged on - Migrate user management to Giraffe View Engine templates --- src/MyWebLog/Handlers/Admin.fs | 79 +++++---- src/MyWebLog/Handlers/Helpers.fs | 4 +- src/MyWebLog/Handlers/Post.fs | 19 ++- src/MyWebLog/Handlers/Routes.fs | 23 ++- src/MyWebLog/Handlers/User.fs | 34 +--- src/MyWebLog/Views/Helpers.fs | 20 ++- src/MyWebLog/Views/User.fs | 231 ++++++++++++++++++++++++-- src/admin-theme/my-info.liquid | 74 --------- src/admin-theme/settings.liquid | 2 +- src/admin-theme/user-edit.liquid | 99 ----------- src/admin-theme/user-list-body.liquid | 61 ------- 11 files changed, 316 insertions(+), 330 deletions(-) delete mode 100644 src/admin-theme/my-info.liquid delete mode 100644 src/admin-theme/user-edit.liquid delete mode 100644 src/admin-theme/user-list-body.liquid diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 6b962e5..e0f61ef 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -531,48 +531,43 @@ module WebLog = // GET /admin/settings let settings : HttpHandler = fun next ctx -> task { let data = ctx.Data - match! TemplateCache.get adminTheme "user-list-body" data with - | Ok userTemplate -> - match! TemplateCache.get adminTheme "tag-mapping-list-body" ctx.Data with - | Ok tagMapTemplate -> - let! allPages = data.Page.All ctx.WebLog.Id - let! themes = data.Theme.All() - let! users = data.WebLogUser.FindByWebLog ctx.WebLog.Id - let! hash = - 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 _.Title.ToLower() - |> List.map (fun p -> KeyValuePair.Create(string p.Id, p.Title)) - } - |> Array.ofSeq) - |> addToHash "themes" ( - themes - |> Seq.ofList - |> Seq.map (fun it -> - KeyValuePair.Create(string it.Id, $"{it.Name} (v{it.Version})")) - |> Array.ofSeq) - |> addToHash "upload_values" [| - KeyValuePair.Create(string Database, "Database") - KeyValuePair.Create(string Disk, "Disk") - |] - |> addToHash "users" (users |> List.map (DisplayUser.FromUser ctx.WebLog) |> Array.ofList) - |> addToHash "rss_model" (EditRssModel.FromRssOptions ctx.WebLog.Rss) - |> addToHash "custom_feeds" ( - ctx.WebLog.Rss.CustomFeeds - |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) - |> Array.ofList) - |> addViewContext ctx - let! hash' = TagMapping.withTagMappings ctx hash - return! - addToHash "user_list" (userTemplate.Render hash') hash' - |> addToHash "tag_mapping_list" (tagMapTemplate.Render hash') - |> adminView "settings" next ctx - | Error message -> return! Error.server message next ctx + match! TemplateCache.get adminTheme "tag-mapping-list-body" ctx.Data with + | Ok tagMapTemplate -> + let! allPages = data.Page.All ctx.WebLog.Id + let! themes = data.Theme.All() + let! hash = + 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 _.Title.ToLower() + |> List.map (fun p -> KeyValuePair.Create(string p.Id, p.Title)) + } + |> Array.ofSeq) + |> addToHash "themes" ( + themes + |> Seq.ofList + |> Seq.map (fun it -> + KeyValuePair.Create(string it.Id, $"{it.Name} (v{it.Version})")) + |> Array.ofSeq) + |> addToHash "upload_values" [| + KeyValuePair.Create(string Database, "Database") + KeyValuePair.Create(string Disk, "Disk") + |] + |> addToHash "rss_model" (EditRssModel.FromRssOptions ctx.WebLog.Rss) + |> addToHash "custom_feeds" ( + ctx.WebLog.Rss.CustomFeeds + |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) + |> Array.ofList) + |> addViewContext ctx + let! hash' = TagMapping.withTagMappings ctx hash + return! + hash' + |> addToHash "tag_mapping_list" (tagMapTemplate.Render hash') + |> adminView "settings" next ctx | Error message -> return! Error.server message next ctx } diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index ad3b611..7f01db7 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -381,7 +381,9 @@ let adminPage pageTitle includeCsrf (content: AppViewContext -> XmlNode list) : let adminBarePage pageTitle includeCsrf (content: AppViewContext -> XmlNode list) : HttpHandler = fun next ctx -> task { let! messages = getCurrentMessages ctx let appCtx = generateViewContext pageTitle messages includeCsrf ctx - return! htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument) next 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 diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index d735bd7..9f0a508 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -207,6 +207,23 @@ let home : HttpHandler = fun next ctx -> task { | None -> return! Error.notFound next ctx } +// GET /{post-permalink}?chapters +let chapters (post: Post) : HttpHandler = + match post.Episode with + | Some ep -> + match ep.Chapters with + | Some chapters -> + + json chapters + | None -> + match ep.ChapterFile with + | Some file -> redirectTo true file + | None -> Error.notFound + | None -> Error.notFound + + +// ~~ ADMINISTRATION ~~ + // GET /admin/posts // GET /admin/posts/page/{pageNbr} let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { @@ -372,7 +389,7 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu } // GET /admin/post/{id}/chapters -let chapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { +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 diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 1729db9..7f6429c 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -29,10 +29,15 @@ module CatchAll = 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 - yield fun next ctx -> - addToHash ViewContext.PageTitle post.Title hash - |> themedView (defaultArg post.Template "single-post") next ctx + 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 -> + 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 match data.Page.FindByPermalink permalink webLog.Id |> await with @@ -130,7 +135,7 @@ let router : HttpHandler = choose [ routef "/%s/revision/%s/preview" Post.previewRevision routef "/%s/revisions" Post.editRevisions routef "/%s/chapter/%i" Post.editChapter - routef "/%s/chapters" Post.chapters + routef "/%s/chapters" Post.manageChapters ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ route "" >=> Admin.WebLog.settings @@ -201,10 +206,7 @@ let router : HttpHandler = choose [ route "/save" >=> Admin.TagMapping.save routef "/%s/delete" Admin.TagMapping.delete ]) - subRoute "/user" (choose [ - route "/save" >=> User.save - routef "/%s/delete" User.delete - ]) + route "/user/save" >=> User.save ]) subRoute "/theme" (choose [ route "/new" >=> Admin.Theme.save @@ -220,6 +222,9 @@ let router : HttpHandler = choose [ subRoute "/post" (choose [ routef "/%s/chapter/%i" Post.deleteChapter ]) + subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ + routef "/user/%s" User.delete + ]) ] ]) GET_HEAD >=> routexp "/category/(.*)" Post.pageOfCategorizedPosts diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index b360df5..fbd1734 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -5,7 +5,6 @@ open System open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Identity open MyWebLog -open NodaTime // ~~ LOG ON / LOG OFF ~~ @@ -84,7 +83,6 @@ let logOff : HttpHandler = fun next ctx -> task { // ~~ ADMINISTRATION ~~ -open System.Collections.Generic open Giraffe.Htmx /// Got no time for URL/form manipulators... @@ -98,16 +96,7 @@ let all : HttpHandler = fun next ctx -> task { /// 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(string Author, "Author") - KeyValuePair.Create(string Editor, "Editor") - KeyValuePair.Create(string WebLogAdmin, "Web Log Admin") - if ctx.HasAccessLevel Administrator then KeyValuePair.Create(string Administrator, "Administrator") - |] - |> adminBareView "user-edit" next ctx + adminBarePage (if model.IsNew then "Add a New User" else "Edit User") true (Views.User.edit model) next ctx // GET /admin/settings/user/{id}/edit let edit usrId : HttpHandler = fun next ctx -> task { @@ -121,7 +110,7 @@ let edit usrId : HttpHandler = fun next ctx -> task { | None -> return! Error.notFound next ctx } -// POST /admin/settings/user/{id}/delete +// 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 @@ -144,21 +133,11 @@ let delete userId : HttpHandler = fun next ctx -> task { | 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" (string user.AccessLevel) - |> addToHash "created_on" (ctx.WebLog.LocalTime user.CreatedOn) - |> addToHash "last_seen_on" (ctx.WebLog.LocalTime (defaultArg user.LastSeenOn (Instant.FromUnixTimeSeconds 0))) - |> adminView "my-info" next ctx - - // 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! adminPage "Edit Your Information" true (Views.User.myInfo (EditMyInfoModel.FromUser user) user) next ctx | None -> return! Error.notFound next ctx } @@ -181,7 +160,10 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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 + return! + adminPage + "Edit Your Information" true + (Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user) next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index 0c90f15..3e8f5d6 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -76,19 +76,27 @@ let raw = rawText /// The pattern for a long date let longDatePattern = - InstantPattern.CreateWithInvariantCulture "MMMM d, yyyy" + ZonedDateTimePattern.CreateWithInvariantCulture("MMMM d, yyyy", DateTimeZoneProviders.Tzdb) /// Create a long date -let longDate = - longDatePattern.Format >> txt +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 = - InstantPattern.CreateWithInvariantCulture "h:mmtt" + ZonedDateTimePattern.CreateWithInvariantCulture("h:mmtt", DateTimeZoneProviders.Tzdb) /// Create a short time -let shortTime instant = - txt (shortTimePattern.Format(instant).ToLower()) +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 /// Functions for generating content in varying layouts module Layout = diff --git a/src/MyWebLog/Views/User.fs b/src/MyWebLog/Views/User.fs index d395825..dedfab2 100644 --- a/src/MyWebLog/Views/User.fs +++ b/src/MyWebLog/Views/User.fs @@ -5,7 +5,130 @@ open Giraffe.ViewEngine.Htmx open MyWebLog open MyWebLog.ViewModels -/// Page to display the log on page +/// 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 "#userList"; _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" ] [ + div [ _class "form-floating" ] [ + input [ _type "email"; _name "Email"; _id "email"; _class "form-control"; _placeholder "E-mail" + _required; _value model.Email ] + label [ _for "email" ] [ raw "E-mail Address" ] + ] + ] + div [ _class "col-12 col-lg-5 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "Url"; _id "url"; _class "form-control"; _placeholder "URL" + _value model.Url ] + label [ _for "url" ] [ raw "User’s Personal URL" ] + ] + ] + ] + div [ _class "row mb-3" ] [ + div [ _class "col-12 col-md-6 col-lg-4 col-xl-3 offset-xl-1 pb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "FirstName"; _id "firstName"; _class "form-control" + _placeholder "First"; _required; _value model.FirstName ] + label [ _for "firstName" ] [ raw "First Name" ] + ] + ] + div [ _class "col-12 col-md-6 col-lg-4 col-xl-3 pb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "LastName"; _id "lastName"; _class "form-control" + _placeholder "Last"; _required; _value model.LastName ] + label [ _for "lastName" ] [ raw "Last Name" ] + ] + ] + div [ _class "col-12 col-md-6 offset-md-3 col-lg-4 offset-lg-0 col-xl-3 offset-xl-1 pb-3" ] [ + div [ _class "form-floating " ] [ + input [ _type "text"; _name "PreferredName"; _id "preferredName"; _class "form-control" + _placeholder "Preferred"; _required; _value model.PreferredName ] + label [ _for "preferredName" ] [ raw "Preferred Name" ] + ] + ] + ] + 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’s password" + ] + ] + ] + div [ _class "row" ] [ + div [ _class "col-12 col-md-6 pb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "password"; _name "Password"; _id "password"; _class "form-control" + _placeholder "Password" + if model.IsNew then _required ] + label [ _for "password" ] [ + if not model.IsNew then raw "New " + raw "Password" + ] + ] + ] + div [ _class "col-12 col-md-6 pb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "password"; _name "PasswordConfirm"; _id "passwordConfirm" + _class "form-control"; _placeholder "Confirm" + if model.IsNew then _required ] + label [ _for "passwordConfirm" ] [ + raw "Confirm" + if not model.IsNew then raw " New" + raw " Password" + ] + ] + ] + ] + ] + ] + ] + div [ _class "row mb-3" ] [ + div [ _class "col text-center" ] [ + button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ]; raw "   " + 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" ] [ @@ -36,6 +159,7 @@ let logOn (model: LogOnModel) (app: AppViewContext) = [ ] ] + /// The list of users for a web log (part of web log settings page) let userList (model: WebLogUser list) app = let badge = "ms-2 badge bg" @@ -47,7 +171,7 @@ let userList (model: WebLogUser list) app = antiCsrf app for user in model do div [ _class "row mwl-table-detail"; _id $"user_{user.Id}" ] [ - div [ _class $"col-12 col-md-4 col-xl-3 no-wrap" ] [ + div [ _class "col-12 col-md-4 col-xl-3 no-wrap" ] [ txt user.PreferredName; raw " " match user.AccessLevel with | Administrator -> span [ _class $"{badge}-success" ] [ raw "ADMINISTRATOR" ] @@ -56,17 +180,16 @@ let userList (model: WebLogUser list) app = | Author -> span [ _class $"{badge}-dark" ] [ raw "AUTHOR" ] br [] if app.IsAdministrator || (app.IsWebLogAdmin && not (user.AccessLevel = Administrator)) then - let urlBase = $"admin/settings/user/{user.Id}" + let userUrl = relUrl app $"admin/settings/user/{user.Id}" small [] [ - a [ _href (relUrl app $"{urlBase}/edit"); _hxTarget $"#user_{user.Id}" + a [ _href $"{userUrl}/edit"; _hxTarget $"#user_{user.Id}" _hxSwap $"innerHTML show:#user_{user.Id}:top" ] [ raw "Edit" ] if app.UserId.Value <> user.Id then - let delLink = relUrl app $"{urlBase}/delete" span [ _class "text-muted" ] [ raw " • " ] - a [ _href delLink; _hxPost delLink; _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.)" ] [ + 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" ] ] @@ -79,13 +202,101 @@ let userList (model: WebLogUser list) app = br []; txt user.Url.Value ] ] - div [ _class "d-none d-xl-block col-xl-2" ] [ longDate user.CreatedOn ] + 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 it; raw " at "; shortTime it + | Some it -> longDate app it; raw " at "; shortTime app it | None -> raw "--" ] ] ] ] - |> List.singleton \ No newline at end of file + |> 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" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "FirstName"; _id "firstName"; _class "form-control"; _autofocus + _required; _placeholder "First"; _value model.FirstName ] + label [ _for "firstName" ] [ raw "First Name" ] + ] + ] + 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.LastName ] + label [ _for "lastName" ] [ raw "Last Name" ] + ] + ] + 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.PreferredName ] + label [ _for "preferredName" ] [ raw "Preferred Name" ] + ] + ] + ] + 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" ] [ + div [ _class "form-floating" ] [ + input [ _type "password"; _name "NewPassword"; _id "newPassword" + _class "form-control"; _placeholder "Password" ] + label [ _for "newPassword" ] [ raw "New Password" ] + ] + ] + 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" ] [ raw "Confirm New Password" ] + ] + ] + ] + ] + ] + ] + div [ _class "row" ] [ + div [ _class "col text-center mb-3" ] [ + button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ] + ] + ] + ] + ] + ] +] diff --git a/src/admin-theme/my-info.liquid b/src/admin-theme/my-info.liquid deleted file mode 100644 index f38e3ad..0000000 --- a/src/admin-theme/my-info.liquid +++ /dev/null @@ -1,74 +0,0 @@ -

      {{ page_title }}

      -
      -
      - -
      -
      - Access Level
      {{ access_level }} -
      -
      - Created
      {{ created_on | date: "MMMM d, yyyy" }} -
      -
      - Last Log On
      - {{ last_seen_on | date: "MMMM d, yyyy" }} at {{ last_seen_on | date: "h:mmtt" | downcase }} -
      -
      -
      -
      -
      -
      -
      - - -
      -
      -
      -
      - - -
      -
      -
      -
      - - -
      -
      -
      -
      -
      -
      - Change Password -
      -

      Optional; leave blank to keep your current password

      -
      -
      -
      -
      - - -
      -
      -
      -
      - - -
      -
      -
      -
      -
      -
      -
      -
      - -
      -
      -
      -
      -
      diff --git a/src/admin-theme/settings.liquid b/src/admin-theme/settings.liquid index ec70201..10ac441 100644 --- a/src/admin-theme/settings.liquid +++ b/src/admin-theme/settings.liquid @@ -122,7 +122,7 @@
      Last Log On
      - {{ user_list }} +
    RSS Settings diff --git a/src/admin-theme/user-edit.liquid b/src/admin-theme/user-edit.liquid deleted file mode 100644 index 84c4171..0000000 --- a/src/admin-theme/user-edit.liquid +++ /dev/null @@ -1,99 +0,0 @@ -
    -
    {{ page_title }}
    -
    - - -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    - {% unless model.is_new %}Change {% endunless %}Password - {% unless model.is_new %} -
    -

    Optional; leave blank not change the user’s password

    -
    - {% endunless %} -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    -
    -
    - - {% if model.is_new %} - - {% else %} - Cancel - {% endif %} -
    -
    -
    -
    diff --git a/src/admin-theme/user-list-body.liquid b/src/admin-theme/user-list-body.liquid deleted file mode 100644 index 8f7545c..0000000 --- a/src/admin-theme/user-list-body.liquid +++ /dev/null @@ -1,61 +0,0 @@ -
    -
    -
    -
    -
    - - {% include_template "_user-list-columns" %} - {%- assign badge = "ms-2 badge bg" -%} - {% for user in users -%} -
    -
    - {{ user.preferred_name }} - {%- if user.access_level == "Administrator" %} - ADMINISTRATOR - {%- elsif user.access_level == "WebLogAdmin" %} - WEB LOG ADMIN - {%- elsif user.access_level == "Editor" %} - EDITOR - {%- elsif user.access_level == "Author" %} - AUTHOR - {%- endif %}
    - {%- unless is_administrator == false and user.access_level == "Administrator" %} - - {%- assign user_url_base = "admin/settings/user/" | append: user.id -%} - - Edit - - {% unless user_id == user.id %} - • - {%- assign user_del_link = user_url_base | append: "/delete" | relative_link -%} - - Delete - - {% endunless %} - - {%- endunless %} -
    - -
    - {{ user.created_on | date: "MMMM d, yyyy" }} -
    -
    - {% if user.last_seen_on %} - {{ user.last_seen_on | date: "MMMM d, yyyy" }} at - {{ user.last_seen_on | date: "h:mmtt" | downcase }} - {% else %} - -- - {% endif %} -
    -
    - {%- endfor %} -
    -
    -- 2.45.1 From 5b8a632e9d046ef6239cbc65feea817e6262ab28 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 10 Mar 2024 22:11:02 -0400 Subject: [PATCH 091/123] Complete main chapter functionality (#6) - Edit page still needs UI tweaks --- src/MyWebLog.Domain/SupportTypes.fs | 6 ++++- src/MyWebLog.Domain/ViewModels.fs | 13 +++++++-- src/MyWebLog/Handlers/Helpers.fs | 5 ++++ src/MyWebLog/Handlers/Post.fs | 36 ++++++++++++++++++++----- src/MyWebLog/Views/Post.fs | 42 ++++++++++++++++++++--------- 5 files changed, 80 insertions(+), 22 deletions(-) diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index acbb7d9..2ba8266 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -164,7 +164,7 @@ type Location = { Name: string /// A geographic coordinate string (RFC 5870) - Geo: string option + Geo: string /// An OpenStreetMap query Osm: string option @@ -182,6 +182,9 @@ type Chapter = { /// 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 @@ -197,6 +200,7 @@ type Chapter = { { StartTime = Duration.Zero Title = None ImageUrl = None + Url = None IsHidden = None EndTime = None Location = None } diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 5a2afcd..bb411aa 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -84,6 +84,9 @@ type DisplayChapter = { /// An image to display for this chapter ImageUrl: string + /// A URL with information about this chapter + Url: string + /// Whether this chapter should be displayed in podcast players IsHidden: bool @@ -106,10 +109,11 @@ type DisplayChapter = { { StartTime = pattern.Format chapter.StartTime Title = defaultArg chapter.Title "" ImageUrl = defaultArg chapter.ImageUrl "" + Url = defaultArg chapter.Url "" IsHidden = defaultArg chapter.IsHidden false EndTime = chapter.EndTime |> Option.map pattern.Format |> Option.defaultValue "" LocationName = chapter.Location |> Option.map _.Name |> Option.defaultValue "" - LocationGeo = chapter.Location |> Option.map _.Geo |> Option.flatten |> Option.defaultValue "" + LocationGeo = chapter.Location |> Option.map _.Geo |> Option.defaultValue "" LocationOsm = chapter.Location |> Option.map _.Osm |> Option.flatten |> Option.defaultValue "" } @@ -379,6 +383,9 @@ type EditChapterModel = { /// An image to display for this chapter ImageUrl: string + /// A URL with information about this chapter + Url: string + /// Whether this chapter should be displayed in podcast players IsHidden: bool @@ -406,6 +413,7 @@ type EditChapterModel = { StartTime = it.StartTime Title = it.Title ImageUrl = it.ImageUrl + Url = it.Url IsHidden = it.IsHidden EndTime = it.EndTime LocationName = it.LocationName @@ -429,10 +437,11 @@ type EditChapterModel = { let location = match noneIfBlank this.LocationName with | None -> None - | Some name -> Some { Name = name; Geo = noneIfBlank this.LocationGeo; Osm = noneIfBlank this.LocationOsm } + | Some name -> Some { Name = name; Geo = this.LocationGeo; Osm = noneIfBlank this.LocationOsm } { StartTime = parseDuration (nameof this.StartTime) this.StartTime Title = noneIfBlank this.Title ImageUrl = noneIfBlank this.ImageUrl + Url = noneIfBlank this.Url IsHidden = if this.IsHidden then Some true else None EndTime = noneIfBlank this.EndTime |> Option.map (parseDuration (nameof this.EndTime)) Location = location } diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 7f01db7..00f7274 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -421,6 +421,11 @@ open System.Threading.Tasks /// Create a Task with a Some result for the given object let someTask<'T> (it: 'T) = Task.FromResult(Some it) +/// 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 System.Collections.Generic open MyWebLog.Data diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 9f0a508..279ca22 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -208,18 +208,42 @@ let home : HttpHandler = fun next ctx -> task { } // GET /{post-permalink}?chapters -let chapters (post: Post) : HttpHandler = +let chapters (post: Post) : HttpHandler = fun next ctx -> match post.Episode with | Some ep -> match ep.Chapters with | Some chapters -> - - json chapters + let chapterData = + chapters + |> Seq.ofList + |> Seq.map (fun it -> + let dic = Dictionary() + 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() + 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() + 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 + json jsonFile next ctx | None -> match ep.ChapterFile with - | Some file -> redirectTo true file - | None -> Error.notFound - | None -> Error.notFound + | Some file -> redirectTo true file next ctx + | None -> Error.notFound next ctx + | None -> Error.notFound next ctx // ~~ ADMINISTRATION ~~ diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index f64eb48..9878310 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -46,7 +46,7 @@ let chapterEdit (model: EditChapterModel) app = [ span [ _class "form-text" ] [ raw "Optional" ] ] ] - div [ _class "col-12 col-lg-6 offset-xl-1 mb-3" ] [ + div [ _class "col-12 col-lg-6 col-xl-5 mb-3" ] [ div [ _class "form-floating" ] [ input [ _type "text"; _id "image_url"; _name "ImageUrl"; _class "form-control" _value model.ImageUrl; _placeholder "Image URL" ] @@ -56,7 +56,17 @@ let chapterEdit (model: EditChapterModel) app = [ ] ] ] - div [ _class "col-12 col-lg-6 col-xl-4 mb-3 align-self-end d-flex flex-column" ] [ + div [ _class "col-12 col-lg-6 col-xl-5 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _id "url"; _name "Url"; _class "form-control"; _value model.Url + _placeholder "URL" ] + label [ _for "url" ] [ raw "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" ] [ div [ _class "form-check form-switch mb-3" ] [ input [ _type "checkbox"; _id "is_hidden"; _name "IsHidden"; _class "form-check-input" _value "true" @@ -87,11 +97,10 @@ let chapterEdit (model: EditChapterModel) app = [ div [ _class "col-6 col-lg-4 offset-lg-2 mb-3" ] [ div [ _class "form-floating" ] [ input [ _type "text"; _id "location_geo"; _name "LocationGeo"; _class "form-control" - _value model.LocationGeo; _placeholder "Location Geo URL" + _value model.LocationGeo; _placeholder "Location Geo URL"; _required if not hasLoc then _disabled ] label [ _for "location_geo" ] [ raw "Geo URL" ] em [ _class "form-text" ] [ - raw "Optional; " a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/location/location.md#geo-recommended" _target "_blank"; _rel "noopener" ] [ raw "see spec" @@ -142,16 +151,19 @@ let chapterList withNew (model: ManageChaptersModel) app = antiCsrf app input [ _type "hidden"; _name "Id"; _value model.Id ] div [ _class "row mwl-table-heading" ] [ - div [ _class "col" ] [ raw "Start" ] - div [ _class "col" ] [ raw "Title" ] - div [ _class "col" ] [ raw "Image?" ] - div [ _class "col" ] [ raw "Location?" ] + 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" ] [ txt (startTimePattern.Format chapter.StartTime) ] - div [ _class "col" ] [ - txt (defaultArg chapter.Title ""); br [] + 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 " " @@ -167,8 +179,12 @@ let chapterList withNew (model: ManageChaptersModel) app = ] ] ] - div [ _class "col" ] [ raw (if Option.isSome chapter.ImageUrl then "Y" else "N") ] - div [ _class "col" ] [ raw (if Option.isSome chapter.Location then "Y" else "N") ] + div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ + raw (match chapter.ImageUrl with Some _ -> "Y" | None -> "N") + ] + div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ + raw (match chapter.Location with Some _ -> "Y" | None -> "N") + ] ]) div [ _class "row pb-3"; _id "chapter-1" ] [ let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1" -- 2.45.1 From 90e6f78248e59a7bf905c012116cb092a4f30375 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 10 Mar 2024 23:14:05 -0400 Subject: [PATCH 092/123] Migrate post list template --- src/MyWebLog/Handlers/Post.fs | 10 ++- src/MyWebLog/Handlers/Routes.fs | 2 +- src/MyWebLog/Views/Post.fs | 107 +++++++++++++++++++++++++++++++ src/admin-theme/post-list.liquid | 98 ---------------------------- 4 files changed, 112 insertions(+), 105 deletions(-) delete mode 100644 src/admin-theme/post-list.liquid diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 279ca22..0555999 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -254,10 +254,7 @@ 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 (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay)) next ctx } // GET /admin/post/{id}/edit @@ -294,12 +291,13 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { | 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 + //return! redirectToGet "admin/posts" next ctx + return! all 1 next ctx } // GET /admin/post/{id}/permalinks diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 7f6429c..835a171 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -184,7 +184,6 @@ let router : HttpHandler = choose [ route "/save" >=> Post.save route "/permalinks" >=> Post.savePermalinks routef "/%s/chapter/%i" Post.saveChapter - routef "/%s/delete" Post.delete routef "/%s/revision/%s/delete" Post.deleteRevision routef "/%s/revision/%s/restore" Post.restoreRevision routef "/%s/revisions/purge" Post.purgeRevisions @@ -220,6 +219,7 @@ let router : HttpHandler = choose [ ] DELETE >=> validateCsrf >=> choose [ subRoute "/post" (choose [ + routef "/%s" Post.delete routef "/%s/chapter/%i" Post.deleteChapter ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index 9878310..2da63c4 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -218,3 +218,110 @@ let chapters withNew (model: ManageChaptersModel) app = [ 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 " • " ] + a [ _href $"{postUrl}/edit" ] [ raw "Edit" ] + if app.IsWebLogAdmin then + span [ _class "text-muted" ] [ raw " • " ] + 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 "« 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 »" + ] + ] + ] + ] + else + p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no posts" ] + ] +] diff --git a/src/admin-theme/post-list.liquid b/src/admin-theme/post-list.liquid deleted file mode 100644 index 010ef56..0000000 --- a/src/admin-theme/post-list.liquid +++ /dev/null @@ -1,98 +0,0 @@ -

    {{ page_title }}

    -
    - Write a New Post - {%- assign post_count = model.posts | size -%} - {%- if post_count > 0 %} -
    - - {%- 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" -%} -
    -
    - PostDate -
    -
    Title
    -
    Author
    -
    Tags
    -
    - {% for post in model.posts -%} -
    -
    - - {%- if post.published_on -%} - Published {{ post.published_on | date: "MMMM d, yyyy" }} - {%- else -%} - Not Published - {%- endif -%} - {%- if post.published_on != post.updated_on -%} - (Updated {{ post.updated_on | date: "MMMM d, yyyy" }}) - {%- endif %} - - - {%- if post.published_on -%} - {{ post.published_on | date: "MMMM d, yyyy" }} - {%- else -%} - Not Published - {%- endif -%} - {%- if post.published_on != post.updated_on %}
    - {{ post.updated_on | date: "MMMM d, yyyy" }} - {%- endif %} -     -
    -
    - {%- if post.episode %}Episode{% endif -%} - {{ post.title }}
    - - View Post - {% if is_editor or is_author and user_id == post.author_id %} - • - Edit - {% endif %} - {% if is_web_log_admin %} - • - {%- assign post_del_link = "admin/post/" | append: post.id | append: "/delete" | relative_link -%} - - Delete - - {% endif %} - -
    -
    - {%- assign tag_count = post.tags | size -%} - - Authored by {{ model.authors | value: post.author_id }} | - {% if tag_count == 0 -%} - No - {%- else -%} - {{ tag_count }} - {%- endif %} Tag{% unless tag_count == 1 %}s{% endunless %} - - {{ model.authors | value: post.author_id }} -
    -
    - {{ post.tags | join: ", " }} -
    -
    - {%- endfor %} -
    - {% if model.newer_link or model.older_link %} -
    -
    - {% if model.newer_link %} -

    « Newer Posts - {% endif %} -

    -
    - {% if model.older_link %} -

    Older Posts » - {% endif %} -

    -
    - {% endif %} - {% else %} -

    This web log has no posts - {% endif %} -

    -- 2.45.1 From 5f114c79556d69194e3b40cf67e98226b50b18b8 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 12 Mar 2024 18:58:15 -0400 Subject: [PATCH 093/123] Move redirect/tag map templates to GVE - Fix chapter tests - Apply generator string change for next release --- src/MyWebLog.Tests/Domain/ViewModelsTests.fs | 10 +- src/MyWebLog/Handlers/Admin.fs | 159 ++++++-------- src/MyWebLog/Handlers/Routes.fs | 18 +- src/MyWebLog/Views/Admin.fs | 218 +++++++++++++++++++ src/MyWebLog/Views/Helpers.fs | 4 + src/MyWebLog/Views/Post.fs | 13 +- src/MyWebLog/Views/User.fs | 8 +- src/MyWebLog/appsettings.json | 1 - src/admin-theme/redirect-edit.liquid | 48 ---- src/admin-theme/redirect-list.liquid | 75 ------- src/admin-theme/settings.liquid | 2 +- src/admin-theme/tag-mapping-edit.liquid | 27 --- src/admin-theme/tag-mapping-list-body.liquid | 43 ---- 13 files changed, 309 insertions(+), 317 deletions(-) delete mode 100644 src/admin-theme/redirect-edit.liquid delete mode 100644 src/admin-theme/redirect-list.liquid delete mode 100644 src/admin-theme/tag-mapping-edit.liquid delete mode 100644 src/admin-theme/tag-mapping-list-body.liquid diff --git a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs index 0915383..e00af60 100644 --- a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs @@ -52,12 +52,14 @@ let displayChapterTests = testList "DisplayChapter.FromChapter" [ { StartTime = Duration.FromSeconds 7201.43242 Title = Some "My Test Chapter" ImageUrl = Some "two-hours-in.jpg" + Url = Some "https://example.com/about" IsHidden = Some true EndTime = Some (Duration.FromSeconds 7313.788) - Location = Some { Name = "Over Here"; Geo = Some "geo:23432"; Osm = Some "SF98fFSu-8" } } + Location = Some { Name = "Over Here"; Geo = "geo:23432"; Osm = Some "SF98fFSu-8" } } Expect.equal chapter.StartTime "2:00:01.43" "Start time not filled/formatted properly" Expect.equal chapter.Title "My Test Chapter" "Title not filled properly" Expect.equal chapter.ImageUrl "two-hours-in.jpg" "Image URL not filled properly" + Expect.equal chapter.Url "https://example.com/about" "URL not filled properly" Expect.isTrue chapter.IsHidden "Is hidden flag not filled properly" Expect.equal chapter.EndTime "2:01:53.78" "End time not filled/formatted properly" Expect.equal chapter.LocationName "Over Here" "Location name not filled properly" @@ -1121,9 +1123,9 @@ let manageChaptersModelTests = testList "ManageChaptersModel.Create" [ Expect.equal model.Id "test-post" "ID not filled properly" Expect.equal model.Title "Look at all these chapters" "Title not filled properly" Expect.hasLength model.Chapters 3 "There should be three chapters" - Expect.equal model.Chapters[0].StartTime "0:00:18" "First chapter not filled properly" - Expect.equal model.Chapters[1].StartTime "0:00:36" "Second chapter not filled properly" - Expect.equal model.Chapters[2].StartTime "0:03:00.7" "Third chapter not filled properly" + Expect.equal model.Chapters[0].StartTime (Duration.FromSeconds 18L) "First chapter not filled properly" + Expect.equal model.Chapters[1].StartTime (Duration.FromSeconds 36L) "Second chapter not filled properly" + Expect.equal model.Chapters[2].StartTime (Duration.FromSeconds 180.7) "Third chapter not filled properly" } ] diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index e0f61ef..e04a9b1 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -214,34 +214,24 @@ module RedirectRules = open Microsoft.AspNetCore.Http // GET /admin/settings/redirect-rules - let all : HttpHandler = fun next ctx -> task { - return! - hashForPage "Redirect Rules" - |> withAntiCsrf ctx - |> addToHash "redirections" ctx.WebLog.RedirectRules - |> adminView "redirect-list" next ctx - } + let all : HttpHandler = fun next ctx -> + adminPage "Redirect Rules" true (Views.Admin.redirectList ctx.WebLog.RedirectRules) next ctx // GET /admin/settings/redirect-rules/[index] - let edit idx : HttpHandler = fun next ctx -> task { - if idx = -1 then - return! - hashForPage "Add Redirect Rule" - |> addToHash "model" (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty) - |> withAntiCsrf ctx - |> adminBareView "redirect-edit" next ctx - else - let rules = ctx.WebLog.RedirectRules - if rules.Length < idx || idx < 0 then - return! Error.notFound next ctx - else - return! - hashForPage "Edit Redirect Rule" - |> addToHash "model" (EditRedirectRuleModel.FromRule idx (List.item idx rules)) - |> withAntiCsrf ctx - |> adminBareView "redirect-edit" next ctx - } - + let edit idx : HttpHandler = fun next ctx -> + let titleAndModel = + if idx = -1 then + Some ("Add", Views.Admin.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty)) + else + let rules = ctx.WebLog.RedirectRules + if rules.Length < idx || idx < 0 then + None + else + Some ("Edit", (Views.Admin.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules)))) + match titleAndModel with + | Some (title, model) -> adminBarePage $"{title} Redirect Rule" true model next ctx + | 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 @@ -251,16 +241,15 @@ module RedirectRules = // POST /admin/settings/redirect-rules/[index] let save idx : HttpHandler = fun next ctx -> task { - let! model = ctx.BindFormAsync() - let isNew = idx = -1 - let rules = ctx.WebLog.RedirectRules - let rule = model.ToRule() - let newRules = - match isNew with - | true when model.InsertAtTop -> List.insertAt 0 rule rules - | true -> List.insertAt rules.Length rule rules - | false -> rules |> List.removeAt idx |> List.insertAt idx rule - do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } + let! model = ctx.BindFormAsync() + 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 } @@ -287,7 +276,7 @@ module RedirectRules = return! all next ctx } - // POST /admin/settings/redirect-rules/[index]/delete + // 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 @@ -302,25 +291,10 @@ module RedirectRules = /// ~~~ TAG MAPPINGS ~~~ module TagMapping = - open Microsoft.AspNetCore.Http - - /// Add tag mappings to the given hash - let withTagMappings (ctx: HttpContext) hash = task { - let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id - return - addToHash "mappings" mappings hash - |> addToHash "mapping_ids" ( - mappings - |> List.map (fun it -> { Name = it.Tag; Value = string it.Id })) - } - // GET /admin/settings/tag-mappings let all : HttpHandler = fun next ctx -> task { - let! hash = - hashForPage "" - |> withAntiCsrf ctx - |> withTagMappings ctx - return! adminBareView "tag-mapping-list-body" next ctx hash + let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id + return! adminBarePage "Tag Mapping List" true (Views.Admin.tagMapList mappings) next ctx } // GET /admin/settings/tag-mapping/{id}/edit @@ -332,10 +306,9 @@ module TagMapping = 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 + adminBarePage + (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") true + (Views.Admin.tagMapEdit (EditTagMapModel.FromMapping tm)) next ctx | None -> return! Error.notFound next ctx } @@ -354,7 +327,7 @@ module TagMapping = | None -> return! Error.notFound next ctx } - // POST /admin/settings/tag-mapping/{id}/delete + // 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" } @@ -531,44 +504,36 @@ module WebLog = // GET /admin/settings let settings : HttpHandler = fun next ctx -> task { let data = ctx.Data - match! TemplateCache.get adminTheme "tag-mapping-list-body" ctx.Data with - | Ok tagMapTemplate -> - let! allPages = data.Page.All ctx.WebLog.Id - let! themes = data.Theme.All() - let! hash = - 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 _.Title.ToLower() - |> List.map (fun p -> KeyValuePair.Create(string p.Id, p.Title)) - } - |> Array.ofSeq) - |> addToHash "themes" ( - themes - |> Seq.ofList - |> Seq.map (fun it -> - KeyValuePair.Create(string it.Id, $"{it.Name} (v{it.Version})")) - |> Array.ofSeq) - |> addToHash "upload_values" [| - KeyValuePair.Create(string Database, "Database") - KeyValuePair.Create(string Disk, "Disk") - |] - |> addToHash "rss_model" (EditRssModel.FromRssOptions ctx.WebLog.Rss) - |> addToHash "custom_feeds" ( - ctx.WebLog.Rss.CustomFeeds - |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) - |> Array.ofList) - |> addViewContext ctx - let! hash' = TagMapping.withTagMappings ctx hash - return! - hash' - |> addToHash "tag_mapping_list" (tagMapTemplate.Render hash') - |> adminView "settings" next ctx - | Error message -> return! Error.server message next ctx + let! allPages = data.Page.All ctx.WebLog.Id + let! themes = data.Theme.All() + 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 _.Title.ToLower() + |> List.map (fun p -> KeyValuePair.Create(string p.Id, p.Title)) + } + |> Array.ofSeq) + |> addToHash "themes" ( + themes + |> Seq.ofList + |> Seq.map (fun it -> + KeyValuePair.Create(string it.Id, $"{it.Name} (v{it.Version})")) + |> Array.ofSeq) + |> addToHash "upload_values" [| + KeyValuePair.Create(string Database, "Database") + KeyValuePair.Create(string Disk, "Disk") + |] + |> addToHash "rss_model" (EditRssModel.FromRssOptions ctx.WebLog.Rss) + |> addToHash "custom_feeds" ( + ctx.WebLog.Rss.CustomFeeds + |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) + |> Array.ofList) + |> adminView "settings" next ctx } // POST /admin/settings diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 835a171..a4ef6f9 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -196,16 +196,12 @@ let router : HttpHandler = choose [ routef "/%s/delete" Feed.deleteCustomFeed ]) subRoute "/redirect-rules" (choose [ - routef "/%i" Admin.RedirectRules.save - routef "/%i/up" Admin.RedirectRules.moveUp - routef "/%i/down" Admin.RedirectRules.moveDown - routef "/%i/delete" Admin.RedirectRules.delete + routef "/%i" Admin.RedirectRules.save + routef "/%i/up" Admin.RedirectRules.moveUp + routef "/%i/down" Admin.RedirectRules.moveDown ]) - subRoute "/tag-mapping" (choose [ - route "/save" >=> Admin.TagMapping.save - routef "/%s/delete" Admin.TagMapping.delete - ]) - route "/user/save" >=> User.save + route "/tag-mapping/save" >=> Admin.TagMapping.save + route "/user/save" >=> User.save ]) subRoute "/theme" (choose [ route "/new" >=> Admin.Theme.save @@ -223,7 +219,9 @@ let router : HttpHandler = choose [ routef "/%s/chapter/%i" Post.deleteChapter ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ - routef "/user/%s" User.delete + routef "/user/%s" User.delete + routef "/redirect-rules/%i" Admin.RedirectRules.delete + routef "/tag-mapping/%s" Admin.TagMapping.delete ]) ] ]) diff --git a/src/MyWebLog/Views/Admin.fs b/src/MyWebLog/Views/Admin.fs index 335d4ce..7e4aac1 100644 --- a/src/MyWebLog/Views/Admin.fs +++ b/src/MyWebLog/Views/Admin.fs @@ -1,6 +1,10 @@ module MyWebLog.Views.Admin +open Giraffe.Htmx.Common open Giraffe.ViewEngine +open Giraffe.ViewEngine.Accessibility +open Giraffe.ViewEngine.Htmx +open MyWebLog open MyWebLog.ViewModels /// The main dashboard @@ -75,3 +79,217 @@ let dashboard (model: DashboardModel) app = [ ] ] ] + + +/// 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" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "From"; _id "from"; _class "form-control" + _placeholder "From local URL/pattern"; _autofocus; _required; _value model.From ] + label [ _for "from" ] [ raw "From" ] + ] + ] + div [ _class "col-12 col-lg-5 mb-3" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "To"; _id "to"; _class "form-control"; _placeholder "To URL/pattern" + _required; _value model.To ] + label [ _for "to" ] [ raw "To" ] + ] + ] + div [ _class "col-12 col-lg-2 mb-3" ] [ + div [ _class "form-check form-switch" ] [ + input [ _type "checkbox"; _name "IsRegex"; _id "isRegex"; _class "form-check-input"; _value "true" + if model.IsRegex then _checked ] + label [ _for "isRegex" ] [ raw "Use RegEx" ] + ] + ] + ] + 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" ] [ + button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ] + 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 + span [ _class "text-muted" ] [ raw " • " ] + a [ _href $"{ruleUrl}/up"; _hxPost $"{ruleUrl}/up" ] [ raw "Move Up" ] + if idx <> model.Length - 1 then + span [ _class "text-muted" ] [ raw " • " ] + a [ _href $"{ruleUrl}/down"; _hxPost $"{ruleUrl}/down" ] [ raw "Move Down" ] + span [ _class "text-muted" ] [ raw " • " ] + 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 "« Back to Settings" ] + ] + div [ _class "container" ] [ + div [ _class "row" ] [ + div [ _class "col" ] [ + a [ _href (relUrl app "admin/settings/redirect-rules/-1"); _class "btn btn-primary btn-sm mb-3" + _hxTarget "#rule_new" ] [ + raw "Add Redirect Rule" + ] + ] + ] + div [ _class "row" ] [ + div [ _class "col" ] [ + 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" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "Tag"; _id "tag"; _class "form-control"; _placeholder "Tag"; _autofocus + _required; _value model.Tag ] + label [ _for "tag" ] [ raw "Tag" ] + ] + ] + div [ _class "col-6 col-lg-4" ] [ + div [ _class "form-floating" ] [ + input [ _type "text"; _name "UrlValue"; _id "urlValue"; _class "form-control" + _placeholder "URL Value"; _required; _value model.UrlValue ] + label [ _for "urlValue" ] [ raw "URL Value" ] + ] + ] + ] + div [ _class "row mb-3" ] [ + div [ _class "col text-center" ] [ + button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ]; raw "   " + 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" + ] + span [ _class "text-muted" ] [ raw " • " ] + 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" ] [ + div [ _class "row" ] [ + div [ _class "col" ] [ + 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 diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index 3e8f5d6..cd09280 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -98,6 +98,10 @@ let shortTime app (instant: Instant) = |> 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") + /// Functions for generating content in varying layouts module Layout = diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index 2da63c4..d3e5660 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -1,5 +1,6 @@ module MyWebLog.Views.Post +open Giraffe.Htmx.Common open Giraffe.ViewEngine open Giraffe.ViewEngine.Htmx open MyWebLog @@ -147,7 +148,7 @@ let chapterEdit (model: EditChapterModel) app = [ /// Display a list of chapters let chapterList withNew (model: ManageChaptersModel) app = - form [ _method "post"; _id "chapter_list"; _class "container mb-3"; _hxTarget "this"; _hxSwap "outerHTML" ] [ + 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" ] [ @@ -170,7 +171,7 @@ let chapterList withNew (model: ManageChaptersModel) app = else let chapterUrl = relUrl app $"admin/post/{model.Id}/chapter/{idx}" a [ _href chapterUrl; _hxGet chapterUrl; _hxTarget $"#chapter{idx}" - _hxSwap $"innerHTML show:#chapter{idx}:top" ] [ + _hxSwap $"{HxSwap.InnerHtml} show:#chapter{idx}:top" ] [ raw "Edit" ] span [ _class "text-muted" ] [ raw " • " ] @@ -179,12 +180,8 @@ let chapterList withNew (model: ManageChaptersModel) app = ] ] ] - div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ - raw (match chapter.ImageUrl with Some _ -> "Y" | None -> "N") - ] - div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ - raw (match chapter.Location with Some _ -> "Y" | None -> "N") - ] + 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" diff --git a/src/MyWebLog/Views/User.fs b/src/MyWebLog/Views/User.fs index dedfab2..90c0116 100644 --- a/src/MyWebLog/Views/User.fs +++ b/src/MyWebLog/Views/User.fs @@ -1,5 +1,6 @@ module MyWebLog.Views.User +open Giraffe.Htmx.Common open Giraffe.ViewEngine open Giraffe.ViewEngine.Htmx open MyWebLog @@ -12,7 +13,7 @@ let edit (model: EditUserModel) app = div [ _class "col-12" ] [ h5 [ _class "my-3" ] [ txt app.PageTitle ] form [ _hxPost (relUrl app "admin/settings/user/save"); _method "post"; _class "container" - _hxTarget "#userList"; _hxSwap "outerHTML show:window:top" ] [ + _hxTarget "#userList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ antiCsrf app input [ _type "hidden"; _name "Id"; _value model.Id ] div [ _class "row" ] [ @@ -167,7 +168,8 @@ let userList (model: WebLogUser list) app = div [ _class "container g-0" ] [ div [ _class "row mwl-table-detail"; _id "user_new" ] [] ] - form [ _method "post"; _class "container g-0"; _hxTarget "this"; _hxSwap "outerHTML show:window:top" ] [ + form [ _method "post"; _class "container g-0"; _hxTarget "this" + _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ antiCsrf app for user in model do div [ _class "row mwl-table-detail"; _id $"user_{user.Id}" ] [ @@ -183,7 +185,7 @@ let userList (model: WebLogUser list) app = let userUrl = relUrl app $"admin/settings/user/{user.Id}" small [] [ a [ _href $"{userUrl}/edit"; _hxTarget $"#user_{user.Id}" - _hxSwap $"innerHTML show:#user_{user.Id}:top" ] [ + _hxSwap $"{HxSwap.InnerHtml} show:#user_{user.Id}:top" ] [ raw "Edit" ] if app.UserId.Value <> user.Id then diff --git a/src/MyWebLog/appsettings.json b/src/MyWebLog/appsettings.json index 5956ea7..102b5a3 100644 --- a/src/MyWebLog/appsettings.json +++ b/src/MyWebLog/appsettings.json @@ -1,5 +1,4 @@ { - "Generator": "myWebLog 2.0", "Generator": "myWebLog 2.1", "Logging": { "LogLevel": { diff --git a/src/admin-theme/redirect-edit.liquid b/src/admin-theme/redirect-edit.liquid deleted file mode 100644 index 15b273b..0000000 --- a/src/admin-theme/redirect-edit.liquid +++ /dev/null @@ -1,48 +0,0 @@ -

    {% if model.rule_id < 0 %}Add{% else %}Edit{% endif %} Redirect Rule

    -{%- assign post_url = "admin/settings/redirect-rules/" | append: model.rule_id | relative_link -%} -
    - - -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    - {% if model.rule_id < 0 %} -
    -
    - -
    - - - - -
    -
    -
    - {% endif %} -
    -
    - - Cancel -
    -
    -
    diff --git a/src/admin-theme/redirect-list.liquid b/src/admin-theme/redirect-list.liquid deleted file mode 100644 index d78eaaf..0000000 --- a/src/admin-theme/redirect-list.liquid +++ /dev/null @@ -1,75 +0,0 @@ -

    {{ page_title }}

    -
    -

    - « Back to Settings -

    -
    -
    -
    - - Add Redirect Rule - -
    -
    -
    -
    - {%- assign redir_count = redirections | size -%} - {% if redir_count > 0 -%} -
    -
    -
    From
    -
    To
    -
    RegEx?
    -
    -
    -
    -
    - - {% for redir in redirections -%} - {%- assign redir_id = "redir_" | append: forloop.index0 -%} -
    -
    - {{ redir.from }}
    - - {%- assign redir_url = "admin/settings/redirect-rules/" | append: forloop.index0 -%} - - Edit - - {% unless forloop.first %} - • - {%- assign move_up = redir_url | append: "/up" | relative_link -%} - Move Up - {% endunless %} - {% unless forloop.last %} - • - {%- assign move_down = redir_url | append: "/down" | relative_link -%} - Move Down - {% endunless %} - • - {%- assign del_url = redir_url | append: "/delete" | relative_link -%} - - Delete - - -
    -
    {{ redir.to }}
    -
    {% if redir.is_regex %}Yes{% else %}No{% endif %}
    -
    - {%- endfor %} -
    - {%- else -%} -
    -

    This web log has no redirect rules defined -

    - {%- endif %} -
    -
    -
    -

    - This is an advanced feature; please - read and understand the documentation on this feature before adding rules. -

    diff --git a/src/admin-theme/settings.liquid b/src/admin-theme/settings.liquid index 10ac441..4f8e2d8 100644 --- a/src/admin-theme/settings.liquid +++ b/src/admin-theme/settings.liquid @@ -244,6 +244,6 @@ hx-target=#tag_new> Add a New Tag Mapping - {{ tag_mapping_list }} +
    diff --git a/src/admin-theme/tag-mapping-edit.liquid b/src/admin-theme/tag-mapping-edit.liquid deleted file mode 100644 index 1c5e8c7..0000000 --- a/src/admin-theme/tag-mapping-edit.liquid +++ /dev/null @@ -1,27 +0,0 @@ -
    {{ page_title }}
    -
    - - -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    - - Cancel -
    -
    -
    diff --git a/src/admin-theme/tag-mapping-list-body.liquid b/src/admin-theme/tag-mapping-list-body.liquid deleted file mode 100644 index 6ed58e2..0000000 --- a/src/admin-theme/tag-mapping-list-body.liquid +++ /dev/null @@ -1,43 +0,0 @@ -
    -
    -
    - {%- assign map_count = mappings | size -%} - {% if map_count > 0 -%} -
    -
    -
    Tag
    -
    URL Value
    -
    -
    -
    - -
    - {% for map in mappings -%} - {%- assign map_id = mapping_ids | value: map.tag -%} -
    -
    - {{ map.tag }}
    - - {%- assign map_url = "admin/settings/tag-mapping/" | append: map_id -%} - - Edit - - • - {%- assign map_del_link = map_url | append: "/delete" | relative_link -%} - - Delete - - -
    -
    {{ map.url_value }}
    -
    - {%- endfor %} -
    - {%- else -%} -

    This web log has no tag mappings

    - {%- endif %} -
    -
    -
    -- 2.45.1 From b99cd5b94bc3830ccb7e20feb963770dbb977ff0 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 12 Mar 2024 22:57:47 -0400 Subject: [PATCH 094/123] Migrate more templates to GVE --- src/MyWebLog.Domain/ViewModels.fs | 30 +--- src/MyWebLog.Tests/Domain/ViewModelsTests.fs | 12 -- src/MyWebLog/DotLiquidBespoke.fs | 14 +- src/MyWebLog/Handlers/Admin.fs | 85 +++++------- src/MyWebLog/Handlers/Helpers.fs | 16 +-- src/MyWebLog/Handlers/Page.fs | 18 ++- src/MyWebLog/Handlers/Post.fs | 38 +++--- src/MyWebLog/Handlers/Routes.fs | 14 +- src/MyWebLog/Handlers/User.fs | 15 +- src/MyWebLog/Views/Admin.fs | 88 ++++++++++++ src/MyWebLog/Views/Helpers.fs | 136 +++++++++++++++++++ src/MyWebLog/Views/User.fs | 117 +++++++++------- src/admin-theme/_theme-list-columns.liquid | 3 - src/admin-theme/_user-list-columns.liquid | 4 - src/admin-theme/admin-dashboard.liquid | 14 +- src/admin-theme/permalinks.liquid | 59 -------- src/admin-theme/revisions.liquid | 65 --------- src/admin-theme/settings.liquid | 13 -- src/admin-theme/theme-list-body.liquid | 33 ----- src/admin-theme/theme-upload.liquid | 30 ---- 20 files changed, 387 insertions(+), 417 deletions(-) delete mode 100644 src/admin-theme/_theme-list-columns.liquid delete mode 100644 src/admin-theme/_user-list-columns.liquid delete mode 100644 src/admin-theme/permalinks.liquid delete mode 100644 src/admin-theme/revisions.liquid delete mode 100644 src/admin-theme/theme-list-body.liquid delete mode 100644 src/admin-theme/theme-upload.liquid diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index bb411aa..1e802aa 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -204,26 +204,6 @@ type DisplayPage = { } -/// Information about a revision used for display -[] -type DisplayRevision = { - /// The as-of date/time for the revision - AsOf: DateTime - - /// The as-of date/time for the revision in the web log's local time zone - AsOfLocal: DateTime - - /// The format of the text of the revision - Format: string -} with - - /// Create a display revision from an actual revision - static member FromRevision (webLog: WebLog) (rev : Revision) = - { AsOf = rev.AsOf.ToDateTimeUtc() - AsOfLocal = webLog.LocalTime rev.AsOf - Format = rev.Text.SourceType } - - open System.IO /// Information about a theme used for display @@ -1180,22 +1160,22 @@ type ManageRevisionsModel = { CurrentTitle: string /// The revisions for the page or post - Revisions: DisplayRevision array + Revisions: Revision list } with /// Create a revision model from a page - static member FromPage webLog (page: Page) = + static member FromPage (page: Page) = { Id = string page.Id Entity = "page" CurrentTitle = page.Title - Revisions = page.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList } + Revisions = page.Revisions } /// Create a revision model from a post - static member FromPost webLog (post: Post) = + static member FromPost (post: Post) = { Id = string post.Id Entity = "post" CurrentTitle = post.Title - Revisions = post.Revisions |> List.map (DisplayRevision.FromRevision webLog) |> Array.ofList } + Revisions = post.Revisions } /// View model for posts in a list diff --git a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs index e00af60..a4bb736 100644 --- a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs @@ -179,17 +179,6 @@ let displayPageTests = testList "DisplayPage" [ ] ] -/// Unit tests for the DisplayRevision type -let displayRevisionTests = test "DisplayRevision.FromRevision succeeds" { - let model = - DisplayRevision.FromRevision - { WebLog.Empty with TimeZone = "Etc/GMT+1" } - { Text = Html "howdy"; AsOf = Noda.epoch } - Expect.equal model.AsOf (Noda.epoch.ToDateTimeUtc()) "AsOf not filled properly" - Expect.equal model.AsOfLocal ((Noda.epoch - Duration.FromHours 1).ToDateTimeUtc()) "AsOfLocal not filled properly" - Expect.equal model.Format "HTML" "Format not filled properly" -} - open System.IO /// Unit tests for the DisplayTheme type @@ -1346,7 +1335,6 @@ let all = testList "ViewModels" [ displayChapterTests displayCustomFeedTests displayPageTests - displayRevisionTests displayThemeTests displayUploadTests displayUserTests diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 660c215..fe1c9d7 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -228,16 +228,10 @@ let register () = typeof; typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof; typeof // View models - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof; typeof; typeof - typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index e04a9b1..d00239d 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -27,45 +27,35 @@ module Dashboard = ListedPages = listed Categories = cats TopLevelCategories = topCats } - return! adminPage "Dashboard" false (Views.Admin.dashboard model) next ctx + return! adminPage "Dashboard" false next ctx (Views.Admin.dashboard model) } // GET /admin/administration let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { - match! TemplateCache.get adminTheme "theme-list-body" ctx.Data with - | Ok bodyTemplate -> - let! themes = ctx.Data.Theme.All() - let cachedTemplates = TemplateCache.allNames () - let! hash = - hashForPage "myWebLog Administration" - |> withAntiCsrf ctx - |> addToHash "themes" ( - themes - |> List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) - |> Array.ofList) - |> addToHash "cached_themes" ( - themes - |> Seq.ofList - |> Seq.map (fun it -> [| - string it.Id - it.Name - cachedTemplates - |> List.filter _.StartsWith(string it.Id) - |> List.length - |> string - |]) - |> Array.ofSeq) - |> addToHash "web_logs" ( - WebLogCache.all () - |> Seq.ofList - |> Seq.sortBy _.Name - |> Seq.map (fun it -> [| string it.Id; it.Name; it.UrlBase |]) - |> Array.ofSeq) - |> addViewContext ctx - return! - addToHash "theme_list" (bodyTemplate.Render hash) hash - |> adminView "admin-dashboard" next ctx - | Error message -> return! Error.server message next ctx + let! themes = ctx.Data.Theme.All() + let cachedTemplates = TemplateCache.allNames () + return! + hashForPage "myWebLog Administration" + |> withAntiCsrf ctx + |> addToHash "cached_themes" ( + themes + |> Seq.ofList + |> Seq.map (fun it -> [| + string it.Id + it.Name + cachedTemplates + |> List.filter _.StartsWith(string it.Id) + |> List.length + |> string + |]) + |> Array.ofSeq) + |> addToHash "web_logs" ( + WebLogCache.all () + |> Seq.ofList + |> Seq.sortBy _.Name + |> Seq.map (fun it -> [| string it.Id; it.Name; it.UrlBase |]) + |> Array.ofSeq) + |> adminView "admin-dashboard" next ctx } /// Redirect the user to the admin dashboard @@ -215,11 +205,11 @@ module RedirectRules = // GET /admin/settings/redirect-rules let all : HttpHandler = fun next ctx -> - adminPage "Redirect Rules" true (Views.Admin.redirectList ctx.WebLog.RedirectRules) next ctx + adminPage "Redirect Rules" true next ctx (Views.Admin.redirectList ctx.WebLog.RedirectRules) // GET /admin/settings/redirect-rules/[index] let edit idx : HttpHandler = fun next ctx -> - let titleAndModel = + let titleAndView = if idx = -1 then Some ("Add", Views.Admin.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty)) else @@ -228,8 +218,8 @@ module RedirectRules = None else Some ("Edit", (Views.Admin.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules)))) - match titleAndModel with - | Some (title, model) -> adminBarePage $"{title} Redirect Rule" true model next ctx + 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 @@ -294,7 +284,7 @@ module TagMapping = // GET /admin/settings/tag-mappings let all : HttpHandler = fun next ctx -> task { let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id - return! adminBarePage "Tag Mapping List" true (Views.Admin.tagMapList mappings) next ctx + return! adminBarePage "Tag Mapping List" true next ctx (Views.Admin.tagMapList mappings) } // GET /admin/settings/tag-mapping/{id}/edit @@ -306,9 +296,8 @@ module TagMapping = match! tagMap with | Some tm -> return! - adminBarePage - (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") true - (Views.Admin.tagMapEdit (EditTagMapModel.FromMapping tm)) next ctx + Views.Admin.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 } @@ -349,17 +338,13 @@ module Theme = let all : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let! themes = ctx.Data.Theme.All () return! - hashForPage "Themes" - |> withAntiCsrf ctx - |> addToHash "themes" (themes |> List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) |> Array.ofList) - |> adminBareView "theme-list-body" next ctx + 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 -> - hashForPage "Upload a Theme File" - |> withAntiCsrf ctx - |> adminBareView "theme-upload" 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 { diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 00f7274..e78a580 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -282,8 +282,9 @@ 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 = [| @@ -370,7 +371,7 @@ let adminBareView template = bareForTheme adminTheme template /// Display a page for an admin endpoint -let adminPage pageTitle includeCsrf (content: AppViewContext -> XmlNode list) : HttpHandler = fun next ctx -> task { +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 @@ -378,7 +379,7 @@ let adminPage pageTitle includeCsrf (content: AppViewContext -> XmlNode list) : } /// Display a bare page for an admin endpoint -let adminBarePage pageTitle includeCsrf (content: AppViewContext -> XmlNode list) : HttpHandler = fun next ctx -> task { +let adminBarePage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task { let! messages = getCurrentMessages ctx let appCtx = generateViewContext pageTitle messages includeCsrf ctx return! @@ -471,13 +472,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) = - Instant.FromDateTimeUtc(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 diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 28b8074..5cf619b 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -66,10 +66,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 } @@ -95,15 +94,14 @@ 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 @@ -158,7 +156,7 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun | _, 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 -> diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 0555999..8e0cdb4 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -254,7 +254,7 @@ let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { let data = ctx.Data let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25 let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data - return! adminPage "Posts" true (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay)) next ctx + return! adminPage "Posts" true next ctx (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay)) } // GET /admin/post/{id}/edit @@ -305,10 +305,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 } @@ -334,15 +333,14 @@ 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 @@ -398,7 +396,7 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f | _, 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 -> @@ -418,7 +416,8 @@ let manageChapters postId : HttpHandler = requireAccess Author >=> fun next ctx && Option.isSome post.Episode.Value.Chapters && canEdit post.AuthorId ctx -> return! - adminPage "Manage Chapters" true (Views.Post.chapters false (ManageChaptersModel.Create post)) next ctx + Views.Post.chapters false (ManageChaptersModel.Create post) + |> adminPage "Manage Chapters" true next ctx | Some _ | None -> return! Error.notFound next ctx } @@ -437,9 +436,8 @@ let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex match chapter with | Some chap -> return! - adminBarePage - (if index = -1 then "Add a Chapter" else "Edit Chapter") true - (Views.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)) next ctx + 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 } @@ -466,9 +464,8 @@ let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex do! data.Post.Update updatedPost do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } return! - adminPage - "Manage Chapters" true - (Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)) next ctx + Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost) + |> adminPage "Manage Chapters" true next ctx with | ex -> return! Error.server ex.Message next ctx else return! Error.notFound next ctx @@ -491,9 +488,8 @@ let deleteChapter (postId, index) : HttpHandler = requireAccess Author >=> fun n do! data.Post.Update updatedPost do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" } return! - adminPage - "Manage Chapters" true (Views.Post.chapterList false (ManageChaptersModel.Create updatedPost)) next - ctx + 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 } diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index a4ef6f9..f0db9ca 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -176,17 +176,13 @@ let router : HttpHandler = 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/chapter/%i" Post.saveChapter - routef "/%s/revision/%s/delete" Post.deleteRevision routef "/%s/revision/%s/restore" Post.restoreRevision - routef "/%s/revisions/purge" Post.purgeRevisions ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ route "" >=> Admin.WebLog.saveSettings @@ -214,9 +210,15 @@ let router : HttpHandler = choose [ ]) ] DELETE >=> validateCsrf >=> choose [ + subRoute "/page" (choose [ + 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" 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 "/user/%s" User.delete diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index fbd1734..5f972ac 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -35,7 +35,7 @@ let logOn returnUrl : HttpHandler = fun next ctx -> match returnUrl with | Some _ -> returnUrl | None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None - adminPage "Log On" true (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo }) next ctx + adminPage "Log On" true next ctx (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo }) open System.Security.Claims @@ -91,12 +91,12 @@ let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" // GET /admin/settings/users let all : HttpHandler = fun next ctx -> task { let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id - return! adminBarePage "User Administration" true (Views.User.userList users) next ctx + 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 -> - adminBarePage (if model.IsNew then "Add a New User" else "Edit User") true (Views.User.edit model) next ctx + adminBarePage (if model.IsNew then "Add a New User" else "Edit User") true next ctx (Views.User.edit model) // GET /admin/settings/user/{id}/edit let edit usrId : HttpHandler = fun next ctx -> task { @@ -137,7 +137,9 @@ let delete userId : HttpHandler = fun next ctx -> task { let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with | Some user -> - return! adminPage "Edit Your Information" true (Views.User.myInfo (EditMyInfoModel.FromUser user) user) next ctx + return! + Views.User.myInfo (EditMyInfoModel.FromUser user) user + |> adminPage "Edit Your Information" true next ctx | None -> return! Error.notFound next ctx } @@ -161,9 +163,8 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { | Some user -> do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" } return! - adminPage - "Edit Your Information" true - (Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user) next ctx + Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user + |> adminPage "Edit Your Information" true next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Views/Admin.fs b/src/MyWebLog/Views/Admin.fs index 7e4aac1..f773b46 100644 --- a/src/MyWebLog/Views/Admin.fs +++ b/src/MyWebLog/Views/Admin.fs @@ -293,3 +293,91 @@ let tagMapList (model: TagMap list) app = ] ] |> List.singleton + + +/// 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 " • " ] + 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 $" • {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 "   " + button [ _type "button"; _class "btn btn-sm btn-secondary ms-3" + _onclick "document.getElementById('theme_new').innerHTML = ''" ] [ + raw "Cancel" + ] + ] + ] + ] + ] + |> List.singleton + \ No newline at end of file diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index cd09280..ab28e95 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -232,3 +232,139 @@ module Layout = 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..]}" + +/// 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 "−" + ] + ] + 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 $"« 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 " • " ] + a [ _href revRestore; _hxPost revRestore ] [ raw "Restore as Current" ] + span [ _class "text-muted" ] [ raw " • " ] + 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 $"« 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/purge" + _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 + ] + ] +] diff --git a/src/MyWebLog/Views/User.fs b/src/MyWebLog/Views/User.fs index 90c0116..98c9dc2 100644 --- a/src/MyWebLog/Views/User.fs +++ b/src/MyWebLog/Views/User.fs @@ -13,7 +13,7 @@ let edit (model: EditUserModel) app = div [ _class "col-12" ] [ h5 [ _class "my-3" ] [ txt app.PageTitle ] form [ _hxPost (relUrl app "admin/settings/user/save"); _method "post"; _class "container" - _hxTarget "#userList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ + _hxTarget "#user_panel"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ antiCsrf app input [ _type "hidden"; _name "Id"; _value model.Id ] div [ _class "row" ] [ @@ -163,56 +163,77 @@ let logOn (model: LogOnModel) (app: AppViewContext) = [ /// The list of users for a web log (part of web log settings page) let userList (model: WebLogUser list) app = - let badge = "ms-2 badge bg" - 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 "this" - _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [ - antiCsrf app - for user in model do - div [ _class "row mwl-table-detail"; _id $"user_{user.Id}" ] [ - div [ _class "col-12 col-md-4 col-xl-3 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 " • " ] - 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" - ] + 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 " • " ] + 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 "col-12 col-md-4 col-xl-4" ] [ - 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 [ _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 diff --git a/src/admin-theme/_theme-list-columns.liquid b/src/admin-theme/_theme-list-columns.liquid deleted file mode 100644 index 18b9282..0000000 --- a/src/admin-theme/_theme-list-columns.liquid +++ /dev/null @@ -1,3 +0,0 @@ -{%- assign theme_col = "col-12 col-md-6" -%} -{%- assign slug_col = "d-none d-md-block col-md-3" -%} -{%- assign tmpl_col = "d-none d-md-block col-md-3" -%} diff --git a/src/admin-theme/_user-list-columns.liquid b/src/admin-theme/_user-list-columns.liquid deleted file mode 100644 index 74b6626..0000000 --- a/src/admin-theme/_user-list-columns.liquid +++ /dev/null @@ -1,4 +0,0 @@ -{%- assign user_col = "col-12 col-md-4 col-xl-3" -%} -{%- assign email_col = "col-12 col-md-4 col-xl-4" -%} -{%- assign cre8_col = "d-none d-xl-block col-xl-2" -%} -{%- assign last_col = "col-12 col-md-4 col-xl-3" -%} diff --git a/src/admin-theme/admin-dashboard.liquid b/src/admin-theme/admin-dashboard.liquid index baed2f7..4d8ac30 100644 --- a/src/admin-theme/admin-dashboard.liquid +++ b/src/admin-theme/admin-dashboard.liquid @@ -2,19 +2,7 @@
    Themes - - Upload a New Theme - -
    - {% include_template "_theme-list-columns" %} -
    -
    Theme
    -
    Slug
    -
    Templates
    -
    -
    -
    - {{ theme_list }} +
    {%- assign cache_base_url = "admin/cache/" -%} diff --git a/src/admin-theme/permalinks.liquid b/src/admin-theme/permalinks.liquid deleted file mode 100644 index 2d4a168..0000000 --- a/src/admin-theme/permalinks.liquid +++ /dev/null @@ -1,59 +0,0 @@ -

    {{ page_title }}

    -
    - {%- assign base_url = "admin/" | append: model.entity | append: "/" -%} -
    - - -
    -
    -
    -

    - {{ model.current_title }}
    - - {{ model.current_permalink }}
    - - « Back to Edit {{ model.entity | capitalize }} - -     -

    -
    -
    -
    - -
    -
    -
    -
    - -
    -
    -
    -
    - -
    -
    -
    -
    -
    diff --git a/src/admin-theme/revisions.liquid b/src/admin-theme/revisions.liquid deleted file mode 100644 index 4a5ab75..0000000 --- a/src/admin-theme/revisions.liquid +++ /dev/null @@ -1,65 +0,0 @@ -

    {{ page_title }}

    -
    -
    - - -
    -
    -
    -

    - {{ model.current_title }}
    - - - « Back to Edit {{ model.entity | capitalize }} - - -

    -
    - {%- assign revision_count = model.revisions | size -%} - {%- assign rev_url_base = "admin/" | append: model.entity | append: "/" | append: model.id | append: "/revision" -%} - {%- if revision_count > 1 %} -
    -
    - -
    -
    - {%- endif %} -
    Revision
    - {% for rev in model.revisions %} - {%- assign as_of_string = rev.as_of | date: "o" -%} - {%- assign as_of_id = "rev_" | append: as_of_string | replace: "\.", "_" | replace: ":", "-" -%} -
    -
    - {{ rev.as_of_local | date: "MMMM d, yyyy" }} at {{ rev.as_of_local | date: "h:mmtt" | downcase }} - {{ rev.format }} - {%- if forloop.first %} - Current Revision - {%- endif %}
    - {% unless forloop.first %} - {%- assign rev_url_prefix = rev_url_base | append: "/" | append: as_of_string -%} - {%- assign rev_restore = rev_url_prefix | append: "/restore" | relative_link -%} - {%- assign rev_delete = rev_url_prefix | append: "/delete" | relative_link -%} - - - Preview - - • - Restore as Current - • - - Delete - - - {% endunless %} -
    - {% unless forloop.first %}
    {% endunless %} -
    - {% endfor %} -
    -
    -
    diff --git a/src/admin-theme/settings.liquid b/src/admin-theme/settings.liquid index 4f8e2d8..45d21dc 100644 --- a/src/admin-theme/settings.liquid +++ b/src/admin-theme/settings.liquid @@ -109,19 +109,6 @@
    Users - {% include_template "_user-list-columns" %} - - Add a New User - -
    -
    -
    User; Full Name / E-mail; Last Log On
    - -
    Created
    -
    Last Log On
    -
    -
    diff --git a/src/admin-theme/theme-list-body.liquid b/src/admin-theme/theme-list-body.liquid deleted file mode 100644 index 13eb143..0000000 --- a/src/admin-theme/theme-list-body.liquid +++ /dev/null @@ -1,33 +0,0 @@ -
    - - {% include_template "_theme-list-columns" %} - {% for theme in themes -%} -
    -
    - {{ theme.name }} - {%- if theme.is_in_use %} - IN USE - {%- endif %} - {%- unless theme.is_on_disk %} - NOT ON DISK - {%- endunless %}
    - - v{{ theme.version }} - {% unless theme.is_in_use or theme.id == "default" %} - • - {%- assign theme_del_link = "admin/theme/" | append: theme.id | append: "/delete" | relative_link -%} - - Delete - - {% endunless %} - -
    Slug: {{ theme.id }} • {{ theme.template_count }} Templates -     -     -
    -
    {{ theme.id }}
    -
    {{ theme.template_count }}
    -
    - {%- endfor %} -
    diff --git a/src/admin-theme/theme-upload.liquid b/src/admin-theme/theme-upload.liquid deleted file mode 100644 index 73f31e8..0000000 --- a/src/admin-theme/theme-upload.liquid +++ /dev/null @@ -1,30 +0,0 @@ -
    -
    {{ page_title }}
    -
    - -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    - - -
    -
    -
    -
    -- 2.45.1 From e9bd3b28025ec69a3dae46373f3863d1cfef3de0 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 13 Mar 2024 18:17:14 -0400 Subject: [PATCH 095/123] Migrate web log settings page to GVE - Add field functions to tighten up forms --- src/MyWebLog.Tests/Domain/ViewModelsTests.fs | 10 - src/MyWebLog/Handlers/Admin.fs | 40 +--- src/MyWebLog/Views/Admin.fs | 217 +++++++++++++++-- src/MyWebLog/Views/Helpers.fs | 53 +++++ src/MyWebLog/Views/Post.fs | 71 ++---- src/MyWebLog/Views/User.fs | 101 ++------ src/admin-theme/settings.liquid | 236 ------------------- 7 files changed, 287 insertions(+), 441 deletions(-) delete mode 100644 src/admin-theme/settings.liquid diff --git a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs index a4bb736..e55e488 100644 --- a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs @@ -1158,16 +1158,11 @@ let manageRevisionsModelTests = testList "ManageRevisionsModel" [ { AsOf = Noda.epoch + Duration.FromDays 20; Text = Html "

    huh

    " } ] let model = ManageRevisionsModel.FromPage - { WebLog.Empty with TimeZone = "Etc/GMT+1" } { Page.Empty with Id = PageId "revs"; Title = "A Revised Page"; Revisions = revisions } Expect.equal model.Id "revs" "Id not filled properly" Expect.equal model.Entity "page" "Entity not filled properly" Expect.equal model.CurrentTitle "A Revised Page" "CurrentTitle not filled properly" Expect.equal model.Revisions.Length 2 "There should be two revisions" - Expect.equal - model.Revisions[0].AsOfLocal - ((revisions[0].AsOf - Duration.FromHours 1).ToDateTimeUtc()) - "AsOfLocal not filled properly" } test "FromPost succeeds" { let revisions = @@ -1175,16 +1170,11 @@ let manageRevisionsModelTests = testList "ManageRevisionsModel" [ { AsOf = Noda.epoch + Duration.FromDays 12; Text = Html "

    original

    " } ] let model = ManageRevisionsModel.FromPost - { WebLog.Empty with TimeZone = "Etc/GMT-3" } { Post.Empty with Id = PostId "altered"; Title = "Round Two"; Revisions = revisions } Expect.equal model.Id "altered" "Id not filled properly" Expect.equal model.Entity "post" "Entity not filled properly" Expect.equal model.CurrentTitle "Round Two" "CurrentTitle not filled properly" Expect.equal model.Revisions.Length 2 "There should be two revisions" - Expect.equal - model.Revisions[0].AsOfLocal - ((revisions[0].AsOf + Duration.FromHours 3).ToDateTimeUtc()) - "AsOfLocal not filled properly" } ] diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index d00239d..df5c257 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -483,42 +483,24 @@ module Theme = /// ~~~ WEB LOG SETTINGS ~~~ module WebLog = - open System.Collections.Generic open System.IO // GET /admin/settings let settings : HttpHandler = fun next ctx -> task { - let data = ctx.Data + 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 ] + let feeds = ctx.WebLog.Rss.CustomFeeds |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) 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 _.Title.ToLower() - |> List.map (fun p -> KeyValuePair.Create(string p.Id, p.Title)) - } - |> Array.ofSeq) - |> addToHash "themes" ( - themes - |> Seq.ofList - |> Seq.map (fun it -> - KeyValuePair.Create(string it.Id, $"{it.Name} (v{it.Version})")) - |> Array.ofSeq) - |> addToHash "upload_values" [| - KeyValuePair.Create(string Database, "Database") - KeyValuePair.Create(string Disk, "Disk") - |] - |> addToHash "rss_model" (EditRssModel.FromRssOptions ctx.WebLog.Rss) - |> addToHash "custom_feeds" ( - ctx.WebLog.Rss.CustomFeeds - |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) - |> Array.ofList) - |> adminView "settings" next ctx + Views.Admin.webLogSettings + (SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss) + feeds + |> adminPage "Web Log Settings" true next ctx } // POST /admin/settings diff --git a/src/MyWebLog/Views/Admin.fs b/src/MyWebLog/Views/Admin.fs index f773b46..8568499 100644 --- a/src/MyWebLog/Views/Admin.fs +++ b/src/MyWebLog/Views/Admin.fs @@ -90,25 +90,17 @@ let redirectEdit (model: EditRedirectRuleModel) app = [ input [ _type "hidden"; _name "RuleId"; _value (string model.RuleId) ] div [ _class "row" ] [ div [ _class "col-12 col-lg-5 mb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "From"; _id "from"; _class "form-control" - _placeholder "From local URL/pattern"; _autofocus; _required; _value model.From ] - label [ _for "from" ] [ raw "From" ] + 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" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "To"; _id "to"; _class "form-control"; _placeholder "To URL/pattern" - _required; _value model.To ] - label [ _for "to" ] [ raw "To" ] + 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" ] [ - div [ _class "form-check form-switch" ] [ - input [ _type "checkbox"; _name "IsRegex"; _id "isRegex"; _class "form-check-input"; _value "true" - if model.IsRegex then _checked ] - label [ _for "isRegex" ] [ raw "Use RegEx" ] - ] + checkboxSwitch [] (nameof model.IsRegex) "Use RegEx" model.IsRegex [] ] ] if model.RuleId < 0 then @@ -126,7 +118,7 @@ let redirectEdit (model: EditRedirectRuleModel) app = [ ] div [ _class "row mb-3" ] [ div [ _class "col text-center" ] [ - button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ] + saveButton; raw "   " a [ _href (relUrl app "admin/settings/redirect-rules"); _class "btn btn-sm btn-secondary ms-3" ] [ raw "Cancel" ] @@ -223,23 +215,15 @@ let tagMapEdit (model: EditTagMapModel) app = [ input [ _type "hidden"; _name "Id"; _value model.Id ] div [ _class "row mb-3" ] [ div [ _class "col-6 col-lg-4 offset-lg-2" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "Tag"; _id "tag"; _class "form-control"; _placeholder "Tag"; _autofocus - _required; _value model.Tag ] - label [ _for "tag" ] [ raw "Tag" ] - ] + textField [ _autofocus; _required ] (nameof model.Tag) "Tag" model.Tag [] ] div [ _class "col-6 col-lg-4" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "UrlValue"; _id "urlValue"; _class "form-control" - _placeholder "URL Value"; _required; _value model.UrlValue ] - label [ _for "urlValue" ] [ raw "URL Value" ] - ] + textField [ _required ] (nameof model.UrlValue) "URL Value" model.UrlValue [] ] ] div [ _class "row mb-3" ] [ div [ _class "col text-center" ] [ - button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ]; raw "   " + saveButton; raw "   " a [ _href (relUrl app "admin/settings/tag-mappings"); _class "btn btn-sm btn-secondary ms-3" ] [ raw "Cancel" ] @@ -380,4 +364,185 @@ let themeUpload app = ] ] |> List.singleton - \ No newline at end of file + + +/// Web log settings page +let webLogSettings + (model: SettingsModel) (themes: Theme list) (pages: Page list) (uploads: UploadDestination list) + (rss: EditRssModel) (feeds: DisplayCustomFeed list) app = [ + h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " Settings" ] + article [] [ + p [ _class "text-muted" ] [ + raw "Go to: "; a [ _href "#users" ] [ raw "Users" ]; raw " • " + a [ _href "#rss-settings" ] [ raw "RSS Settings" ]; raw " • " + a [ _href "#tag-mappings" ] [ raw "Tag Mappings" ]; raw " • " + 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" + 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"; _rel "noopener" ] [ + 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" rss.ItemsInFeed [ + span [ _class "form-text" ] [ + raw "Set to “0” to use “Posts per Page” 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" + _rel "noopener" ] [ + 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 feeds.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" ] + ] + for feed in feeds do + div [ _class "row mwl-table-detail" ] [ + div [ _class "col-12 col-md-6" ] [ + txt feed.Source + if feed.IsPodcast then + raw "   "; span [ _class "badge bg-primary" ] [ raw "PODCAST" ] + br [] + small [] [ + let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}" + a [ _href (relUrl app feed.Path); _target "_blank" ] [ raw "View Feed" ] + span [ _class "text-muted" ] [ raw " • " ] + a [ _href $"{feedUrl}/edit" ] [ raw "Edit" ] + span [ _class "text-muted" ] [ raw " • " ] + 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 feed.Path ] + span [ _class "d-none d-md-inline" ] [ txt feed.Path ] + ] + ] + ] + ] + ] + 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 ] [] + ] + ] +] diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index ab28e95..5d4dfee 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -102,6 +102,59 @@ let shortTime app (instant: Instant) = let yesOrNo value = raw (if value then "Yes" else "No") +/// Create a text input field +let inputField fieldType attrs name labelText value extra = + div [ _class "form-floating" ] [ + [ _type fieldType; _name name; _id name; _class "form-control"; _placeholder labelText; _value value ] + |> List.append attrs + |> input + label [ _for 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: int) extra = + inputField "number" attrs name labelText (string 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 list) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra = + div [ _class "form-floating" ] [ + 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 ] [ txt (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 = + div [ _class "form-check form-switch" ] [ + [ _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" ] + /// Functions for generating content in varying layouts module Layout = diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index d3e5660..36339f9 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -24,83 +24,47 @@ let chapterEdit (model: EditChapterModel) app = [ input [ _type "hidden"; _name "Index"; _value (string model.Index) ] div [ _class "row" ] [ div [ _class "col-6 col-lg-3 mb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "start_time"; _name "StartTime"; _class "form-control"; _required - _autofocus; _placeholder "Start Time" - if model.Index >= 0 then _value model.StartTime ] - label [ _for "start_time" ] [ raw "Start Time" ] - ] + 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" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "end_time"; _name "EndTime"; _class "form-control"; _value model.EndTime - _placeholder "End Time" ] - label [ _for "end_time" ] [ raw "End Time" ] + 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" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "title"; _name "Title"; _class "form-control"; _value model.Title - _placeholder "Title" ] - label [ _for "title" ] [ raw "Chapter Title" ] + 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" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "image_url"; _name "ImageUrl"; _class "form-control" - _value model.ImageUrl; _placeholder "Image URL" ] - label [ _for "image_url" ] [ raw "Image URL" ] + 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" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "url"; _name "Url"; _class "form-control"; _value model.Url - _placeholder "URL" ] - label [ _for "url" ] [ raw "URL" ] - span [ _class "form-text" ] [ - raw "Optional; informational link for this chapter" - ] + 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" ] [ - div [ _class "form-check form-switch mb-3" ] [ - input [ _type "checkbox"; _id "is_hidden"; _name "IsHidden"; _class "form-check-input" - _value "true" - if model.IsHidden then _checked ] - label [ _for "is_hidden" ] [ raw "Hidden Chapter" ] - ] - span [ _class "form-text" ] [ raw "Not displayed, but may update image and location" ] + 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 = model.LocationName <> "" + let attrs = if hasLoc then [] else [ _disabled ] div [ _class "col-12 col-md-4 col-lg-3 offset-lg-1 mb-3 align-self-end" ] [ - div [ _class "form-check form-switch mb-3" ] [ - input [ _type "checkbox"; _id "has_location"; _class "form-check-input"; _value "true" - if hasLoc then _checked - _onclick "Admin.checkChapterLocation()" ] - label [ _for "has_location" ] [ raw "Associate Location" ] - ] + checkboxSwitch [ _onclick "Admin.checkChapterLocation()" ] "has_location" "Associate Location" hasLoc [] ] div [ _class "col-12 col-md-8 col-lg-6 offset-lg-1 mb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "location_name"; _name "LocationName"; _class "form-control" - _value model.LocationName; _placeholder "Location Name"; _required - if not hasLoc then _disabled ] - label [ _for "location_name" ] [ raw "Name" ] - ] + textField (_required :: attrs) (nameof model.LocationName) "Name" model.LocationName [] ] div [ _class "col-6 col-lg-4 offset-lg-2 mb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "location_geo"; _name "LocationGeo"; _class "form-control" - _value model.LocationGeo; _placeholder "Location Geo URL"; _required - if not hasLoc then _disabled ] - label [ _for "location_geo" ] [ raw "Geo URL" ] + 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"; _rel "noopener" ] [ @@ -110,11 +74,7 @@ let chapterEdit (model: EditChapterModel) app = [ ] ] div [ _class "col-6 col-lg-4 mb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _id "location_osm"; _name "LocationOsm"; _class "form-control" - _value model.LocationOsm; _placeholder "Location OSM Query" - if not hasLoc then _disabled ] - label [ _for "location_osm" ] [ raw "OpenStreetMap ID" ] + textField attrs (nameof model.LocationOsm) "OpenStreetMap ID" model.LocationOsm [ em [ _class "form-text" ] [ raw "Optional; " a [ _href "https://www.openstreetmap.org/"; _target "_blank"; _rel "noopener" ] [ raw "get ID" ] @@ -138,8 +98,7 @@ let chapterEdit (model: EditChapterModel) app = [ ] else input [ _type "hidden"; _name "AddAnother"; _value "false" ] - button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save" ] - raw "   " + saveButton; raw "   " a [ _href cancelLink; _hxGet cancelLink; _class "btn btn-secondary"; _hxTarget "body" ] [ raw "Cancel" ] ] ] diff --git a/src/MyWebLog/Views/User.fs b/src/MyWebLog/Views/User.fs index 98c9dc2..5db2f57 100644 --- a/src/MyWebLog/Views/User.fs +++ b/src/MyWebLog/Views/User.fs @@ -30,41 +30,21 @@ let edit (model: EditUserModel) app = ] ] div [ _class "col-12 col-md-7 col-lg-4 col-xxl-3 mb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "email"; _name "Email"; _id "email"; _class "form-control"; _placeholder "E-mail" - _required; _value model.Email ] - label [ _for "email" ] [ raw "E-mail Address" ] - ] + emailField [ _required ] (nameof model.Email) "E-mail Address" model.Email [] ] div [ _class "col-12 col-lg-5 mb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "Url"; _id "url"; _class "form-control"; _placeholder "URL" - _value model.Url ] - label [ _for "url" ] [ raw "User’s Personal URL" ] - ] + textField [] (nameof model.Url) "User’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" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "FirstName"; _id "firstName"; _class "form-control" - _placeholder "First"; _required; _value model.FirstName ] - label [ _for "firstName" ] [ raw "First Name" ] - ] + textField [ _required ] (nameof model.FirstName) "First Name" model.FirstName [] ] div [ _class "col-12 col-md-6 col-lg-4 col-xl-3 pb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "LastName"; _id "lastName"; _class "form-control" - _placeholder "Last"; _required; _value model.LastName ] - label [ _for "lastName" ] [ raw "Last Name" ] - ] + 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" ] [ - div [ _class "form-floating " ] [ - input [ _type "text"; _name "PreferredName"; _id "preferredName"; _class "form-control" - _placeholder "Preferred"; _required; _value model.PreferredName ] - label [ _for "preferredName" ] [ raw "Preferred Name" ] - ] + textField [ _required ] (nameof model.PreferredName) "Preferred Name" model.PreferredName [] ] ] div [ _class "row mb-3" ] [ @@ -83,28 +63,12 @@ let edit (model: EditUserModel) app = ] ] div [ _class "row" ] [ + let attrs, newLbl = if model.IsNew then [ _required ], "" else [], "New " div [ _class "col-12 col-md-6 pb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "password"; _name "Password"; _id "password"; _class "form-control" - _placeholder "Password" - if model.IsNew then _required ] - label [ _for "password" ] [ - if not model.IsNew then raw "New " - raw "Password" - ] - ] + passwordField attrs (nameof model.Password) $"{newLbl}Password" "" [] ] div [ _class "col-12 col-md-6 pb-3" ] [ - div [ _class "form-floating" ] [ - input [ _type "password"; _name "PasswordConfirm"; _id "passwordConfirm" - _class "form-control"; _placeholder "Confirm" - if model.IsNew then _required ] - label [ _for "passwordConfirm" ] [ - raw "Confirm" - if not model.IsNew then raw " New" - raw " Password" - ] - ] + passwordField attrs (nameof model.PasswordConfirm) $"Confirm {newLbl}Password" "" [] ] ] ] @@ -112,7 +76,7 @@ let edit (model: EditUserModel) app = ] div [ _class "row mb-3" ] [ div [ _class "col text-center" ] [ - button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ]; raw "   " + saveButton; raw "   " if model.IsNew then button [ _type "button"; _class "btn btn-sm btn-secondary ms-3" _onclick "document.getElementById('user_new').innerHTML = ''" ] [ @@ -138,17 +102,10 @@ let logOn (model: LogOnModel) (app: AppViewContext) = [ 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" ] [ - div [ _class "form-floating" ] [ - input [ _type "email"; _id "email"; _name "EmailAddress"; _class "form-control"; _autofocus - _required ] - label [ _for "email" ] [ rawText "E-mail Address" ] - ] + emailField [ _required; _autofocus ] (nameof model.EmailAddress) "E-mail Address" "" [] ] 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" ] [ rawText "Password" ] - ] + passwordField [ _required ] (nameof model.Password) "Password" "" [] ] ] div [ _class "row pb-3" ] [ @@ -263,25 +220,13 @@ let myInfo (model: EditMyInfoModel) (user: WebLogUser) app = [ 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" ] [ - div [ _class "form-floating" ] [ - input [ _type "text"; _name "FirstName"; _id "firstName"; _class "form-control"; _autofocus - _required; _placeholder "First"; _value model.FirstName ] - label [ _for "firstName" ] [ raw "First Name" ] - ] + textField [ _required; _autofocus ] (nameof model.FirstName) "First Name" model.FirstName [] ] 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.LastName ] - label [ _for "lastName" ] [ raw "Last Name" ] - ] + textField [ _required ] (nameof model.LastName) "Last Name" model.LastName [] ] 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.PreferredName ] - label [ _for "preferredName" ] [ raw "Preferred Name" ] - ] + textField [ _required ] (nameof model.PreferredName) "Preferred Name" model.PreferredName [] ] ] div [ _class "row mb-3" ] [ @@ -297,28 +242,16 @@ let myInfo (model: EditMyInfoModel) (user: WebLogUser) app = [ ] 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" ] [ raw "New Password" ] - ] + passwordField [] (nameof model.NewPassword) "New Password" "" [] ] 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" ] [ raw "Confirm New Password" ] - ] + passwordField [] (nameof model.NewPasswordConfirm) "Confirm New Password" "" [] ] ] ] ] ] - div [ _class "row" ] [ - div [ _class "col text-center mb-3" ] [ - button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ] - ] - ] + div [ _class "row" ] [ div [ _class "col text-center mb-3" ] [ saveButton ] ] ] ] ] diff --git a/src/admin-theme/settings.liquid b/src/admin-theme/settings.liquid deleted file mode 100644 index 45d21dc..0000000 --- a/src/admin-theme/settings.liquid +++ /dev/null @@ -1,236 +0,0 @@ -

    {{ web_log.name }} Settings

    -
    -

    - Go to: Users • RSS Settings • - Tag Mappings • - Redirect Rules -

    -
    - Web Log Settings -
    - -
    -
    -
    -
    - - -
    -
    -
    -
    - - - - WARNING changing this value may break - links - (more) - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    - - What is this? - -
    -
    -
    - - -
    -
    -
    -
    -
    - -
    -
    -
    -
    -
    -
    - Users - -
    -
    - RSS Settings -
    - -
    -
    -
    -
    - Feeds Enabled -
    - - -
    -
    - - -
    -
    - - -
    -
    -
    -
    -
    -
    -
    - - - Default is feed.xml -
    -
    -
    -
    - - - - Set to “0” to use “Posts per Page” setting ({{ web_log.posts_per_page }}) - -
    -
    -
    -
    - - - - Can be a - - Creative Commons license string - - -
    -
    -
    -
    -
    - -
    -
    -
    -
    -
    - Custom Feeds - - Add a New Custom Feed - - {%- assign feed_count = custom_feeds | size -%} - {%- if feed_count > 0 %} -
    - {%- assign source_col = "col-12 col-md-6" -%} - {%- assign path_col = "col-12 col-md-6" -%} - -
    -
    - FeedSource -
    -
    Relative Path
    -
    - {% for feed in custom_feeds %} -
    -
    - {{ feed.source }} - {%- if feed.is_podcast %}   PODCAST{% endif %}
    - - {%- assign feed_url = "admin/settings/rss/" | append: feed.id -%} - View Feed - • - Edit - • - {%- assign feed_del_link = feed_url | append: "/delete" | relative_link -%} - - Delete - - -
    -
    - Served at {{ feed.path }} - {{ feed.path }} -
    -
    - {%- endfor %} -
    - {%- else %} -

    No custom feeds defined - {%- endif %} -

    -
    -
    - Tag Mappings - - Add a New Tag Mapping - - -
    -
    -- 2.45.1 From cac7b1d9b536572b7c937032c067a3847e502b3e Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 13 Mar 2024 21:31:15 -0400 Subject: [PATCH 096/123] Migrate page list template to GVE - Update chapter field names in admin.js --- src/MyWebLog/Handlers/Page.fs | 22 ++++----- src/MyWebLog/Handlers/Routes.fs | 2 +- src/MyWebLog/MyWebLog.fsproj | 1 + src/MyWebLog/Views/Page.fs | 84 ++++++++++++++++++++++++++++++++ src/admin-theme/page-list.liquid | 75 ---------------------------- src/admin-theme/wwwroot/admin.js | 2 +- 6 files changed, 96 insertions(+), 90 deletions(-) create mode 100644 src/MyWebLog/Views/Page.fs delete mode 100644 src/admin-theme/page-list.liquid diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 5cf619b..9563b94 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -9,19 +9,15 @@ 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 - |> Seq.ofList - |> Seq.truncate 25 - |> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog) - |> List.ofSeq) - |> addToHash "page_nbr" pageNbr - |> addToHash "prev_page" (if pageNbr = 2 then "" else $"/page/{pageNbr - 1}") - |> addToHash "has_next" (List.length pages > 25) - |> 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 @@ -51,7 +47,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { | 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 -> diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index f0db9ca..87fe4e5 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -175,7 +175,6 @@ let router : HttpHandler = choose [ subRoute "/page" (choose [ route "/save" >=> Page.save route "/permalinks" >=> Page.savePermalinks - routef "/%s/delete" Page.delete routef "/%s/revision/%s/restore" Page.restoreRevision ]) subRoute "/post" (choose [ @@ -211,6 +210,7 @@ let router : HttpHandler = choose [ ] DELETE >=> validateCsrf >=> choose [ subRoute "/page" (choose [ + routef "/%s" Page.delete routef "/%s/revision/%s" Page.deleteRevision routef "/%s/revisions" Page.purgeRevisions ]) diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index c795441..40b0eb6 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -11,6 +11,7 @@ + diff --git a/src/MyWebLog/Views/Page.fs b/src/MyWebLog/Views/Page.fs new file mode 100644 index 0000000..360858d --- /dev/null +++ b/src/MyWebLog/Views/Page.fs @@ -0,0 +1,84 @@ +module MyWebLog.Views.Page + +open Giraffe.ViewEngine +open Giraffe.ViewEngine.Htmx +open MyWebLog +open MyWebLog.ViewModels + +/// 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 "   "; span [ _class "badge bg-success" ] [ raw "HOME PAGE" ] + if pg.IsInPageList then + raw "   "; 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 " • " ] + a [ _href $"{adminUrl}/edit" ] [ raw "Edit" ] + if app.IsWebLogAdmin then + span [ _class "text-muted" ] [ raw " • " ] + a [ _href adminUrl; _hxDelete adminUrl; _class "text-danger" + _hxConfirm $"Are you sure you want to delete the page “{pg.Title}”? 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 "« Previous" + ] + ] + ] + div [ _class "text-right" ] [ + if hasNext then + p [] [ + a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages/page/{pageNbr + 1}") ] [ + raw "Next »" + ] + ] + ] + ] + ] +] diff --git a/src/admin-theme/page-list.liquid b/src/admin-theme/page-list.liquid deleted file mode 100644 index 7682f02..0000000 --- a/src/admin-theme/page-list.liquid +++ /dev/null @@ -1,75 +0,0 @@ -

    {{ page_title }}

    -
    - Create a New Page - {%- assign page_count = pages | size -%} - {% if page_count > 0 %} - {%- assign title_col = "col-12 col-md-5" -%} - {%- assign link_col = "col-12 col-md-5" -%} - {%- assign upd8_col = "col-12 col-md-2" -%} -
    - -
    -
    - TitlePage -
    -
    Permalink
    -
    Updated
    -
    - {% for pg in pages -%} -
    -
    - {{ pg.title }} - {%- if pg.is_default %}   HOME PAGE{% endif -%} - {%- if pg.is_in_page_list %}   IN PAGE LIST {% endif -%}
    - - {%- capture pg_link %}{% unless pg.is_default %}{{ pg.permalink }}{% endunless %}{% endcapture -%} - View Page - {% if is_editor or is_author and user_id == pg.author_id %} - • - Edit - {% endif %} - {% if is_web_log_admin %} - • - {%- assign pg_del_link = "admin/page/" | append: pg.id | append: "/delete" | relative_link -%} - - Delete - - {% endif %} - -
    -
    - {%- capture pg_link %}/{% unless pg.is_default %}{{ pg.permalink }}{% endunless %}{% endcapture -%} - {{ pg_link }}{{ pg_link }} -
    -
    - Updated {{ pg.updated_on | date: "MMMM d, yyyy" }} - {{ pg.updated_on | date: "MMMM d, yyyy" }} -
    -
    - {%- endfor %} -
    - {% if page_nbr > 1 or has_next %} -
    -
    - {% if page_nbr > 1 %} -

    - - « Previous - - {% endif %} -

    -
    - {% if has_next %} -

    - - Next » - - {% endif %} -

    -
    - {% endif %} - {% else %} -

    This web log has no pages

    - {% endif %} -
    diff --git a/src/admin-theme/wwwroot/admin.js b/src/admin-theme/wwwroot/admin.js index 4867539..4727ca9 100644 --- a/src/admin-theme/wwwroot/admin.js +++ b/src/admin-theme/wwwroot/admin.js @@ -310,7 +310,7 @@ this.Admin = { */ checkChapterLocation() { const isDisabled = !document.getElementById("has_location").checked - ;["location_name", "location_geo", "location_osm"].forEach(it => { + ;["LocationName", "LocationGeo", "LocationOsm"].forEach(it => { const elt = document.getElementById(it) elt.disabled = isDisabled if (isDisabled) elt.value = "" -- 2.45.1 From b85cae2241bfff7602f131cb85478b2a68cf448d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 14 Mar 2024 20:54:58 -0400 Subject: [PATCH 097/123] Tweak to chapter edit template --- src/MyWebLog/Views/Post.fs | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index 36339f9..fa0de21 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -55,8 +55,7 @@ let chapterEdit (model: EditChapterModel) app = [ ] ] div [ _class "row" ] [ - let hasLoc = model.LocationName <> "" - let attrs = if hasLoc then [] else [ _disabled ] + 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 [] ] @@ -91,11 +90,7 @@ let chapterEdit (model: EditChapterModel) app = [ div [ _class "col" ] [ let cancelLink = relUrl app $"admin/post/{model.PostId}/chapters" if model.Index < 0 then - div [ _class "form-check form-switch mb-3" ] [ - input [ _type "checkbox"; _id "add_another"; _name "AddAnother"; _class "form-check-input" - _value "true"; _checked ] - label [ _for "add_another" ] [ raw "Add Another New Chapter" ] - ] + checkboxSwitch [ _checked ] (nameof model.AddAnother) "Add Another New Chapter" true [] else input [ _type "hidden"; _name "AddAnother"; _value "false" ] saveButton; raw "   " -- 2.45.1 From 91046c643eca10c37d90574c907990e229b2ba80 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Thu, 14 Mar 2024 22:50:37 -0400 Subject: [PATCH 098/123] Migrate custom feed page to GVE - Allow IDs to be overridden --- src/MyWebLog/Handlers/Feed.fs | 31 +-- src/MyWebLog/Views/Admin.fs | 210 +++++++++++++++++++ src/MyWebLog/Views/Helpers.fs | 14 +- src/admin-theme/custom-feed-edit.liquid | 259 ------------------------ src/admin-theme/wwwroot/admin.js | 6 +- 5 files changed, 240 insertions(+), 280 deletions(-) delete mode 100644 src/admin-theme/custom-feed-edit.liquid diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 94dfd75..c1e8cdd 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -431,20 +431,23 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next | _ -> 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("", "– Unspecified –") - KeyValuePair.Create(string Podcast, "Podcast") - KeyValuePair.Create(string Music, "Music") - KeyValuePair.Create(string Video, "Video") - KeyValuePair.Create(string Film, "Film") - KeyValuePair.Create(string Audiobook, "Audiobook") - KeyValuePair.Create(string Newsletter, "Newsletter") - KeyValuePair.Create(string 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 = "– Unspecified –" } + { 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.Admin.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 diff --git a/src/MyWebLog/Views/Admin.fs b/src/MyWebLog/Views/Admin.fs index 8568499..e1e171a 100644 --- a/src/MyWebLog/Views/Admin.fs +++ b/src/MyWebLog/Views/Admin.fs @@ -81,6 +81,216 @@ let dashboard (model: DashboardModel) app = [ ] +/// 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 "« 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 = + if c.ParentNames.Length = 0 then "" + else + c.ParentNames + |> Array.map (fun it -> $"{it} ⟩ ") + |> String.concat "" + { Name = c.Id; Value = $"{parents} {c.Name}".Trim() }) + |> Seq.append [ { Name = ""; Value = "– Select Category –" } ] + |> List.ofSeq + 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" 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"; _rel "noopener" ] [ + 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"; _rel "noopener" ] [ + 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"; _rel "noopener" ] [ + 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}" diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index 5d4dfee..5372127 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -104,11 +104,17 @@ let yesOrNo value = /// Create a text input field let inputField fieldType attrs name labelText value extra = + let fieldId, newAttrs = + let passedId = attrs |> List.tryFind (fun x -> match x with KeyValue ("id", _) -> true | _ -> false) + match passedId with + | Some (KeyValue (_, idValue)) -> + idValue, attrs |> List.filter (fun x -> match x with KeyValue ("id", _) -> false | _ -> true) + | Some _ | None -> name, attrs div [ _class "form-floating" ] [ - [ _type fieldType; _name name; _id name; _class "form-control"; _placeholder labelText; _value value ] - |> List.append attrs + [ _type fieldType; _name name; _id fieldId; _class "form-control"; _placeholder labelText; _value value ] + |> List.append newAttrs |> input - label [ _for name ] [ raw labelText ] + label [ _for fieldId ] [ raw labelText ] yield! extra ] @@ -135,7 +141,7 @@ let selectField<'T, 'a> 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 ] [ txt (displayFunc item) ] + option [ _value itemId; if value = itemId then _selected ] [ raw (displayFunc item) ] ] label [ _for name ] [ raw labelText ] yield! extra diff --git a/src/admin-theme/custom-feed-edit.liquid b/src/admin-theme/custom-feed-edit.liquid deleted file mode 100644 index 20d4297..0000000 --- a/src/admin-theme/custom-feed-edit.liquid +++ /dev/null @@ -1,259 +0,0 @@ -

    {{ page_title }}

    -
    -
    - - - {%- assign typ = model.source_type -%} -
    -
    -
    - « Back to Settings -
    -
    -
    -
    -
    - Identification -
    -
    -
    - - - Appended to {{ web_log.url_base }}/ -
    -
    -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    -
    - Feed Source -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    -
    -
    -
    - Podcast Settings -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    - - - - - iTunes Category / Subcategory List - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    - - -
    -
    -
    -
    - - - For iTunes, must match registered e-mail -
    -
    -
    -
    - - - Optional; blank for no default -
    -
    -
    -
    - - - Relative URL will be appended to {{ web_log.url_base }}/ -
    -
    -
    -
    -
    -
    - - - Displayed in podcast directories -
    -
    -
    -
    -
    -
    - - - Optional; prepended to episode media file if present -
    -
    -
    -
    -
    -
    - - - - Optional; URL describing donation options for this podcast, relative URL supported - -
    -
    -
    -
    - - - Optional; text for the funding link -
    -
    -
    -
    -
    -
    - - - - Optional; v5 UUID uniquely identifying this podcast; once entered, do not change this value - (documentation) - -
    -
    -
    -
    - - - - Optional; medium of the podcast content - (documentation) - -
    -
    -
    -
    -
    -
    -
    -
    - -
    -
    -
    -
    -
    diff --git a/src/admin-theme/wwwroot/admin.js b/src/admin-theme/wwwroot/admin.js index 4727ca9..d69e134 100644 --- a/src/admin-theme/wwwroot/admin.js +++ b/src/admin-theme/wwwroot/admin.js @@ -249,7 +249,7 @@ this.Admin = { * Check to enable or disable podcast fields */ checkPodcast() { - document.getElementById("podcastFields").disabled = !document.getElementById("isPodcast").checked + document.getElementById("podcastFields").disabled = !document.getElementById("IsPodcast").checked }, /** @@ -269,8 +269,8 @@ this.Admin = { * @param {string} source The source that was selected */ customFeedBy(source) { - const categoryInput = document.getElementById("sourceValueCat") - const tagInput = document.getElementById("sourceValueTag") + const categoryInput = document.getElementById("SourceValueCat") + const tagInput = document.getElementById("SourceValueTag") if (source === "category") { tagInput.value = "" tagInput.disabled = true -- 2.45.1 From 3998399e1114a30342a7660bd0eeda0eb53c4dc2 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 15 Mar 2024 17:00:32 -0400 Subject: [PATCH 099/123] Migrate several templates to GVE All that remains is post/page edit --- src/MyWebLog/Handlers/Admin.fs | 82 +- src/MyWebLog/Handlers/Feed.fs | 5 +- src/MyWebLog/Handlers/Routes.fs | 22 +- src/MyWebLog/Handlers/Upload.fs | 30 +- src/MyWebLog/MyWebLog.fsproj | 1 + src/MyWebLog/Views/Admin.fs | 720 ++---------------- src/MyWebLog/Views/Helpers.fs | 9 +- src/MyWebLog/Views/Post.fs | 6 +- src/MyWebLog/Views/WebLog.fs | 875 ++++++++++++++++++++++ src/admin-theme/admin-dashboard.liquid | 92 --- src/admin-theme/category-edit.liquid | 52 -- src/admin-theme/category-list-body.liquid | 57 -- src/admin-theme/category-list.liquid | 8 - src/admin-theme/upload-list.liquid | 75 -- src/admin-theme/upload-new.liquid | 29 - 15 files changed, 1009 insertions(+), 1054 deletions(-) create mode 100644 src/MyWebLog/Views/WebLog.fs delete mode 100644 src/admin-theme/admin-dashboard.liquid delete mode 100644 src/admin-theme/category-edit.liquid delete mode 100644 src/admin-theme/category-list-body.liquid delete mode 100644 src/admin-theme/category-list.liquid delete mode 100644 src/admin-theme/upload-list.liquid delete mode 100644 src/admin-theme/upload-new.liquid diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index df5c257..2446197 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -27,35 +27,13 @@ module Dashboard = ListedPages = listed Categories = cats TopLevelCategories = topCats } - return! adminPage "Dashboard" false next ctx (Views.Admin.dashboard model) + return! adminPage "Dashboard" false next ctx (Views.WebLog.dashboard model) } // GET /admin/administration let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { - let! themes = ctx.Data.Theme.All() - let cachedTemplates = TemplateCache.allNames () - return! - hashForPage "myWebLog Administration" - |> withAntiCsrf ctx - |> addToHash "cached_themes" ( - themes - |> Seq.ofList - |> Seq.map (fun it -> [| - string it.Id - it.Name - cachedTemplates - |> List.filter _.StartsWith(string it.Id) - |> List.length - |> string - |]) - |> Array.ofSeq) - |> addToHash "web_logs" ( - WebLogCache.all () - |> Seq.ofList - |> Seq.sortBy _.Name - |> Seq.map (fun it -> [| string it.Id; it.Name; it.UrlBase |]) - |> Array.ofSeq) - |> adminView "admin-dashboard" next ctx + let! themes = ctx.Data.Theme.All() + return! adminPage "myWebLog Administration" true next ctx (Views.Admin.dashboard themes) } /// Redirect the user to the admin dashboard @@ -117,43 +95,24 @@ module Category = open MyWebLog.Data // GET /admin/categories - let all : HttpHandler = fun next ctx -> task { - match! TemplateCache.get adminTheme "category-list-body" ctx.Data with - | Ok catListTemplate -> - let! hash = - hashForPage "Categories" - |> withAntiCsrf ctx - |> addViewContext ctx - return! - addToHash "category_list" (catListTemplate.Render hash) hash - |> adminView "category-list" next ctx - | Error message -> return! Error.server message next ctx - } - - // GET /admin/categories/bare - let bare : HttpHandler = fun next ctx -> - hashForPage "Categories" - |> withAntiCsrf ctx - |> adminBareView "category-list-body" next ctx - + let all : HttpHandler = fun next ctx -> + adminPage "Categories" true next ctx Views.WebLog.categoryList // GET /admin/category/{id}/edit 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) + | Some cat -> return Some ("Edit Category", cat) | None -> return None } 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 } @@ -171,16 +130,16 @@ module Category = 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! bare next ctx + return! all next ctx | None -> return! Error.notFound next ctx } - // POST /admin/category/{id}/delete - let delete catId : HttpHandler = fun next ctx -> task { + // 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 @@ -194,7 +153,7 @@ module Category = 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! bare next ctx + return! all next ctx } @@ -205,19 +164,20 @@ module RedirectRules = // GET /admin/settings/redirect-rules let all : HttpHandler = fun next ctx -> - adminPage "Redirect Rules" true next ctx (Views.Admin.redirectList ctx.WebLog.RedirectRules) + adminPage "Redirect Rules" true next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules) // GET /admin/settings/redirect-rules/[index] let edit idx : HttpHandler = fun next ctx -> let titleAndView = if idx = -1 then - Some ("Add", Views.Admin.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty)) + 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.Admin.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules)))) + 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 @@ -284,7 +244,7 @@ module TagMapping = // GET /admin/settings/tag-mappings let all : HttpHandler = fun next ctx -> task { let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id - return! adminBarePage "Tag Mapping List" true next ctx (Views.Admin.tagMapList mappings) + return! adminBarePage "Tag Mapping List" true next ctx (Views.WebLog.tagMapList mappings) } // GET /admin/settings/tag-mapping/{id}/edit @@ -296,7 +256,7 @@ module TagMapping = match! tagMap with | Some tm -> return! - Views.Admin.tagMapEdit (EditTagMapModel.FromMapping tm) + 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 } @@ -497,7 +457,7 @@ module WebLog = let uploads = [ Database; Disk ] let feeds = ctx.WebLog.Rss.CustomFeeds |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) return! - Views.Admin.webLogSettings + Views.WebLog.webLogSettings (SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss) feeds |> adminPage "Web Log Settings" true next ctx diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index c1e8cdd..8c55dbd 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -2,7 +2,6 @@ module MyWebLog.Handlers.Feed open System -open System.Collections.Generic open System.IO open System.Net open System.ServiceModel.Syndication @@ -446,7 +445,7 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next { Name = string Newsletter; Value = "Newsletter" } { Name = string Blog; Value = "Blog" } ] - Views.Admin.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums + 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 @@ -474,7 +473,7 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun 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 diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 87fe4e5..733f29b 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -114,7 +114,6 @@ let router : HttpHandler = choose [ route "/administration" >=> Admin.Dashboard.admin subRoute "/categor" (requireAccess WebLogAdmin >=> choose [ route "ies" >=> Admin.Category.all - route "ies/bare" >=> Admin.Category.bare routef "y/%s/edit" Admin.Category.edit ]) route "/dashboard" >=> Admin.Dashboard.user @@ -184,11 +183,10 @@ let router : HttpHandler = choose [ routef "/%s/revision/%s/restore" Post.restoreRevision ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ - route "" >=> Admin.WebLog.saveSettings + route "" >=> Admin.WebLog.saveSettings subRoute "/rss" (choose [ - route "" >=> Feed.saveSettings - route "/save" >=> Feed.saveCustomFeed - routef "/%s/delete" Feed.deleteCustomFeed + route "" >=> Feed.saveSettings + route "/save" >=> Feed.saveCustomFeed ]) subRoute "/redirect-rules" (choose [ routef "/%i" Admin.RedirectRules.save @@ -202,13 +200,10 @@ let router : HttpHandler = choose [ route "/new" >=> Admin.Theme.save routef "/%s/delete" Admin.Theme.delete ]) - subRoute "/upload" (choose [ - route "/save" >=> Upload.save - routexp "/delete/(.*)" Upload.deleteFromDisk - routef "/%s/delete" Upload.deleteFromDb - ]) + 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 @@ -221,9 +216,14 @@ let router : HttpHandler = choose [ routef "/%s/revisions" Post.purgeRevisions ]) subRoute "/settings" (requireAccess WebLogAdmin >=> choose [ - routef "/user/%s" User.delete 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 ]) ] ]) diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index aac82d9..a52b037 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -108,30 +108,24 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/') UpdatedOn = create Source = string Disk }) - |> List.ofSeq 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" (string ctx.WebLog.Uploads) - |> adminView "upload-new" next ctx + adminPage "Upload a File" true next ctx Views.WebLog.uploadNew /// Redirect to the upload list @@ -173,8 +167,8 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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" } @@ -193,8 +187,8 @@ 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 diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 40b0eb6..105c91b 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -14,6 +14,7 @@ + diff --git a/src/MyWebLog/Views/Admin.fs b/src/MyWebLog/Views/Admin.fs index e1e171a..a3933db 100644 --- a/src/MyWebLog/Views/Admin.fs +++ b/src/MyWebLog/Views/Admin.fs @@ -2,493 +2,107 @@ module MyWebLog.Views.Admin open Giraffe.Htmx.Common open Giraffe.ViewEngine -open Giraffe.ViewEngine.Accessibility open Giraffe.ViewEngine.Htmx open MyWebLog open MyWebLog.ViewModels -/// The main dashboard -let dashboard (model: DashboardModel) app = [ - h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " • 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 "  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 "  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" - ] - ] +/// 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" ] ] ] ] - 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 "  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/category/new/edit"); _class "btn btn-secondary" ] [ - raw "Add a New Category" - ] - ] + 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 " • " ] + a [ _href refreshUrl; _hxPost refreshUrl ] [ raw "Refresh" ] ] ] + div [ _class "col-4" ] [ + raw (templates |> List.filter _.StartsWith(string theme.Id) |> List.length |> string) + ] ] - 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 "« 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 = - if c.ParentNames.Length = 0 then "" - else - c.ParentNames - |> Array.map (fun it -> $"{it} ⟩ ") - |> String.concat "" - { Name = c.Id; Value = $"{parents} {c.Name}".Trim() }) - |> Seq.append [ { Name = ""; Value = "– Select Category –" } ] - |> List.ofSeq - 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" 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"; _rel "noopener" ] [ - 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"; _rel "noopener" ] [ - 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"; _rel "noopener" ] [ - raw "documentation" - ]; raw ")" - ] - ] - ] - ] - ] - ] - ] - div [ _class "row pb-3" ] [ div [ _class "col text-center" ] [ saveButton ] ] + fieldset [ _class "container mb-3 pb-0" ] [ + legend [] [ raw "Themes" ] + span [ _hxGet (relUrl app "admin/theme/list"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] [] ] - ] -] - - -/// 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 "   " - 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 - span [ _class "text-muted" ] [ raw " • " ] - a [ _href $"{ruleUrl}/up"; _hxPost $"{ruleUrl}/up" ] [ raw "Move Up" ] - if idx <> model.Length - 1 then - span [ _class "text-muted" ] [ raw " • " ] - a [ _href $"{ruleUrl}/down"; _hxPost $"{ruleUrl}/down" ] [ raw "Move Down" ] - span [ _class "text-muted" ] [ raw " • " ] - 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 "« Back to Settings" ] - ] - div [ _class "container" ] [ - div [ _class "row" ] [ - div [ _class "col" ] [ - a [ _href (relUrl app "admin/settings/redirect-rules/-1"); _class "btn btn-primary btn-sm mb-3" - _hxTarget "#rule_new" ] [ - raw "Add Redirect Rule" - ] - ] + 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" ] [ - 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" + 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 ] ] - 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 "   " - a [ _href (relUrl app "admin/settings/tag-mappings"); _class "btn btn-sm btn-secondary ms-3" ] [ - raw "Cancel" + 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 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" - ] - span [ _class "text-muted" ] [ raw " • " ] - 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" ] [ - div [ _class "row" ] [ - div [ _class "col" ] [ - 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 - - /// Display a list of themes let themeList (model: DisplayTheme list) app = let themeCol = "col-12 col-md-6" @@ -574,185 +188,3 @@ let themeUpload app = ] ] |> List.singleton - - -/// Web log settings page -let webLogSettings - (model: SettingsModel) (themes: Theme list) (pages: Page list) (uploads: UploadDestination list) - (rss: EditRssModel) (feeds: DisplayCustomFeed list) app = [ - h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " Settings" ] - article [] [ - p [ _class "text-muted" ] [ - raw "Go to: "; a [ _href "#users" ] [ raw "Users" ]; raw " • " - a [ _href "#rss-settings" ] [ raw "RSS Settings" ]; raw " • " - a [ _href "#tag-mappings" ] [ raw "Tag Mappings" ]; raw " • " - 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" - 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"; _rel "noopener" ] [ - 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" rss.ItemsInFeed [ - span [ _class "form-text" ] [ - raw "Set to “0” to use “Posts per Page” 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" - _rel "noopener" ] [ - 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 feeds.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" ] - ] - for feed in feeds do - div [ _class "row mwl-table-detail" ] [ - div [ _class "col-12 col-md-6" ] [ - txt feed.Source - if feed.IsPodcast then - raw "   "; span [ _class "badge bg-primary" ] [ raw "PODCAST" ] - br [] - small [] [ - let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}" - a [ _href (relUrl app feed.Path); _target "_blank" ] [ raw "View Feed" ] - span [ _class "text-muted" ] [ raw " • " ] - a [ _href $"{feedUrl}/edit" ] [ raw "Edit" ] - span [ _class "text-muted" ] [ raw " • " ] - 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 feed.Path ] - span [ _class "d-none d-md-inline" ] [ txt feed.Path ] - ] - ] - ] - ] - ] - 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 ] [] - ] - ] -] diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index 5372127..a087d2c 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -74,6 +74,9 @@ 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) @@ -136,7 +139,7 @@ let passwordField attrs name labelText value extra = /// Create a select (dropdown) field let selectField<'T, 'a> - attrs name labelText value (values: 'T list) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra = + attrs name labelText value (values: 'T seq) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra = div [ _class "form-floating" ] [ select ([ _name name; _id name; _class "form-control" ] |> List.append attrs) [ for item in values do @@ -161,6 +164,10 @@ let checkboxSwitch attrs name labelText (value: bool) extra = 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 " • " ] + /// Functions for generating content in varying layouts module Layout = diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index fa0de21..d7b9499 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -66,7 +66,7 @@ let chapterEdit (model: EditChapterModel) app = [ 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"; _rel "noopener" ] [ + _target "_blank"; _relNoOpener ] [ raw "see spec" ] ] @@ -76,10 +76,10 @@ let chapterEdit (model: EditChapterModel) app = [ textField attrs (nameof model.LocationOsm) "OpenStreetMap ID" model.LocationOsm [ em [ _class "form-text" ] [ raw "Optional; " - a [ _href "https://www.openstreetmap.org/"; _target "_blank"; _rel "noopener" ] [ raw "get ID" ] + 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"; _rel "noopener" ] [ + _target "_blank"; _relNoOpener ] [ raw "see spec" ] ] diff --git a/src/MyWebLog/Views/WebLog.fs b/src/MyWebLog/Views/WebLog.fs new file mode 100644 index 0000000..2aeff71 --- /dev/null +++ b/src/MyWebLog/Views/WebLog.fs @@ -0,0 +1,875 @@ +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}   » ") + |> String.concat "" + { Name = c.Id; Value = $"{parents}{c.Name}" }) + |> Seq.append [ { Name = ""; Value = "– None –" } ] + 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 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} ⟩ ") + |> 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; _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" ] + ] + ] + + 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 + 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" ] [ + // don't think we need this... + // _hxTarget "#catList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" + antiCsrf app + div [ _class "row mwl-table-detail"; _id "cat_new" ] [] + 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 " • 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 "  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 "  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 "  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/category/new/edit"); _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 "« 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} ⟩ ") + |> String.concat "" + { Name = c.Id; Value = $"{parents}{c.Name}" }) + |> Seq.append [ { Name = ""; Value = "– Select Category –" } ] + 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" 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 "   " + 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 "« 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 "   " + 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" ] [ + raw (match upload.UpdatedOn with Some updated -> updated.ToString "yyyy-MM-dd/HH:mm" | None -> "--") + ] + ] + + 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" ] [ + 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) (feeds: DisplayCustomFeed list) app = [ + h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " Settings" ] + article [] [ + p [ _class "text-muted" ] [ + raw "Go to: "; a [ _href "#users" ] [ raw "Users" ]; raw " • " + a [ _href "#rss-settings" ] [ raw "RSS Settings" ]; raw " • " + a [ _href "#tag-mappings" ] [ raw "Tag Mappings" ]; raw " • " + 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" + 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" rss.ItemsInFeed [ + span [ _class "form-text" ] [ + raw "Set to “0” to use “Posts per Page” 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 feeds.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" ] + ] + for feed in feeds do + div [ _class "row mwl-table-detail" ] [ + div [ _class "col-12 col-md-6" ] [ + txt feed.Source + if feed.IsPodcast then + raw "   "; span [ _class "badge bg-primary" ] [ raw "PODCAST" ] + br [] + small [] [ + let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}" + a [ _href (relUrl app 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 feed.Path ] + span [ _class "d-none d-md-inline" ] [ txt feed.Path ] + ] + ] + ] + ] + ] + 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 ] [] + ] + ] +] diff --git a/src/admin-theme/admin-dashboard.liquid b/src/admin-theme/admin-dashboard.liquid deleted file mode 100644 index 4d8ac30..0000000 --- a/src/admin-theme/admin-dashboard.liquid +++ /dev/null @@ -1,92 +0,0 @@ -

    {{ page_title }}

    -
    -
    - Themes - -
    -
    - {%- assign cache_base_url = "admin/cache/" -%} - Caches -
    -
    -

    - myWebLog uses a few caches to ensure that it serves pages as fast as possible. - (more information) -

    -
    -
    -
    -
    -
    Web Logs
    -
    -
    - These caches include the page list and categories for each web log -
    - {%- assign web_log_base_url = cache_base_url | append: "web-log/" -%} -
    - - -
    -
    Web Log
    -
    - {%- for web_log in web_logs %} -
    -
    - {{ web_log[1] }}
    - - {{ web_log[2] }}
    - {%- assign refresh_url = web_log_base_url | append: web_log[0] | append: "/refresh" | relative_link -%} - Refresh -     -
    -
    - {%- endfor %} -
    -
    -
    -
    -
    -
    -
    Themes
    -
    -
    - The theme template cache is filled on demand as pages are displayed; refreshing a theme with no cached - templates will still refresh its asset cache -
    - {%- assign theme_base_url = cache_base_url | append: "theme/" -%} -
    - - -
    -
    Theme
    -
    Cached
    -
    - {%- for theme in cached_themes %} - {% unless theme[0] == "admin" %} -
    -
    - {{ theme[1] }}
    - - {{ theme[0] }} • - {%- assign refresh_url = theme_base_url | append: theme[0] | append: "/refresh" | relative_link -%} - Refresh - -
    -
    {{ theme[2] }}
    -
    - {% endunless %} - {%- endfor %} -
    -
    -
    -
    -
    -
    -
    diff --git a/src/admin-theme/category-edit.liquid b/src/admin-theme/category-edit.liquid deleted file mode 100644 index 3cb44ef..0000000 --- a/src/admin-theme/category-edit.liquid +++ /dev/null @@ -1,52 +0,0 @@ -
    -
    {{ page_title }}
    -
    - - -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    - - Cancel -
    -
    -
    -
    diff --git a/src/admin-theme/category-list-body.liquid b/src/admin-theme/category-list-body.liquid deleted file mode 100644 index 83984a9..0000000 --- a/src/admin-theme/category-list-body.liquid +++ /dev/null @@ -1,57 +0,0 @@ -
    -
    -
    - {%- 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" -%} -
    -
    -
    Category; Description
    -
    Description
    -
    -
    -
    - -
    - {% for cat in categories -%} -
    -
    - {%- if cat.parent_names %} - {% for name in cat.parent_names %}{{ name }} ⟩ {% endfor %} - {%- endif %} - {{ cat.name }}
    - - {%- assign cat_url_base = "admin/category/" | append: cat.id -%} - {%- if cat.post_count > 0 %} - - View {{ cat.post_count }} Post{% unless cat.post_count == 1 %}s{% endunless -%} - - • - {%- endif %} - - Edit - - • - {%- assign cat_del_link = cat_url_base | append: "/delete" | relative_link -%} - - Delete - - -
    -
    - {%- if cat.description %}{{ cat.description.value }}{% else %}none{% endif %} -
    -
    - {%- endfor %} -
    - {%- else -%} -
    -

    This web log has no categories defined

    -
    - {%- endif %} -
    -
    -
    diff --git a/src/admin-theme/category-list.liquid b/src/admin-theme/category-list.liquid deleted file mode 100644 index 689c41c..0000000 --- a/src/admin-theme/category-list.liquid +++ /dev/null @@ -1,8 +0,0 @@ -

    {{ page_title }}

    - diff --git a/src/admin-theme/upload-list.liquid b/src/admin-theme/upload-list.liquid deleted file mode 100644 index 24c5a9d..0000000 --- a/src/admin-theme/upload-list.liquid +++ /dev/null @@ -1,75 +0,0 @@ -

    {{ page_title }}

    -
    - {%- capture base_url %}{{ "" | relative_link }}{% endcapture -%} - {%- capture upload_path %}upload/{{ web_log.slug }}/{% endcapture -%} - {%- capture upload_base %}{{ base_url }}{{ upload_path }}{% endcapture -%} - Upload a New File -
    - -
    -
    Uploaded files served from
    {{ upload_base }}
    -
    - {%- assign file_count = files | size -%} - {%- if file_count > 0 %} -
    -
    File Name
    -
    Path
    -
    File Date/Time
    -
    - {% for file in files %} -
    -
    - {%- capture badge_class -%} - {%- if file.source == "Disk" %}secondary{% else %}primary{% endif -%} - {%- endcapture -%} - {%- assign path_and_name = file.path | append: file.name -%} - {%- assign blog_rel = upload_path | append: path_and_name -%} - {{ file.source }} - {{ file.name }}
    - - View File - • Copy - - Absolute - - | - - Relative - - {%- unless base_url == "/" %} - | - - For Post - - {%- endunless %} - Link - {% if is_web_log_admin %} - • - {%- capture delete_url -%} - {%- if file.source == "Disk" -%} - admin/upload/delete/{{ path_and_name }} - {%- else -%} - admin/upload/{{ file.id }}/delete - {%- endif -%} - {%- endcapture -%} - Delete - {% endif %} - -
    -
    {{ file.path }}
    -
    - {% if file.updated_on %}{{ file.updated_on.value | date: "yyyy-MM-dd/HH:mm" }}{% else %}--{% endif %} -
    -
    - {% endfor %} - {%- else -%} -
    -

    This web log has uploaded files
    -
    - {%- endif %} -
    -
    diff --git a/src/admin-theme/upload-new.liquid b/src/admin-theme/upload-new.liquid deleted file mode 100644 index fcd9e8d..0000000 --- a/src/admin-theme/upload-new.liquid +++ /dev/null @@ -1,29 +0,0 @@ -

    {{ page_title }}

    -
    -
    - -
    -
    -
    - - -
    -
    -
    - Destination
    -
    - - - - -
    -
    -
    -
    -
    -
    -
    -
    -- 2.45.1 From ddab491dfc886c62279680b558edbcc08eb83ade Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 15 Mar 2024 18:03:38 -0400 Subject: [PATCH 100/123] First cut of common edit model --- src/MyWebLog.Domain/ViewModels.fs | 53 +++++++++++++++++++++++++++++++ src/MyWebLog/DotLiquidBespoke.fs | 7 ++-- src/MyWebLog/Views/Helpers.fs | 34 ++++++++++++++++++++ 3 files changed, 90 insertions(+), 4 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 1e802aa..3632963 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -604,6 +604,59 @@ type EditMyInfoModel = { NewPasswordConfirm = "" } +/// View model common to page and post edits +type EditCommonModel() = + + /// Find the latest revision within a list of revisions + let findLatestRevision (revs: Revision list) = + match revs |> List.sortByDescending _.AsOf |> List.tryHead with Some rev -> rev | None -> Revision.Empty + + /// The ID of the page or post + member val Id = "" with get, set + + /// The title of the page or post + member val Title = "" with get, set + + /// The permalink for the page or post + member val Permalink = "" with get, set + + /// The entity to which this model applies ("page" or "post") + member val Entity = "" with get, set + + /// Whether to provide a link to manage chapters + member val IncludeChapterLink = false with get, set + + /// The source type ("HTML" or "Markdown") + member val Source = "" with get, set + + /// The text of the page or post + member val Text = "" with get, set + + /// Whether this is a new page or post + member this.IsNew with get () = this.Id = "new" + + /// Fill the properties of this object from a page + member this.FromPage (page: Page) = + let latest = findLatestRevision page.Revisions + this.Id <- string page.Id + this.Title <- page.Title + this.Permalink <- string page.Permalink + this.Entity <- "page" + this.Source <- latest.Text.SourceType + this.Text <- latest.Text.Text + + /// Fill the properties of this object from a post + member this.FromPost (post: Post) = + let latest = findLatestRevision post.Revisions + this.Id <- string post.Id + this.Title <- post.Title + this.Permalink <- string post.Permalink + this.Entity <- "post" + this.IncludeChapterLink <- Option.isSome post.Episode && Option.isSome post.Episode.Value.Chapters + this.Source <- latest.Text.SourceType + this.Text <- latest.Text.Text + + /// View model to edit a page [] type EditPageModel = { diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index fe1c9d7..872486b 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -228,10 +228,9 @@ let register () = typeof; typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof; typeof // View models - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index a087d2c..23213c0 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -310,6 +310,40 @@ let roundTrip = InstantPattern.CreateWithInvariantCulture "uuuu'-'MM'-'dd'T'HH': 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 [ _required; _autofocus ] (nameof model.Title) "Title" model.Title [] + textField [ _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 "     " + 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 (string Html); if model.Source = string 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 (string Markdown); if model.Source = string Markdown then _checked ] + label [ _class "btn btn-sm btn-outline-secondary"; _for "source_md" ] [ raw "Markdown" ] + ] + ] + div [ _class "pb-3" ] [ + textarea [ _name (nameof model.Text); _id (nameof model.Text); _class "form-control"; _rows "20" ] [ + raw model.Text + ] + ] +] + + /// Form to manage permalinks for pages or posts let managePermalinks (model: ManagePermalinksModel) app = [ let baseUrl = relUrl app $"admin/{model.Entity}/" -- 2.45.1 From ec04fea86c8e3b379a62664d487c4c105177e7a2 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 15 Mar 2024 22:49:27 -0400 Subject: [PATCH 101/123] Migrate page edit to GVE --- src/MyWebLog.Domain/ViewModels.fs | 245 +++++++++++------------------- src/MyWebLog/Handlers/Helpers.fs | 10 +- src/MyWebLog/Handlers/Page.fs | 12 +- src/MyWebLog/Handlers/Post.fs | 4 +- src/MyWebLog/Views/Helpers.fs | 83 +++++++--- src/MyWebLog/Views/Page.fs | 21 +++ src/admin-theme/wwwroot/admin.js | 2 +- 7 files changed, 187 insertions(+), 190 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 3632963..8c69c2c 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -626,88 +626,65 @@ type EditCommonModel() = /// Whether to provide a link to manage chapters member val IncludeChapterLink = false with get, set + /// The template to use to display the page + member val Template = "" with get, set + /// The source type ("HTML" or "Markdown") member val Source = "" with get, set /// The text of the page or post member val Text = "" with get, set + /// Names of metadata items + member val MetaNames: string array = [||] with get, set + + /// Values of metadata items + member val MetaValues: string array = [||] with get, set + /// Whether this is a new page or post member this.IsNew with get () = this.Id = "new" /// Fill the properties of this object from a page - member this.FromPage (page: Page) = + member this.PopulateFromPage (page: Page) = let latest = findLatestRevision page.Revisions - this.Id <- string page.Id - this.Title <- page.Title - this.Permalink <- string page.Permalink - this.Entity <- "page" - this.Source <- latest.Text.SourceType - this.Text <- latest.Text.Text + this.Id <- string page.Id + this.Title <- page.Title + this.Permalink <- string page.Permalink + this.Entity <- "page" + this.Template <- defaultArg page.Template "" + this.Source <- latest.Text.SourceType + this.Text <- latest.Text.Text + this.MetaNames <- page.Metadata |> List.map _.Name |> Array.ofList + this.MetaValues <- page.Metadata |> List.map _.Value |> Array.ofList /// Fill the properties of this object from a post - member this.FromPost (post: Post) = + member this.PopulateFromPost (post: Post) = let latest = findLatestRevision post.Revisions this.Id <- string post.Id this.Title <- post.Title this.Permalink <- string post.Permalink this.Entity <- "post" this.IncludeChapterLink <- Option.isSome post.Episode && Option.isSome post.Episode.Value.Chapters + this.Template <- defaultArg post.Template "" this.Source <- latest.Text.SourceType this.Text <- latest.Text.Text + this.MetaNames <- post.Metadata |> List.map _.Name |> Array.ofList + this.MetaValues <- post.Metadata |> List.map _.Value |> Array.ofList + - /// View model to edit a page -[] -type EditPageModel = { - /// The ID of the page being edited - PageId: string - - /// The title of the page - Title: string - - /// The permalink for the page - Permalink: string - - /// The template to use to display the page - Template: string +type EditPageModel() = + inherit EditCommonModel() /// Whether this page is shown in the page list - IsShownInPageList: bool + member val IsShownInPageList = false with get, set - /// The source format for the text - Source: string - - /// The text of the page - Text: string - - /// Names of metadata items - MetaNames: string array - - /// Values of metadata items - MetaValues: string array -} with - /// Create an edit model from an existing page - static member FromPage (page: Page) = - let latest = - match page.Revisions |> List.sortByDescending _.AsOf |> List.tryHead with - | Some rev -> rev - | None -> Revision.Empty - let page = if page.Metadata |> List.isEmpty then { page with Metadata = [ MetaItem.Empty ] } else page - { PageId = string page.Id - Title = page.Title - Permalink = string page.Permalink - Template = defaultArg page.Template "" - IsShownInPageList = page.IsInPageList - Source = latest.Text.SourceType - Text = latest.Text.Text - MetaNames = page.Metadata |> List.map _.Name |> Array.ofList - MetaValues = page.Metadata |> List.map _.Value |> Array.ofList } - - /// Whether this is a new page - member this.IsNew = - this.PageId = "new" + static member FromPage(page: Page) = + let model = EditPageModel() + model.PopulateFromPage page + model.IsShownInPageList <- page.IsInPageList + model /// Update a page with values from this model member this.UpdatePage (page: Page) now = @@ -737,163 +714,123 @@ type EditPageModel = { /// View model to edit a post -[] -type EditPostModel = { - /// The ID of the post being edited - PostId: string - - /// The title of the post - Title: string - - /// The permalink for the post - Permalink: string - - /// The source format for the text - Source: string - - /// The text of the post - Text: string +type EditPostModel() = + inherit EditCommonModel() /// The tags for the post - Tags: string - - /// The template used to display the post - Template: string + member val Tags = "" with get, set /// The category IDs for the post - CategoryIds: string array + member val CategoryIds: string array = [||] with get, set /// The post status - Status: string + member val Status = "" with get, set /// Whether this post should be published - DoPublish: bool - - /// Names of metadata items - MetaNames: string array - - /// Values of metadata items - MetaValues: string array + member val DoPublish = false with get, set /// Whether to override the published date/time - SetPublished: bool + member val SetPublished = false with get, set /// The published date/time to override - PubOverride: Nullable + member val PubOverride = Nullable() with get, set /// Whether all revisions should be purged and the override date set as the updated date as well - SetUpdated: bool + member val SetUpdated = false with get, set /// Whether this post has a podcast episode - IsEpisode: bool + member val IsEpisode = false with get, set /// The URL for the media for this episode (may be permalink) - Media: string + member val Media = "" with get, set /// The size (in bytes) of the media for this episode - Length: int64 + member val Length = 0L with get, set /// The duration of the media for this episode - Duration: string + member val Duration = "" with get, set /// The media type (optional, defaults to podcast-defined media type) - MediaType: string + member val MediaType = "" with get, set /// The URL for the image for this episode (may be permalink; optional, defaults to podcast image) - ImageUrl: string + member val ImageUrl = "" with get, set /// A subtitle for the episode (optional) - Subtitle: string + member val Subtitle = "" with get, set /// The explicit rating for this episode (optional, defaults to podcast setting) - Explicit: string + member val Explicit = "" with get, set /// The chapter source ("internal" for chapters defined here, "external" for a file link, "none" if none defined) - ChapterSource: string + member val ChapterSource = "" with get, set /// The URL for the chapter file for the episode (may be permalink; optional) - ChapterFile: string + member val ChapterFile = "" with get, set /// The type of the chapter file (optional; defaults to application/json+chapters if chapterFile is provided) - ChapterType: string + member val ChapterType = "" with get, set /// Whether the chapter file (or chapters) contains/contain waypoints - ContainsWaypoints: bool + member val ContainsWaypoints = false with get, set /// The URL for the transcript (may be permalink; optional) - TranscriptUrl: string + member val TranscriptUrl = "" with get, set /// The MIME type for the transcript (optional, recommended if transcriptUrl is provided) - TranscriptType: string + member val TranscriptType = "" with get, set /// The language of the transcript (optional) - TranscriptLang: string + member val TranscriptLang = "" with get, set /// Whether the provided transcript should be presented as captions - TranscriptCaptions: bool + member val TranscriptCaptions = false with get, set /// The season number (optional) - SeasonNumber: int + member val SeasonNumber = 0 with get, set /// A description of this season (optional, ignored if season number is not provided) - SeasonDescription: string + member val SeasonDescription = "" with get, set /// The episode number (decimal; optional) - EpisodeNumber: string + member val EpisodeNumber = "" with get, set /// A description of this episode (optional, ignored if episode number is not provided) - EpisodeDescription: string -} with + member val EpisodeDescription = "" with get, set /// Create an edit model from an existing past static member FromPost (webLog: WebLog) (post: Post) = - let latest = - match post.Revisions |> List.sortByDescending _.AsOf |> List.tryHead with - | Some rev -> rev - | None -> Revision.Empty - let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.Empty ] } else post + let model = EditPostModel() + let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.Empty ] } else post + model.PopulateFromPost post let episode = defaultArg post.Episode Episode.Empty - { PostId = string post.Id - Title = post.Title - Permalink = string post.Permalink - Source = latest.Text.SourceType - Text = latest.Text.Text - Tags = String.Join(", ", post.Tags) - Template = defaultArg post.Template "" - CategoryIds = post.CategoryIds |> List.map string |> Array.ofList - Status = string post.Status - DoPublish = false - MetaNames = post.Metadata |> List.map _.Name |> Array.ofList - MetaValues = post.Metadata |> List.map _.Value |> Array.ofList - SetPublished = false - PubOverride = post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable - SetUpdated = false - IsEpisode = Option.isSome post.Episode - Media = episode.Media - Length = episode.Length - Duration = defaultArg (episode.FormatDuration()) "" - MediaType = defaultArg episode.MediaType "" - ImageUrl = defaultArg episode.ImageUrl "" - Subtitle = defaultArg episode.Subtitle "" - Explicit = defaultArg (episode.Explicit |> Option.map string) "" - ChapterSource = if Option.isSome episode.Chapters then "internal" - elif Option.isSome episode.ChapterFile then "external" - else "none" - ChapterFile = defaultArg episode.ChapterFile "" - ChapterType = defaultArg episode.ChapterType "" - ContainsWaypoints = defaultArg episode.ChapterWaypoints false - TranscriptUrl = defaultArg episode.TranscriptUrl "" - TranscriptType = defaultArg episode.TranscriptType "" - TranscriptLang = defaultArg episode.TranscriptLang "" - TranscriptCaptions = defaultArg episode.TranscriptCaptions false - SeasonNumber = defaultArg episode.SeasonNumber 0 - SeasonDescription = defaultArg episode.SeasonDescription "" - EpisodeNumber = defaultArg (episode.EpisodeNumber |> Option.map string) "" - EpisodeDescription = defaultArg episode.EpisodeDescription "" } - - /// Whether this is a new post - member this.IsNew = - this.PostId = "new" + model.Tags <- post.Tags |> String.concat ", " + model.CategoryIds <- post.CategoryIds |> List.map string |> Array.ofList + model.Status <- string post.Status + model.PubOverride <- post.PublishedOn |> Option.map webLog.LocalTime |> Option.toNullable + model.IsEpisode <- Option.isSome post.Episode + model.Media <- episode.Media + model.Length <- episode.Length + model.Duration <- defaultArg (episode.FormatDuration()) "" + model.MediaType <- defaultArg episode.MediaType "" + model.ImageUrl <- defaultArg episode.ImageUrl "" + model.Subtitle <- defaultArg episode.Subtitle "" + model.Explicit <- defaultArg (episode.Explicit |> Option.map string) "" + model.ChapterSource <- if Option.isSome episode.Chapters then "internal" + elif Option.isSome episode.ChapterFile then "external" + else "none" + model.ChapterFile <- defaultArg episode.ChapterFile "" + model.ChapterType <- defaultArg episode.ChapterType "" + model.ContainsWaypoints <- defaultArg episode.ChapterWaypoints false + model.TranscriptUrl <- defaultArg episode.TranscriptUrl "" + model.TranscriptType <- defaultArg episode.TranscriptType "" + model.TranscriptLang <- defaultArg episode.TranscriptLang "" + model.TranscriptCaptions <- defaultArg episode.TranscriptCaptions false + model.SeasonNumber <- defaultArg episode.SeasonNumber 0 + model.SeasonDescription <- defaultArg episode.SeasonDescription "" + model.EpisodeNumber <- defaultArg (episode.EpisodeNumber |> Option.map string) "" + model.EpisodeDescription <- defaultArg episode.EpisodeDescription "" + model /// Update a post with values from the submitted form member this.UpdatePost (post: Post) now = diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index e78a580..98c7c9a 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -427,23 +427,21 @@ let absoluteUrl (url: string) (ctx: HttpContext) = if url.StartsWith "http" then url else ctx.WebLog.AbsoluteUrl (Permalink url) -open System.Collections.Generic 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 diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 9563b94..070976c 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -34,15 +34,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { | Some (title, page) when canEdit page.AuthorId ctx -> let model = EditPageModel.FromPage page let! templates = templatesForTheme ctx "page" - return! - 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 } @@ -177,7 +169,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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 diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 8e0cdb4..67e44a4 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -505,7 +505,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { WebLogId = ctx.WebLog.Id AuthorId = ctx.UserId } |> someTask - else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id + else data.Post.FindFullById (PostId model.Id) ctx.WebLog.Id match! tryPost with | Some post when canEdit post.AuthorId ctx -> let priorCats = post.CategoryIds @@ -522,7 +522,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { 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 diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index 23213c0..6ddfdc0 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -105,19 +105,25 @@ let shortTime app (instant: Instant) = 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, newAttrs = - let passedId = attrs |> List.tryFind (fun x -> match x with KeyValue ("id", _) -> true | _ -> false) - match passedId with - | Some (KeyValue (_, idValue)) -> - idValue, attrs |> List.filter (fun x -> match x with KeyValue ("id", _) -> false | _ -> true) - | Some _ | None -> name, attrs - div [ _class "form-floating" ] [ - [ _type fieldType; _name name; _id fieldId; _class "form-control"; _placeholder labelText; _value value ] - |> List.append newAttrs + 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 fieldId ] [ raw labelText ] + label [ _for (defaultArg fieldId name) ] [ raw labelText ] yield! extra ] @@ -140,7 +146,8 @@ let passwordField 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 = - div [ _class "form-floating" ] [ + 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) @@ -152,7 +159,8 @@ let selectField<'T, 'a> /// Create a checkbox input styled as a switch let checkboxSwitch attrs name labelText (value: bool) extra = - div [ _class "form-check form-switch" ] [ + 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 @@ -312,8 +320,8 @@ let private capitalize (it: string) = /// The common edit form shared by pages and posts let commonEdit (model: EditCommonModel) app = [ - textField [ _required; _autofocus ] (nameof model.Title) "Title" model.Title [] - textField [ _required ] (nameof model.Permalink) "Permalink" model.Permalink [ + 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" ] [ @@ -329,14 +337,14 @@ let commonEdit (model: EditCommonModel) app = [ label [ _for "text" ] [ raw "Text" ]; raw "     " 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 (string Html); if model.Source = string Html then _checked ] + _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 (string Markdown); if model.Source = string Markdown then _checked ] + _value "Markdown"; if model.Source = "Markdown" then _checked ] label [ _class "btn btn-sm btn-outline-secondary"; _for "source_md" ] [ raw "Markdown" ] ] ] - div [ _class "pb-3" ] [ + div [ _class "mb-3" ] [ textarea [ _name (nameof model.Text); _id (nameof model.Text); _class "form-control"; _rows "20" ] [ raw model.Text ] @@ -344,6 +352,47 @@ let commonEdit (model: EditCommonModel) app = [ ] +/// 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 "−" + ] + ] + 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}))" + ] + ] + ] + + /// Form to manage permalinks for pages or posts let managePermalinks (model: ManagePermalinksModel) app = [ let baseUrl = relUrl app $"admin/{model.Entity}/" diff --git a/src/MyWebLog/Views/Page.fs b/src/MyWebLog/Views/Page.fs index 360858d..55b28de 100644 --- a/src/MyWebLog/Views/Page.fs +++ b/src/MyWebLog/Views/Page.fs @@ -5,6 +5,27 @@ 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 ] diff --git a/src/admin-theme/wwwroot/admin.js b/src/admin-theme/wwwroot/admin.js index d69e134..7edc1e5 100644 --- a/src/admin-theme/wwwroot/admin.js +++ b/src/admin-theme/wwwroot/admin.js @@ -146,7 +146,7 @@ this.Admin = { newRow.appendChild(nameCol) newRow.appendChild(valueCol) - document.getElementById("metaItems").appendChild(newRow) + document.getElementById("meta_items").appendChild(newRow) this.nextMetaIndex++ }, -- 2.45.1 From a448339870e3f49ee981e921a07c75ae2ffc6ac8 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Mar 2024 00:06:04 -0400 Subject: [PATCH 102/123] Migrate post edit to GVE --- src/MyWebLog/Handlers/Helpers.fs | 8 - src/MyWebLog/Handlers/Post.fs | 21 +-- src/MyWebLog/Views/Post.fs | 243 +++++++++++++++++++++++++++++++ 3 files changed, 249 insertions(+), 23 deletions(-) diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 98c7c9a..74cd160 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -178,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 @@ -362,10 +358,6 @@ let themedView template next ctx hash = task { /// The ID for the admin theme let adminTheme = ThemeId "admin" -/// Display a view for the admin theme -let adminView template = - viewForTheme adminTheme template - /// Display a bare view for the admin theme let adminBareView template = bareForTheme adminTheme template diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 67e44a4..6b8fec5 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -272,21 +272,12 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { | 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("", "– Default –") - KeyValuePair.Create(string Yes, "Yes") - KeyValuePair.Create(string No, "No") - KeyValuePair.Create(string Clean, "Clean") - |] - |> adminView "post-edit" next ctx + let ratings = [ + { 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 } diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index d7b9499..5e568fe 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -276,3 +276,246 @@ let list (model: PostDisplay) app = [ 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)" + 0 (* TODO: 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 [] (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 [] (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" 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" + 0 (* TODO: 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
    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 "  ⟩  ") + txt cat.Name + ] + ] + ] + ] + ] + ] + ] + script [] [ raw "window.setTimeout(() => Admin.toggleEpisodeFields(), 500)" ] +] -- 2.45.1 From 64599316d5885223af12c67c9261a8d490729786 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Mar 2024 10:56:55 -0400 Subject: [PATCH 103/123] Eliminate final admin theme Liquid resources - Update admin.js with new field IDs --- src/MyWebLog/Handlers/Admin.fs | 2 +- src/MyWebLog/Handlers/Helpers.fs | 9 +- src/MyWebLog/Handlers/Page.fs | 15 +- src/MyWebLog/Handlers/Post.fs | 15 +- src/MyWebLog/Views/Helpers.fs | 8 + src/admin-theme/_edit-common.liquid | 38 --- src/admin-theme/_layout.liquid | 80 ------ src/admin-theme/layout-bare.liquid | 5 - src/admin-theme/layout-partial.liquid | 5 - src/admin-theme/layout.liquid | 17 -- src/admin-theme/page-edit.liquid | 82 ------- src/admin-theme/post-edit.liquid | 341 -------------------------- src/admin-theme/wwwroot/admin.js | 18 +- 13 files changed, 25 insertions(+), 610 deletions(-) delete mode 100644 src/admin-theme/_edit-common.liquid delete mode 100644 src/admin-theme/_layout.liquid delete mode 100644 src/admin-theme/layout-bare.liquid delete mode 100644 src/admin-theme/layout-partial.liquid delete mode 100644 src/admin-theme/layout.liquid delete mode 100644 src/admin-theme/page-edit.liquid delete mode 100644 src/admin-theme/post-edit.liquid diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 2446197..fefd983 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -384,7 +384,7 @@ module Theme = if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then let themeFile = Seq.head ctx.Request.Form.Files match deriveIdFromFileName themeFile.FileName with - | Ok themeId when themeId <> adminTheme -> + | Ok themeId when themeId <> ThemeId "admin" -> let data = ctx.Data let! exists = data.Theme.Exists themeId let isNew = not exists diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 74cd160..13a0501 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -355,13 +355,6 @@ let themedView template next ctx hash = task { return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash } -/// The ID for the admin theme -let adminTheme = ThemeId "admin" - -/// Display a bare view for the admin theme -let adminBareView template = - bareForTheme adminTheme template - /// Display a page for an admin endpoint let adminPage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task { let! messages = getCurrentMessages ctx @@ -416,7 +409,7 @@ let someTask<'T> (it: 'T) = Task.FromResult(Some it) /// 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) + if url.StartsWith "http" then url else ctx.WebLog.AbsoluteUrl(Permalink url) open MyWebLog.Data diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 070976c..2d23bc1 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -115,18 +115,9 @@ 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 = - [ """
    """ - rev.Text.AsHtml() |> addBaseToRelativeUrls ctx.WebLog.ExtraPath - "
    " - ] - |> String.concat "" - |} - |> 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/page/{id}/revision/{revision-date}/restore @@ -150,7 +141,7 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun | Some pg, Some rev when canEdit pg.AuthorId ctx -> do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } - return! adminBareView "" next ctx (makeHash {| content = "" |}) + return! adminBarePage "" false next ctx (fun _ -> []) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ | _, None -> return! Error.notFound next ctx diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 6b8fec5..216cb8d 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -358,18 +358,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 = - [ """
    """ - rev.Text.AsHtml() |> addBaseToRelativeUrls ctx.WebLog.ExtraPath - "
    " - ] - |> String.concat "" - |} - |> 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 @@ -393,7 +384,7 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu | Some post, Some rev when canEdit post.AuthorId ctx -> do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } - return! adminBareView "" next ctx (makeHash {| content = "" |}) + return! adminBarePage "" false next ctx (fun _ -> []) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ | _, None -> return! Error.notFound next ctx diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index 6ddfdc0..cf4d716 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -393,6 +393,14 @@ let commonMetaItems (model: EditCommonModel) = ] +/// 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}/" diff --git a/src/admin-theme/_edit-common.liquid b/src/admin-theme/_edit-common.liquid deleted file mode 100644 index e72622b..0000000 --- a/src/admin-theme/_edit-common.liquid +++ /dev/null @@ -1,38 +0,0 @@ -
    - - -
    -
    - - - {%- unless model.is_new %} - {%- assign entity_url_base = "admin/" | append: entity | append: "/" | append: entity_id -%} - - Manage Permalinks - • - Manage Revisions - {% if model.chapter_source == "internal" %} - - • - Manage Chapters - - {% endif %} - - {%- endunless -%} -
    -
    -     -
    - - - - -
    -
    -
    - -
    diff --git a/src/admin-theme/_layout.liquid b/src/admin-theme/_layout.liquid deleted file mode 100644 index 440acea..0000000 --- a/src/admin-theme/_layout.liquid +++ /dev/null @@ -1,80 +0,0 @@ -
    - -
    -
    -
    - {% for msg in messages %} - - {% endfor %} -
    -
    -
    -

    Loading…

    - {{ content }} -
    -
    -
    - {%- assign version = generator | split: " " -%} - v{{ version[1] }} - myWebLog -
    -
    diff --git a/src/admin-theme/layout-bare.liquid b/src/admin-theme/layout-bare.liquid deleted file mode 100644 index 4335d8d..0000000 --- a/src/admin-theme/layout-bare.liquid +++ /dev/null @@ -1,5 +0,0 @@ - - - -{{ content }} - diff --git a/src/admin-theme/layout-partial.liquid b/src/admin-theme/layout-partial.liquid deleted file mode 100644 index fe06a41..0000000 --- a/src/admin-theme/layout-partial.liquid +++ /dev/null @@ -1,5 +0,0 @@ - - - {{ page_title | strip_html }} « Admin « {{ web_log.name | strip_html }} - {% include_template "_layout" %} - diff --git a/src/admin-theme/layout.liquid b/src/admin-theme/layout.liquid deleted file mode 100644 index 264428c..0000000 --- a/src/admin-theme/layout.liquid +++ /dev/null @@ -1,17 +0,0 @@ - - - - - {{ page_title | strip_html }} « Admin « {{ web_log.name | strip_html }} - - - - {% include_template "_layout" %} - - {{ htmx_script }} - - - diff --git a/src/admin-theme/page-edit.liquid b/src/admin-theme/page-edit.liquid deleted file mode 100644 index 715ec05..0000000 --- a/src/admin-theme/page-edit.liquid +++ /dev/null @@ -1,82 +0,0 @@ -

    {{ page_title }}

    -
    -
    - - -
    -
    -
    - {%- assign entity = "page" -%} - {%- assign entity_id = model.page_id -%} - {% include_template "_edit-common" %} -
    -
    -
    - - -
    -
    - - -
    -
    -
    -
    -
    - -
    -
    -
    -
    -
    - - Metadata - - -
    -
    - {%- for meta in metadata %} -
    -
    - -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    - {% endfor -%} -
    - - -
    -
    -
    -
    -
    -
    -
    diff --git a/src/admin-theme/post-edit.liquid b/src/admin-theme/post-edit.liquid deleted file mode 100644 index 03dcdd7..0000000 --- a/src/admin-theme/post-edit.liquid +++ /dev/null @@ -1,341 +0,0 @@ -

    {{ page_title }}

    -
    -
    - - -
    -
    -
    - {%- assign entity = "post" -%} - {%- assign entity_id = model.post_id -%} - {% include_template "_edit-common" %} -
    - - -
    comma-delimited
    -
    - {% if model.status == "Draft" %} -
    - - -
    - {% endif %} - -
    -
    - - - - - - - - -
    -
    -
    -
    - - -
    - Relative URL will be appended to base media path (if set) or served from this web log -
    -
    -
    -
    -
    - - -
    Optional; overrides podcast default
    -
    -
    -
    -
    -
    -
    - - -
    TODO: derive from above file name
    -
    -
    -
    -
    - - -
    Recommended; enter in HH:MM:SS format
    -
    -
    -
    -
    -
    -
    - - -
    Optional; a subtitle for this episode
    -
    -
    -
    -
    -
    -
    - - -
    - Optional; overrides podcast default; relative URL served from this web log -
    -
    -
    -
    -
    - - -
    Optional; overrides podcast default
    -
    -
    -
    -
    -
    -
    Chapters
    -
    - - -
    -
    - - -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    - - -
    Relative URL served from this web log
    -
    -
    -
    -
    - - -
    - Optional; application/json+chapters assumed if chapter file ends with - .json -
    -
    -
    -
    -
    -
    -
    - - -
    Optional; relative URL served from this web log
    -
    -
    -
    -
    - - -
    Required if transcript URL provided
    -
    -
    -
    -
    -
    -
    - - -
    Optional; overrides podcast default
    -
    -
    -
    -
    - - -
    -
    -
    -
    -
    -
    - - -
    Optional
    -
    -
    -
    -
    - - -
    Optional
    -
    -
    -
    -
    -
    -
    - - -
    Optional; up to 2 decimal points
    -
    -
    -
    -
    - - -
    Optional
    -
    -
    -
    -
    - -
    -
    - - Metadata - - -
    -
    - {%- for meta in metadata %} -
    -
    - -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    - {% endfor -%} -
    - - -
    -
    - {% if model.status == "Published" %} -
    - Maintenance -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    - - -
    -
    -
    -
    -
    - {% endif %} -
    -
    -
    - - -
    -
    - Categories - {% for cat in categories %} -
    - - -
    - {% endfor %} -
    -
    -
    -
    -
    -
    - diff --git a/src/admin-theme/wwwroot/admin.js b/src/admin-theme/wwwroot/admin.js index 7edc1e5..989065c 100644 --- a/src/admin-theme/wwwroot/admin.js +++ b/src/admin-theme/wwwroot/admin.js @@ -217,13 +217,13 @@ this.Admin = { * @param {"none"|"internal"|"external"} src The source for chapters for this episode */ setChapterSource(src) { - document.getElementById("containsWaypoints").disabled = src === "none" + document.getElementById("ContainsWaypoints").disabled = src === "none" const isDisabled = src === "none" || src === "internal" - const chapterFile = document.getElementById("chapterFile") + const chapterFile = document.getElementById("ChapterFile") chapterFile.disabled = isDisabled chapterFile.required = !isDisabled - document.getElementById("chapterType").disabled = isDisabled - const link = document.getElementById("chapterEditLink") + document.getElementById("ChapterType").disabled = isDisabled + const link = document.getElementById("ChapterEditLink") if (link) link.style.display = src === "none" || src === "external" ? "none" : "" }, @@ -231,13 +231,13 @@ this.Admin = { * Enable or disable podcast fields */ toggleEpisodeFields() { - const disabled = !document.getElementById("isEpisode").checked + const disabled = !document.getElementById("IsEpisode").checked let fields = [ - "media", "mediaType", "length", "duration", "subtitle", "imageUrl", "explicit", "transcriptUrl", "transcriptType", - "transcriptLang", "transcriptCaptions", "seasonNumber", "seasonDescription", "episodeNumber", "episodeDescription" + "Media", "MediaType", "Length", "Duration", "Subtitle", "ImageUrl", "Explicit", "TranscriptUrl", "TranscriptType", + "TranscriptLang", "TranscriptCaptions", "SeasonNumber", "SeasonDescription", "EpisodeNumber", "EpisodeDescription" ] if (disabled) { - fields.push("chapterFile", "chapterType", "containsWaypoints") + fields.push("ChapterFile", "ChapterType", "ContainsWaypoints") } else { const src = [...document.getElementsByName("ChapterSource")].filter(it => it.checked)[0].value this.setChapterSource(src) @@ -302,7 +302,7 @@ this.Admin = { * Require transcript type if transcript URL is present */ requireTranscriptType() { - document.getElementById("transcriptType").required = document.getElementById("transcriptUrl").value.trim() !== "" + document.getElementById("TranscriptType").required = document.getElementById("TranscriptUrl").value.trim() !== "" }, /** -- 2.45.1 From 54e46fdeb6c51e129247fdce7b167640f8e419a1 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Mar 2024 12:20:08 -0400 Subject: [PATCH 104/123] Remove unneeded types --- src/MyWebLog.Domain/ViewModels.fs | 281 +++------- src/MyWebLog.Tests/Domain/ViewModelsTests.fs | 528 ++++++++----------- src/MyWebLog/DotLiquidBespoke.fs | 9 +- src/MyWebLog/Handlers/Admin.fs | 2 - src/MyWebLog/Views/WebLog.fs | 63 ++- 5 files changed, 336 insertions(+), 547 deletions(-) diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 8c69c2c..d52cd10 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -73,82 +73,6 @@ type DisplayCategory = { } -/// A display version of an episode chapter -type DisplayChapter = { - /// The start time of the chapter (H:mm:ss.FF format) - StartTime: string - - /// The title of the chapter - Title: string - - /// An image to display for this chapter - ImageUrl: string - - /// A URL with information about this chapter - Url: string - - /// Whether this chapter should be displayed in podcast players - IsHidden: bool - - /// The end time of the chapter (H:mm:ss.FF format) - EndTime: string - - /// The name of a location - LocationName: string - - /// The geographic coordinates of the location - LocationGeo: string - - /// An OpenStreetMap query for this location - LocationOsm: string -} with - - /// Create a display chapter from a chapter - static member FromChapter (chapter: Chapter) = - let pattern = DurationPattern.CreateWithInvariantCulture "H:mm:ss.FF" - { StartTime = pattern.Format chapter.StartTime - Title = defaultArg chapter.Title "" - ImageUrl = defaultArg chapter.ImageUrl "" - Url = defaultArg chapter.Url "" - IsHidden = defaultArg chapter.IsHidden false - EndTime = chapter.EndTime |> Option.map pattern.Format |> Option.defaultValue "" - LocationName = chapter.Location |> Option.map _.Name |> Option.defaultValue "" - LocationGeo = chapter.Location |> Option.map _.Geo |> Option.defaultValue "" - LocationOsm = chapter.Location |> Option.map _.Osm |> Option.flatten |> Option.defaultValue "" } - - -/// A display version of a custom feed definition -type DisplayCustomFeed = { - /// The ID of the custom feed - Id: string - - /// The source of the custom feed - Source: string - - /// The relative path at which the custom feed is served - Path: string - - /// Whether this custom feed is for a podcast - IsPodcast: bool -} with - - /// Create a display version from a custom feed - static member FromFeed (cats: DisplayCategory array) (feed: CustomFeed) = - let source = - match feed.Source with - | Category (CategoryId catId) -> - cats - |> Array.tryFind (fun cat -> cat.Id = catId) - |> Option.map _.Name - |> Option.defaultValue "--INVALID; DELETE THIS FEED--" - |> sprintf "Category: %s" - | Tag tag -> $"Tag: {tag}" - { Id = string feed.Id - Source = source - Path = string feed.Path - IsPodcast = Option.isSome feed.Podcast } - - /// Details about a page used to display page lists [] type DisplayPage = { @@ -269,50 +193,6 @@ type DisplayUpload = { Source = string source } -/// View model to display a user's information -[] -type DisplayUser = { - /// The ID of the user - Id: string - - /// The user name (e-mail address) - Email: string - - /// The user's first name - FirstName: string - - /// The user's last name - LastName: string - - /// The user's preferred name - PreferredName: string - - /// The URL of the user's personal site - Url: string - - /// The user's access level - AccessLevel: string - - /// When the user was created - CreatedOn: DateTime - - /// When the user last logged on - LastSeenOn: Nullable -} with - - /// Construct a displayed user from a web log user - static member FromUser (webLog: WebLog) (user: WebLogUser) = - { Id = string user.Id - Email = user.Email - FirstName = user.FirstName - LastName = user.LastName - PreferredName = user.PreferredName - Url = defaultArg user.Url "" - AccessLevel = string user.AccessLevel - CreatedOn = webLog.LocalTime user.CreatedOn - LastSeenOn = user.LastSeenOn |> Option.map webLog.LocalTime |> Option.toNullable } - - /// View model for editing categories [] type EditCategoryModel = { @@ -386,19 +266,19 @@ type EditChapterModel = { } with /// Create a display chapter from a chapter - static member FromChapter (postId: PostId) idx chapter = - let it = DisplayChapter.FromChapter chapter + static member FromChapter (postId: PostId) idx (chapter: Chapter) = + let pattern = DurationPattern.CreateWithInvariantCulture "H:mm:ss.FF" { PostId = string postId Index = idx - StartTime = it.StartTime - Title = it.Title - ImageUrl = it.ImageUrl - Url = it.Url - IsHidden = it.IsHidden - EndTime = it.EndTime - LocationName = it.LocationName - LocationGeo = it.LocationGeo - LocationOsm = it.LocationOsm + StartTime = pattern.Format chapter.StartTime + Title = defaultArg chapter.Title "" + ImageUrl = defaultArg chapter.ImageUrl "" + Url = defaultArg chapter.Url "" + IsHidden = defaultArg chapter.IsHidden false + EndTime = chapter.EndTime |> Option.map pattern.Format |> Option.defaultValue "" + LocationName = chapter.Location |> Option.map _.Name |> Option.defaultValue "" + LocationGeo = chapter.Location |> Option.map _.Geo |> Option.defaultValue "" + LocationOsm = chapter.Location |> Option.map _.Osm |> Option.flatten |> Option.defaultValue "" AddAnother = false } /// Create a chapter from the values in this model @@ -427,6 +307,76 @@ type EditChapterModel = { Location = location } +/// View model common to page and post edits +type EditCommonModel() = + + /// Find the latest revision within a list of revisions + let findLatestRevision (revs: Revision list) = + match revs |> List.sortByDescending _.AsOf |> List.tryHead with Some rev -> rev | None -> Revision.Empty + + /// The ID of the page or post + member val Id = "" with get, set + + /// The title of the page or post + member val Title = "" with get, set + + /// The permalink for the page or post + member val Permalink = "" with get, set + + /// The entity to which this model applies ("page" or "post") + member val Entity = "" with get, set + + /// Whether to provide a link to manage chapters + member val IncludeChapterLink = false with get, set + + /// The template to use to display the page + member val Template = "" with get, set + + /// The source type ("HTML" or "Markdown") + member val Source = "" with get, set + + /// The text of the page or post + member val Text = "" with get, set + + /// Names of metadata items + member val MetaNames: string array = [||] with get, set + + /// Values of metadata items + member val MetaValues: string array = [||] with get, set + + /// Whether this is a new page or post + member this.IsNew with get () = this.Id = "new" + + /// Fill the properties of this object from a page + member this.PopulateFromPage (page: Page) = + let latest = findLatestRevision page.Revisions + let metaItems = if page.Metadata.Length = 0 then [ MetaItem.Empty ] else page.Metadata + this.Id <- string page.Id + this.Title <- page.Title + this.Permalink <- string page.Permalink + this.Entity <- "page" + this.Template <- defaultArg page.Template "" + this.Source <- latest.Text.SourceType + this.Text <- latest.Text.Text + this.MetaNames <- metaItems |> List.map _.Name |> Array.ofList + this.MetaValues <- metaItems |> List.map _.Value |> Array.ofList + + /// Fill the properties of this object from a post + member this.PopulateFromPost (post: Post) = + let latest = findLatestRevision post.Revisions + let metaItems = if post.Metadata.Length = 0 then [ MetaItem.Empty ] else post.Metadata + this.Id <- string post.Id + this.Title <- post.Title + this.Permalink <- string post.Permalink + this.Entity <- "post" + this.IncludeChapterLink <- Option.isSome post.Episode && Option.isSome post.Episode.Value.Chapters + this.Template <- defaultArg post.Template "" + this.Source <- latest.Text.SourceType + this.Text <- latest.Text.Text + this.MetaNames <- metaItems |> List.map _.Name |> Array.ofList + this.MetaValues <- metaItems |> List.map _.Value |> Array.ofList + + /// View model to edit a custom RSS feed [] type EditCustomFeedModel = { @@ -604,74 +554,6 @@ type EditMyInfoModel = { NewPasswordConfirm = "" } -/// View model common to page and post edits -type EditCommonModel() = - - /// Find the latest revision within a list of revisions - let findLatestRevision (revs: Revision list) = - match revs |> List.sortByDescending _.AsOf |> List.tryHead with Some rev -> rev | None -> Revision.Empty - - /// The ID of the page or post - member val Id = "" with get, set - - /// The title of the page or post - member val Title = "" with get, set - - /// The permalink for the page or post - member val Permalink = "" with get, set - - /// The entity to which this model applies ("page" or "post") - member val Entity = "" with get, set - - /// Whether to provide a link to manage chapters - member val IncludeChapterLink = false with get, set - - /// The template to use to display the page - member val Template = "" with get, set - - /// The source type ("HTML" or "Markdown") - member val Source = "" with get, set - - /// The text of the page or post - member val Text = "" with get, set - - /// Names of metadata items - member val MetaNames: string array = [||] with get, set - - /// Values of metadata items - member val MetaValues: string array = [||] with get, set - - /// Whether this is a new page or post - member this.IsNew with get () = this.Id = "new" - - /// Fill the properties of this object from a page - member this.PopulateFromPage (page: Page) = - let latest = findLatestRevision page.Revisions - this.Id <- string page.Id - this.Title <- page.Title - this.Permalink <- string page.Permalink - this.Entity <- "page" - this.Template <- defaultArg page.Template "" - this.Source <- latest.Text.SourceType - this.Text <- latest.Text.Text - this.MetaNames <- page.Metadata |> List.map _.Name |> Array.ofList - this.MetaValues <- page.Metadata |> List.map _.Value |> Array.ofList - - /// Fill the properties of this object from a post - member this.PopulateFromPost (post: Post) = - let latest = findLatestRevision post.Revisions - this.Id <- string post.Id - this.Title <- post.Title - this.Permalink <- string post.Permalink - this.Entity <- "post" - this.IncludeChapterLink <- Option.isSome post.Episode && Option.isSome post.Episode.Value.Chapters - this.Template <- defaultArg post.Template "" - this.Source <- latest.Text.SourceType - this.Text <- latest.Text.Text - this.MetaNames <- post.Metadata |> List.map _.Name |> Array.ofList - this.MetaValues <- post.Metadata |> List.map _.Value |> Array.ofList - - /// View model to edit a page type EditPageModel() = inherit EditCommonModel() @@ -801,7 +683,6 @@ type EditPostModel() = /// Create an edit model from an existing past static member FromPost (webLog: WebLog) (post: Post) = let model = EditPostModel() - let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.Empty ] } else post model.PopulateFromPost post let episode = defaultArg post.Episode Episode.Empty model.Tags <- post.Tags |> String.concat ", " diff --git a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs index e55e488..da29a2b 100644 --- a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs @@ -33,88 +33,6 @@ let addBaseToRelativeUrlsTests = testList "PublicHelpers.addBaseToRelativeUrls" } ] -/// Unit tests for the DisplayChapter type -let displayChapterTests = testList "DisplayChapter.FromChapter" [ - test "succeeds for a minimally-filled chapter" { - let chapter = DisplayChapter.FromChapter { Chapter.Empty with StartTime = Duration.FromSeconds 322L } - Expect.equal chapter.StartTime "0:05:22" "Start time not filled/formatted properly" - Expect.equal chapter.Title "" "Title not filled properly" - Expect.equal chapter.ImageUrl "" "Image URL not filled properly" - Expect.isFalse chapter.IsHidden "Is hidden flag not filled properly" - Expect.equal chapter.EndTime "" "End time not filled properly" - Expect.equal chapter.LocationName "" "Location name not filled properly" - Expect.equal chapter.LocationGeo "" "Location geo URL not filled properly" - Expect.equal chapter.LocationOsm "" "Location OSM query not filled properly" - } - test "succeeds for a fully-filled chapter" { - let chapter = - DisplayChapter.FromChapter - { StartTime = Duration.FromSeconds 7201.43242 - Title = Some "My Test Chapter" - ImageUrl = Some "two-hours-in.jpg" - Url = Some "https://example.com/about" - IsHidden = Some true - EndTime = Some (Duration.FromSeconds 7313.788) - Location = Some { Name = "Over Here"; Geo = "geo:23432"; Osm = Some "SF98fFSu-8" } } - Expect.equal chapter.StartTime "2:00:01.43" "Start time not filled/formatted properly" - Expect.equal chapter.Title "My Test Chapter" "Title not filled properly" - Expect.equal chapter.ImageUrl "two-hours-in.jpg" "Image URL not filled properly" - Expect.equal chapter.Url "https://example.com/about" "URL not filled properly" - Expect.isTrue chapter.IsHidden "Is hidden flag not filled properly" - Expect.equal chapter.EndTime "2:01:53.78" "End time not filled/formatted properly" - Expect.equal chapter.LocationName "Over Here" "Location name not filled properly" - Expect.equal chapter.LocationGeo "geo:23432" "Location geo URL not filled properly" - Expect.equal chapter.LocationOsm "SF98fFSu-8" "Location OSM query not filled properly" - } -] - -/// Unit tests for the DisplayCustomFeed type -let displayCustomFeedTests = testList "DisplayCustomFeed.FromFeed" [ - test "succeeds for a feed for an existing category" { - let cats = - [| { DisplayCategory.Id = "abc" - Slug = "a-b-c" - Name = "My Lovely Category" - Description = None - ParentNames = [||] - PostCount = 3 } |] - let feed = - { CustomFeed.Empty with - Id = CustomFeedId "test-feed" - Source = Category (CategoryId "abc") - Path = Permalink "test-feed.xml" } - let model = DisplayCustomFeed.FromFeed cats feed - Expect.equal model.Id "test-feed" "Id not filled properly" - Expect.equal model.Source "Category: My Lovely Category" "Source not filled properly" - Expect.equal model.Path "test-feed.xml" "Path not filled properly" - Expect.isFalse model.IsPodcast "IsPodcast not filled properly" - } - test "succeeds for a feed for a non-existing category" { - let feed = - { CustomFeed.Empty with - Id = CustomFeedId "bad-feed" - Source = Category (CategoryId "xyz") - Path = Permalink "trouble.xml" } - let model = DisplayCustomFeed.FromFeed [||] feed - Expect.equal model.Id "bad-feed" "Id not filled properly" - Expect.equal model.Source "Category: --INVALID; DELETE THIS FEED--" "Source not filled properly" - Expect.equal model.Path "trouble.xml" "Path not filled properly" - Expect.isFalse model.IsPodcast "IsPodcast not filled properly" - } - test "succeeds for a feed for a tag" { - let feed = - { Id = CustomFeedId "tag-feed" - Source = Tag "testing" - Path = Permalink "testing-posts.xml" - Podcast = Some PodcastOptions.Empty } - let model = DisplayCustomFeed.FromFeed [||] feed - Expect.equal model.Id "tag-feed" "Id not filled properly" - Expect.equal model.Source "Tag: testing" "Source not filled properly" - Expect.equal model.Path "testing-posts.xml" "Path not filled properly" - Expect.isTrue model.IsPodcast "IsPodcast not filled properly" - } -] - /// Unit tests for the DisplayPage type let displayPageTests = testList "DisplayPage" [ let page = @@ -242,47 +160,6 @@ let displayUploadTests = test "DisplayUpload.FromUpload succeeds" { model.UpdatedOn.Value ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "UpdatedOn not filled properly" } -/// Unit tests for the DisplayUser type -let displayUserTests = testList "DisplayUser.FromUser" [ - let minimalUser = - { WebLogUser.Empty with - Id = WebLogUserId "test-user" - Email = "jim.james@example.com" - FirstName = "Jim" - LastName = "James" - PreferredName = "John" - AccessLevel = Editor - CreatedOn = Noda.epoch } - test "succeeds when the user has minimal information" { - let model = DisplayUser.FromUser WebLog.Empty minimalUser - Expect.equal model.Id "test-user" "Id not filled properly" - Expect.equal model.Email "jim.james@example.com" "Email not filled properly" - Expect.equal model.FirstName "Jim" "FirstName not filled properly" - Expect.equal model.LastName "James" "LastName not filled properly" - Expect.equal model.PreferredName "John" "PreferredName not filled properly" - Expect.equal model.Url "" "Url not filled properly" - Expect.equal model.AccessLevel "Editor" "AccessLevel not filled properly" - Expect.equal model.CreatedOn (Noda.epoch.ToDateTimeUtc()) "CreatedOn not filled properly" - Expect.isFalse model.LastSeenOn.HasValue "LastSeenOn should have been null" - } - test "succeeds when the user has all information" { - let model = - DisplayUser.FromUser - { WebLog.Empty with TimeZone = "Etc/GMT-1" } - { minimalUser with - Url = Some "https://my.site" - LastSeenOn = Some (Noda.epoch + Duration.FromDays 4) } - Expect.equal model.Url "https://my.site" "Url not filled properly" - Expect.equal - model.CreatedOn ((Noda.epoch + Duration.FromHours 1).ToDateTimeUtc()) "CreatedOn not filled properly" - Expect.isTrue model.LastSeenOn.HasValue "LastSeenOn should not have been null" - Expect.equal - model.LastSeenOn.Value - ((Noda.epoch + Duration.FromDays 4 + Duration.FromHours 1).ToDateTimeUtc()) - "LastSeenOn not filled properly" - } - ] - /// Unit tests for the EditCategoryModel type let editCategoryModelTests = testList "EditCategoryModel" [ testList "FromCategory" [ @@ -315,6 +192,131 @@ let editCategoryModelTests = testList "EditCategoryModel" [ ] ] +/// A full page used to test various models +let private testFullPage = + { Page.Empty with + Id = PageId "the-page" + Title = "Test Page" + Permalink = Permalink "blog/page.html" + Template = Some "bork" + IsInPageList = true + Revisions = + [ { AsOf = Noda.epoch + Duration.FromHours 1; Text = Markdown "# Howdy!" } + { AsOf = Noda.epoch; Text = Html "

    howdy

    " } ] + Metadata = [ { Name = "Test"; Value = "me" }; { Name = "Two"; Value = "2" } ] } + +/// A full post used to test various models +let testFullPost = + { Post.Empty with + Id = PostId "a-post" + Status = Published + Title = "A Post" + Permalink = Permalink "1970/01/a-post.html" + PublishedOn = Some (Noda.epoch + Duration.FromDays 7) + UpdatedOn = Noda.epoch + Duration.FromDays 365 + Template = Some "demo" + Text = "

    A post!

    " + CategoryIds = [ CategoryId "cat-a"; CategoryId "cat-b"; CategoryId "cat-n" ] + Tags = [ "demo"; "post" ] + Metadata = [ { Name = "A Meta"; Value = "A Value" } ] + Revisions = + [ { AsOf = Noda.epoch + Duration.FromDays 365; Text = Html "

    A post!

    " } + { AsOf = Noda.epoch + Duration.FromDays 7; Text = Markdown "A post!" } ] + Episode = + Some { Media = "a-post-ep.mp3" + Length = 15555L + Duration = Some (Duration.FromMinutes 15L + Duration.FromSeconds 22L) + MediaType = Some "audio/mpeg3" + ImageUrl = Some "uploads/podcast-cover.jpg" + Subtitle = Some "Narration" + Explicit = Some Clean + Chapters = None + ChapterFile = Some "uploads/1970/01/chapters.txt" + ChapterType = Some "chapters" + ChapterWaypoints = Some true + TranscriptUrl = Some "uploads/1970/01/transcript.txt" + TranscriptType = Some "transcript" + TranscriptLang = Some "EN-us" + TranscriptCaptions = Some true + SeasonNumber = Some 3 + SeasonDescription = Some "Season Three" + EpisodeNumber = Some 322. + EpisodeDescription = Some "Episode 322" } } + +/// Unit tests for the EditCommonModel type +let editCommonModelTests = testList "EditCommonModel" [ + testList "IsNew" [ + test "succeeds for a new page or post" { + Expect.isTrue (EditCommonModel(Id = "new")).IsNew "IsNew should have been set" + } + test "succeeds for an existing page or post" { + Expect.isFalse (EditCommonModel(Id = string (PageId.Create ()))).IsNew "IsNew should not have been set" + } + ] + testList "PopulateFromPage" [ + test "succeeds for empty page" { + let model = EditCommonModel() + model.PopulateFromPage { Page.Empty with Id = PageId "abc" } + Expect.equal model.Id "abc" "PageId not filled properly" + Expect.equal model.Title "" "Title not filled properly" + Expect.equal model.Permalink "" "Permalink not filled properly" + Expect.equal model.Template "" "Template not filled properly" + Expect.equal model.Source "HTML" "Source not filled properly" + Expect.equal model.Text "" "Text not set properly" + Expect.equal model.MetaNames.Length 1 "MetaNames should have one entry" + Expect.equal model.MetaNames[0] "" "Meta name not set properly" + Expect.equal model.MetaValues.Length 1 "MetaValues should have one entry" + Expect.equal model.MetaValues[0] "" "Meta value not set properly" + } + test "succeeds for filled page" { + let model = EditCommonModel() + model.PopulateFromPage testFullPage + Expect.equal model.Id "the-page" "PageId not filled properly" + Expect.equal model.Title "Test Page" "Title not filled properly" + Expect.equal model.Permalink "blog/page.html" "Permalink not filled properly" + Expect.equal model.Template "bork" "Template not filled properly" + Expect.equal model.Source "Markdown" "Source not filled properly" + Expect.equal model.Text "# Howdy!" "Text not filled properly" + Expect.equal model.MetaNames.Length 2 "MetaNames should have two entries" + Expect.equal model.MetaNames[0] "Test" "Meta name 0 not set properly" + Expect.equal model.MetaNames[1] "Two" "Meta name 1 not set properly" + Expect.equal model.MetaValues.Length 2 "MetaValues should have two entries" + Expect.equal model.MetaValues[0] "me" "Meta value 0 not set properly" + Expect.equal model.MetaValues[1] "2" "Meta value 1 not set properly" + } + ] + testList "PopulateFromPost" [ + test "succeeds for empty post" { + let model = EditCommonModel() + model.PopulateFromPost { Post.Empty with Id = PostId "la-la-la" } + Expect.equal model.Id "la-la-la" "PostId not filled properly" + Expect.equal model.Title "" "Title not filled properly" + Expect.equal model.Permalink "" "Permalink not filled properly" + Expect.equal model.Source "HTML" "Source not filled properly" + Expect.equal model.Text "" "Text not filled properly" + Expect.equal model.Template "" "Template not filled properly" + Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" + Expect.equal model.MetaNames[0] "" "Meta name 0 not filled properly" + Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" + Expect.equal model.MetaValues[0] "" "Meta value 0 not filled properly" + } + test "succeeds for full post with external chapters" { + let model = EditCommonModel() + model.PopulateFromPost testFullPost + Expect.equal model.Id "a-post" "PostId not filled properly" + Expect.equal model.Title "A Post" "Title not filled properly" + Expect.equal model.Permalink "1970/01/a-post.html" "Permalink not filled properly" + Expect.equal model.Source "HTML" "Source not filled properly" + Expect.equal model.Text "

    A post!

    " "Text not filled properly" + Expect.equal model.Template "demo" "Template not filled properly" + Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" + Expect.equal model.MetaNames[0] "A Meta" "Meta name 0 not filled properly" + Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" + Expect.equal model.MetaValues[0] "A Value" "Meta value 0 not filled properly" + } + ] +] + /// Unit tests for the EditCustomFeedModel type let editCustomFeedModelTests = testList "EditCustomFeedModel" [ let minimalPodcast = @@ -502,63 +504,26 @@ let editMyInfoModelTests = test "EditMyInfoModel.FromUser succeeds" { Expect.equal model.NewPasswordConfirm "" "NewPasswordConfirm not filled properly" } +/// Unit tests for the EditPageModel type let editPageModelTests = testList "EditPageModel" [ - let fullPage = - { Page.Empty with - Id = PageId "the-page" - Title = "Test Page" - Permalink = Permalink "blog/page.html" - Template = Some "bork" - IsInPageList = true - Revisions = - [ { AsOf = Noda.epoch + Duration.FromHours 1; Text = Markdown "# Howdy!" } - { AsOf = Noda.epoch; Text = Html "

    howdy

    " } ] - Metadata = [ { Name = "Test"; Value = "me" }; { Name = "Two"; Value = "2" } ] } testList "FromPage" [ test "succeeds for empty page" { let model = EditPageModel.FromPage { Page.Empty with Id = PageId "abc" } - Expect.equal model.PageId "abc" "PageId not filled properly" - Expect.equal model.Title "" "Title not filled properly" - Expect.equal model.Permalink "" "Permalink not filled properly" - Expect.equal model.Template "" "Template not filled properly" + Expect.equal model.Id "abc" "Parent fields not filled properly" Expect.isFalse model.IsShownInPageList "IsShownInPageList should not have been set" - Expect.equal model.Source "HTML" "Source not filled properly" - Expect.equal model.Text "" "Text not set properly" - Expect.equal model.MetaNames.Length 1 "MetaNames should have one entry" - Expect.equal model.MetaNames[0] "" "Meta name not set properly" - Expect.equal model.MetaValues.Length 1 "MetaValues should have one entry" - Expect.equal model.MetaValues[0] "" "Meta value not set properly" } test "succeeds for filled page" { - let model = EditPageModel.FromPage fullPage - Expect.equal model.PageId "the-page" "PageId not filled properly" - Expect.equal model.Title "Test Page" "Title not filled properly" - Expect.equal model.Permalink "blog/page.html" "Permalink not filled properly" - Expect.equal model.Template "bork" "Template not filled properly" + let model = EditPageModel.FromPage testFullPage + Expect.equal model.Id "the-page" "Parent fields not filled properly" Expect.isTrue model.IsShownInPageList "IsShownInPageList should have been set" - Expect.equal model.Source "Markdown" "Source not filled properly" - Expect.equal model.Text "# Howdy!" "Text not filled properly" - Expect.equal model.MetaNames.Length 2 "MetaNames should have two entries" - Expect.equal model.MetaNames[0] "Test" "Meta name 0 not set properly" - Expect.equal model.MetaNames[1] "Two" "Meta name 1 not set properly" - Expect.equal model.MetaValues.Length 2 "MetaValues should have two entries" - Expect.equal model.MetaValues[0] "me" "Meta value 0 not set properly" - Expect.equal model.MetaValues[1] "2" "Meta value 1 not set properly" - } - ] - testList "IsNew" [ - test "succeeds for a new page" { - Expect.isTrue - (EditPageModel.FromPage { Page.Empty with Id = PageId "new" }).IsNew "IsNew should have been set" - } - test "succeeds for an existing page" { - Expect.isFalse (EditPageModel.FromPage Page.Empty).IsNew "IsNew should not have been set" } ] testList "UpdatePage" [ test "succeeds with minimal changes" { - let model = { EditPageModel.FromPage fullPage with Title = "Updated Page"; IsShownInPageList = false } - let page = model.UpdatePage fullPage (Noda.epoch + Duration.FromHours 4) + let model = EditPageModel.FromPage testFullPage + model.Title <- "Updated Page" + model.IsShownInPageList <- false + let page = model.UpdatePage testFullPage (Noda.epoch + Duration.FromHours 4) Expect.equal page.Title "Updated Page" "Title not filled properly" Expect.equal page.Permalink (Permalink "blog/page.html") "Permalink not filled properly" Expect.isEmpty page.PriorPermalinks "PriorPermalinks should be empty" @@ -582,18 +547,18 @@ let editPageModelTests = testList "EditPageModel" [ Expect.equal rev2.Text (Html "

    howdy

    ") "Revision 1 text not filled properly" } test "succeeds with all changes" { - let model = - { PageId = "this-page" - Title = "My Updated Page" - Permalink = "blog/updated.html" - Template = "" - IsShownInPageList = false - Source = "HTML" - Text = "

    Howdy, partners!

    " - MetaNames = [| "banana"; "apple"; "grape" |] - MetaValues = [| "monkey"; "zebra"; "ape" |] } + let model = EditPageModel() + model.Id <- "this-page" + model.Title <- "My Updated Page" + model.Permalink <- "blog/updated.html" + model.Template <- "" + model.IsShownInPageList <- false + model.Source <- "HTML" + model.Text <- "

    Howdy, partners!

    " + model.MetaNames <- [| "banana"; "apple"; "grape" |] + model.MetaValues <- [| "monkey"; "zebra"; "ape" |] let now = Noda.epoch + Duration.FromDays 7 - let page = model.UpdatePage fullPage now + let page = model.UpdatePage testFullPage now Expect.equal page.Title "My Updated Page" "Title not filled properly" Expect.equal page.Permalink (Permalink "blog/updated.html") "Permalink not filled properly" Expect.equal page.PriorPermalinks [ Permalink "blog/page.html" ] "PriorPermalinks not filled properly" @@ -621,59 +586,14 @@ let editPageModelTests = testList "EditPageModel" [ /// Unit tests for the EditPostModel type let editPostModelTests = testList "EditPostModel" [ - let fullPost = - { Post.Empty with - Id = PostId "a-post" - Status = Published - Title = "A Post" - Permalink = Permalink "1970/01/a-post.html" - PublishedOn = Some (Noda.epoch + Duration.FromDays 7) - UpdatedOn = Noda.epoch + Duration.FromDays 365 - Template = Some "demo" - Text = "

    A post!

    " - CategoryIds = [ CategoryId "cat-a"; CategoryId "cat-b"; CategoryId "cat-n" ] - Tags = [ "demo"; "post" ] - Metadata = [ { Name = "A Meta"; Value = "A Value" } ] - Revisions = - [ { AsOf = Noda.epoch + Duration.FromDays 365; Text = Html "

    A post!

    " } - { AsOf = Noda.epoch + Duration.FromDays 7; Text = Markdown "A post!" } ] - Episode = - Some { Media = "a-post-ep.mp3" - Length = 15555L - Duration = Some (Duration.FromMinutes 15L + Duration.FromSeconds 22L) - MediaType = Some "audio/mpeg3" - ImageUrl = Some "uploads/podcast-cover.jpg" - Subtitle = Some "Narration" - Explicit = Some Clean - Chapters = None - ChapterFile = Some "uploads/1970/01/chapters.txt" - ChapterType = Some "chapters" - ChapterWaypoints = Some true - TranscriptUrl = Some "uploads/1970/01/transcript.txt" - TranscriptType = Some "transcript" - TranscriptLang = Some "EN-us" - TranscriptCaptions = Some true - SeasonNumber = Some 3 - SeasonDescription = Some "Season Three" - EpisodeNumber = Some 322. - EpisodeDescription = Some "Episode 322" } } testList "FromPost" [ test "succeeds for empty post" { let model = EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "la-la-la" } - Expect.equal model.PostId "la-la-la" "PostId not filled properly" - Expect.equal model.Title "" "Title not filled properly" - Expect.equal model.Permalink "" "Permalink not filled properly" - Expect.equal model.Source "HTML" "Source not filled properly" - Expect.equal model.Text "" "Text not filled properly" + Expect.equal model.Id "la-la-la" "Parent fields not filled properly" Expect.equal model.Tags "" "Tags not filled properly" - Expect.equal model.Template "" "Template not filled properly" Expect.isEmpty model.CategoryIds "CategoryIds not filled properly" Expect.equal model.Status (string Draft) "Status not filled properly" Expect.isFalse model.DoPublish "DoPublish should not have been set" - Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" - Expect.equal model.MetaNames[0] "" "Meta name 0 not filled properly" - Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" - Expect.equal model.MetaValues[0] "" "Meta value 0 not filled properly" Expect.isFalse model.SetPublished "SetPublished should not have been set" Expect.isFalse model.PubOverride.HasValue "PubOverride not filled properly" Expect.isFalse model.SetUpdated "SetUpdated should not have been set" @@ -699,21 +619,12 @@ let editPostModelTests = testList "EditPostModel" [ Expect.equal model.EpisodeDescription "" "EpisodeDescription not filled properly" } test "succeeds for full post with external chapters" { - let model = EditPostModel.FromPost { WebLog.Empty with TimeZone = "Etc/GMT+1" } fullPost - Expect.equal model.PostId "a-post" "PostId not filled properly" - Expect.equal model.Title "A Post" "Title not filled properly" - Expect.equal model.Permalink "1970/01/a-post.html" "Permalink not filled properly" - Expect.equal model.Source "HTML" "Source not filled properly" - Expect.equal model.Text "

    A post!

    " "Text not filled properly" + let model = EditPostModel.FromPost { WebLog.Empty with TimeZone = "Etc/GMT+1" } testFullPost + Expect.equal model.Id "a-post" "Parent fields not filled properly" Expect.equal model.Tags "demo, post" "Tags not filled properly" - Expect.equal model.Template "demo" "Template not filled properly" Expect.equal model.CategoryIds [| "cat-a"; "cat-b"; "cat-n" |] "CategoryIds not filled properly" Expect.equal model.Status (string Published) "Status not filled properly" Expect.isFalse model.DoPublish "DoPublish should not have been set" - Expect.equal model.MetaNames.Length 1 "MetaNames not filled properly" - Expect.equal model.MetaNames[0] "A Meta" "Meta name 0 not filled properly" - Expect.equal model.MetaValues.Length 1 "MetaValues not filled properly" - Expect.equal model.MetaValues[0] "A Value" "Meta value 0 not filled properly" Expect.isFalse model.SetPublished "SetPublished should not have been set" Expect.isTrue model.PubOverride.HasValue "PubOverride should not have been null" Expect.equal @@ -746,63 +657,52 @@ let editPostModelTests = testList "EditPostModel" [ let model = EditPostModel.FromPost { WebLog.Empty with TimeZone = "Etc/GMT+1" } - { fullPost with + { testFullPost with Episode = Some - { fullPost.Episode.Value with + { testFullPost.Episode.Value with Chapters = Some [] ChapterFile = None ChapterType = None } } Expect.equal model.ChapterSource "internal" "ChapterSource not filled properly" } ] - testList "IsNew" [ - test "succeeds for a new post" { - Expect.isTrue - (EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "new" }).IsNew - "IsNew should be set for new post" - } - test "succeeds for a not-new post" { - Expect.isFalse - (EditPostModel.FromPost WebLog.Empty { Post.Empty with Id = PostId "nu" }).IsNew - "IsNew should not be set for not-new post" - } - ] - let updatedModel = - { EditPostModel.FromPost WebLog.Empty fullPost with - Title = "An Updated Post" - Permalink = "1970/01/updated-post.html" - Source = "HTML" - Text = "

    An updated post!

    " - Tags = "Zebras, Aardvarks, , Turkeys" - Template = "updated" - CategoryIds = [| "cat-x"; "cat-y" |] - MetaNames = [| "Zed Meta"; "A Meta" |] - MetaValues = [| "A Value"; "Zed Value" |] - Media = "an-updated-ep.mp3" - Length = 14444L - Duration = "0:14:42" - MediaType = "audio/mp3" - ImageUrl = "updated-cover.png" - Subtitle = "Talking" - Explicit = "no" - ChapterSource = "external" - ChapterFile = "updated-chapters.txt" - ChapterType = "indexes" - TranscriptUrl = "updated-transcript.txt" - TranscriptType = "subtitles" - TranscriptLang = "ES-mx" - SeasonNumber = 4 - SeasonDescription = "Season Fo" - EpisodeNumber = "432.1" - EpisodeDescription = "Four Three Two pt One" } + let updatedModel () = + let model = EditPostModel.FromPost WebLog.Empty testFullPost + model.Title <- "An Updated Post" + model.Permalink <- "1970/01/updated-post.html" + model.Source <- "HTML" + model.Text <- "

    An updated post!

    " + model.Tags <- "Zebras, Aardvarks, , Turkeys" + model.Template <- "updated" + model.CategoryIds <- [| "cat-x"; "cat-y" |] + model.MetaNames <- [| "Zed Meta"; "A Meta" |] + model.MetaValues <- [| "A Value"; "Zed Value" |] + model.Media <- "an-updated-ep.mp3" + model.Length <- 14444L + model.Duration <- "0:14:42" + model.MediaType <- "audio/mp3" + model.ImageUrl <- "updated-cover.png" + model.Subtitle <- "Talking" + model.Explicit <- "no" + model.ChapterSource <- "external" + model.ChapterFile <- "updated-chapters.txt" + model.ChapterType <- "indexes" + model.TranscriptUrl <- "updated-transcript.txt" + model.TranscriptType <- "subtitles" + model.TranscriptLang <- "ES-mx" + model.SeasonNumber <- 4 + model.SeasonDescription <- "Season Fo" + model.EpisodeNumber <- "432.1" + model.EpisodeDescription <- "Four Three Two pt One" + model testList "UpdatePost" [ test "succeeds for a full podcast episode" { - let post = updatedModel.UpdatePost fullPost (Noda.epoch + Duration.FromDays 400) + let post = (updatedModel ()).UpdatePost testFullPost (Noda.epoch + Duration.FromDays 400) Expect.equal post.Title "An Updated Post" "Title not filled properly" Expect.equal post.Permalink (Permalink "1970/01/updated-post.html") "Permalink not filled properly" Expect.equal post.PriorPermalinks [ Permalink "1970/01/a-post.html" ] "PriorPermalinks not filled properly" - Expect.equal post.PublishedOn fullPost.PublishedOn "PublishedOn should not have changed" + Expect.equal post.PublishedOn testFullPost.PublishedOn "PublishedOn should not have changed" Expect.equal post.UpdatedOn (Noda.epoch + Duration.FromDays 400) "UpdatedOn not filled properly" Expect.equal post.Text "

    An updated post!

    " "Text not filled properly" Expect.equal post.Tags [ "aardvarks"; "turkeys"; "zebras" ] "Tags not filled properly" @@ -841,25 +741,24 @@ let editPostModelTests = testList "EditPostModel" [ Expect.equal ep.EpisodeDescription (Some "Four Three Two pt One") "EpisodeDescription not filled properly" } test "succeeds for a minimal podcast episode" { - let minModel = - { updatedModel with - Duration = "" - MediaType = "" - ImageUrl = "" - Subtitle = "" - Explicit = "" - ChapterFile = "" - ChapterType = "" - ContainsWaypoints = false - TranscriptUrl = "" - TranscriptType = "" - TranscriptLang = "" - TranscriptCaptions = false - SeasonNumber = 0 - SeasonDescription = "" - EpisodeNumber = "" - EpisodeDescription = "" } - let post = minModel.UpdatePost fullPost (Noda.epoch + Duration.FromDays 500) + let minModel = updatedModel () + minModel.Duration <- "" + minModel.MediaType <- "" + minModel.ImageUrl <- "" + minModel.Subtitle <- "" + minModel.Explicit <- "" + minModel.ChapterFile <- "" + minModel.ChapterType <- "" + minModel.ContainsWaypoints <- false + minModel.TranscriptUrl <- "" + minModel.TranscriptType <- "" + minModel.TranscriptLang <- "" + minModel.TranscriptCaptions <- false + minModel.SeasonNumber <- 0 + minModel.SeasonDescription <- "" + minModel.EpisodeNumber <- "" + minModel.EpisodeDescription <- "" + let post = minModel.UpdatePost testFullPost (Noda.epoch + Duration.FromDays 500) Expect.isSome post.Episode "There should have been a podcast episode" let ep = post.Episode.Value Expect.equal ep.Media "an-updated-ep.mp3" "Media not filled properly" @@ -882,12 +781,11 @@ let editPostModelTests = testList "EditPostModel" [ Expect.isNone ep.EpisodeDescription "EpisodeDescription not filled properly" } test "succeeds for a podcast episode with internal chapters" { - let minModel = - { updatedModel with - ChapterSource = "internal" - ChapterFile = "" - ChapterType = "" } - let post = minModel.UpdatePost fullPost (Noda.epoch + Duration.FromDays 500) + let minModel = updatedModel () + minModel.ChapterSource <- "internal" + minModel.ChapterFile <- "" + minModel.ChapterType <- "" + let post = minModel.UpdatePost testFullPost (Noda.epoch + Duration.FromDays 500) Expect.isSome post.Episode "There should have been a podcast episode" let ep = post.Episode.Value Expect.equal ep.Chapters (Some []) "Chapters not filled properly" @@ -895,10 +793,11 @@ let editPostModelTests = testList "EditPostModel" [ Expect.isNone ep.ChapterType "ChapterType not filled properly" } test "succeeds for a podcast episode with no chapters" { - let minModel = { updatedModel with ChapterSource = "none" } + let minModel = updatedModel () + minModel.ChapterSource <- "none" let post = minModel.UpdatePost - { fullPost with Episode = Some { fullPost.Episode.Value with Chapters = Some [] } } + { testFullPost with Episode = Some { testFullPost.Episode.Value with Chapters = Some [] } } (Noda.epoch + Duration.FromDays 500) Expect.isSome post.Episode "There should have been a podcast episode" let ep = post.Episode.Value @@ -908,14 +807,17 @@ let editPostModelTests = testList "EditPostModel" [ Expect.isNone ep.ChapterWaypoints "ChapterWaypoints not filled properly" } test "succeeds for no podcast episode and no template" { - let post = { updatedModel with IsEpisode = false; Template = "" }.UpdatePost fullPost Noda.epoch + let model = updatedModel () + model.IsEpisode <- false + model.Template <- "" + let post = model.UpdatePost testFullPost Noda.epoch Expect.isNone post.Template "Template not filled properly" Expect.isNone post.Episode "Episode not filled properly" } test "succeeds when publishing a draft" { - let post = - { updatedModel with DoPublish = true }.UpdatePost - { fullPost with Status = Draft } (Noda.epoch + Duration.FromDays 375) + let model = updatedModel () + model.DoPublish <- true + let post = model.UpdatePost { testFullPost with Status = Draft } (Noda.epoch + Duration.FromDays 375) Expect.equal post.Status Published "Status not set properly" Expect.equal post.PublishedOn (Some (Noda.epoch + Duration.FromDays 375)) "PublishedOn not set properly" } @@ -1322,13 +1224,11 @@ let userMessageTests = testList "UserMessage" [ /// All tests in the Domain.ViewModels file let all = testList "ViewModels" [ addBaseToRelativeUrlsTests - displayChapterTests - displayCustomFeedTests displayPageTests displayThemeTests displayUploadTests - displayUserTests editCategoryModelTests + editCommonModelTests editCustomFeedModelTests editMyInfoModelTests editPageModelTests diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index 872486b..e68f448 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -225,12 +225,11 @@ let register () = Template.RegisterTag "user_links" [ // Domain types - typeof; typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof; typeof; typeof + typeof; typeof // View models - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof; typeof + typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index fefd983..6bca839 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -455,11 +455,9 @@ module WebLog = |> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ] let! themes = data.Theme.All() let uploads = [ Database; Disk ] - let feeds = ctx.WebLog.Rss.CustomFeeds |> List.map (DisplayCustomFeed.FromFeed (CategoryCache.get ctx)) return! Views.WebLog.webLogSettings (SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss) - feeds |> adminPage "Web Log Settings" true next ctx } diff --git a/src/MyWebLog/Views/WebLog.fs b/src/MyWebLog/Views/WebLog.fs index 2aeff71..a0f2cb6 100644 --- a/src/MyWebLog/Views/WebLog.fs +++ b/src/MyWebLog/Views/WebLog.fs @@ -699,7 +699,40 @@ let uploadNew app = [ /// Web log settings page let webLogSettings (model: SettingsModel) (themes: Theme list) (pages: Page list) (uploads: UploadDestination list) - (rss: EditRssModel) (feeds: DisplayCustomFeed list) app = [ + (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 "   "; 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" ] [ @@ -824,7 +857,7 @@ let webLogSettings a [ _class "btn btn-sm btn-secondary"; _href (relUrl app "admin/settings/rss/new/edit") ] [ raw "Add a New Custom Feed" ] - if feeds.Length = 0 then + 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" ] [ @@ -834,31 +867,9 @@ let webLogSettings 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" ] + div [ _class "col-12 col-md-6 d-none d-md-inline-block" ] [ raw "Relative Path" ] ] - for feed in feeds do - div [ _class "row mwl-table-detail" ] [ - div [ _class "col-12 col-md-6" ] [ - txt feed.Source - if feed.IsPodcast then - raw "   "; span [ _class "badge bg-primary" ] [ raw "PODCAST" ] - br [] - small [] [ - let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}" - a [ _href (relUrl app 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 feed.Path ] - span [ _class "d-none d-md-inline" ] [ txt feed.Path ] - ] - ] + yield! app.WebLog.Rss.CustomFeeds |> List.map feedDetail ] ] ] -- 2.45.1 From 4301788344e6caa4afcc8767fb1409de677a31d4 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Mar 2024 14:35:57 -0400 Subject: [PATCH 105/123] Bug fixes with new admin forms --- src/MyWebLog/Handlers/Page.fs | 4 ++-- src/MyWebLog/Handlers/Post.fs | 7 ++++--- src/MyWebLog/Views/Helpers.fs | 8 ++++---- src/MyWebLog/Views/Post.fs | 13 ++++++++----- src/MyWebLog/Views/WebLog.fs | 8 +++++--- src/admin-theme/wwwroot/admin.js | 4 +--- 6 files changed, 24 insertions(+), 20 deletions(-) diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 2d23bc1..f616375 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -46,7 +46,7 @@ let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta 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 + return! all 1 next ctx } // GET /admin/page/{id}/permalinks @@ -96,7 +96,7 @@ let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> | 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 + return! editRevisions pgId next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 216cb8d..79bd624 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -273,6 +273,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let! templates = templatesForTheme ctx "post" let model = EditPostModel.FromPost ctx.WebLog post let ratings = [ + { Name = ""; Value = "– Default –" } { Name = string Yes; Value = "Yes" } { Name = string No; Value = "No" } { Name = string Clean; Value = "Clean" } @@ -338,7 +339,7 @@ let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx | 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 + return! editRevisions postId next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -427,7 +428,7 @@ let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex // POST /admin/post/{id}/chapter/{idx} let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let data = ctx.Data - match! data.Post.FindById (PostId postId) ctx.WebLog.Id with + match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with | Some post when Option.isSome post.Episode && Option.isSome post.Episode.Value.Chapters @@ -447,7 +448,7 @@ let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } return! Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost) - |> adminPage "Manage Chapters" true next ctx + |> adminBarePage "Manage Chapters" true next ctx with | ex -> return! Error.server ex.Message next ctx else return! Error.notFound next ctx diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index cf4d716..8907e37 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -132,8 +132,8 @@ 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: int) extra = - inputField "number" attrs name labelText (string value) extra +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 = @@ -450,7 +450,7 @@ let managePermalinks (model: ManagePermalinksModel) app = [ div [ _id "permalinks"; _class "container g-0" ] [ yield! Array.mapi linkDetail model.Prior script [] [ - raw """document.addEventListener(\"DOMContentLoaded\", """ + raw """document.addEventListener("DOMContentLoaded", """ raw $"() => Admin.setPermalinkIndex({model.Prior.Length}))" ] ] @@ -514,7 +514,7 @@ let manageRevisions (model: ManageRevisionsModel) app = [ 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/purge" + 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" ] diff --git a/src/MyWebLog/Views/Post.fs b/src/MyWebLog/Views/Post.fs index 5e568fe..81b0719 100644 --- a/src/MyWebLog/Views/Post.fs +++ b/src/MyWebLog/Views/Post.fs @@ -325,7 +325,7 @@ let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [ div [ _class "row pb-3" ] [ div [ _class "col" ] [ numberField [ _required ] (nameof model.Length) "Media Length (bytes)" - 0 (* TODO: string model.Length *) [ + (string model.Length) [ div [ _class "form-text" ] [ raw "TODO: derive from above file name" ] ] ] @@ -409,14 +409,16 @@ let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [ ] div [ _class "row" ] [ div [ _class "col-12 col-md-8 pb-3" ] [ - textField [] (nameof model.TranscriptUrl) "Transcript URL" model.TranscriptUrl [ + 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 [] (nameof model.TranscriptType) "Transcript MIME Type" + textField [ if model.TranscriptUrl <> "" then _required ] + (nameof model.TranscriptType) "Transcript MIME Type" model.TranscriptType [ div [ _class "form-text" ] [ raw "Required if transcript URL provided" ] ] @@ -436,7 +438,8 @@ let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [ ] div [ _class "row pb-3" ] [ div [ _class "col col-md-4" ] [ - numberField [] (nameof model.SeasonNumber) "Season Number" model.SeasonNumber [ + numberField [] (nameof model.SeasonNumber) "Season Number" + (string model.SeasonNumber) [ div [ _class "form-text" ] [ raw "Optional" ] ] ] @@ -450,7 +453,7 @@ let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [ div [ _class "row pb-3" ] [ div [ _class "col col-md-4" ] [ numberField [ _step "0.01" ] (nameof model.EpisodeNumber) "Episode Number" - 0 (* TODO: model.EpisodeNumber *) [ + model.EpisodeNumber [ div [ _class "form-text" ] [ raw "Optional; up to 2 decimal points" ] ] ] diff --git a/src/MyWebLog/Views/WebLog.fs b/src/MyWebLog/Views/WebLog.fs index a0f2cb6..98d64ca 100644 --- a/src/MyWebLog/Views/WebLog.fs +++ b/src/MyWebLog/Views/WebLog.fs @@ -281,7 +281,8 @@ let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: Met 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" model.ItemsInFeed [] + numberField [ _required ] (nameof model.ItemsInFeed) "# Episodes" + (string model.ItemsInFeed) [] ] ] div [ _class "row" ] [ @@ -775,7 +776,7 @@ let webLogSettings ] div [ _class "col-12 col-md-4 col-xl-2 pb-3" ] [ numberField [ _required; _min "0"; _max "50" ] (nameof model.PostsPerPage) "Posts per Page" - model.PostsPerPage [] + (string model.PostsPerPage) [] ] ] div [ _class "row" ] [ @@ -827,7 +828,8 @@ let webLogSettings ] ] 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" rss.ItemsInFeed [ + numberField [ _required; _min "0" ] (nameof rss.ItemsInFeed) "Items in Feed" + (string rss.ItemsInFeed) [ span [ _class "form-text" ] [ raw "Set to “0” to use “Posts per Page” setting (" raw (string app.WebLog.PostsPerPage); raw ")" diff --git a/src/admin-theme/wwwroot/admin.js b/src/admin-theme/wwwroot/admin.js index 989065c..31baf7c 100644 --- a/src/admin-theme/wwwroot/admin.js +++ b/src/admin-theme/wwwroot/admin.js @@ -375,9 +375,7 @@ this.Admin = { */ showPreRenderedMessages() { [...document.querySelectorAll(".toast")].forEach(el => { - if (el.getAttribute("data-mwl-shown") === "true" && el.className.indexOf("hide") >= 0) { - document.removeChild(el) - } else { + if (el.getAttribute("data-mwl-shown") !== "true") { const toast = new bootstrap.Toast(el, el.getAttribute("data-bs-autohide") === "false" ? { autohide: false } : { delay: 6000, autohide: true }) -- 2.45.1 From 31d49d4b1a08566c0c5b85cf79799401bd7a471f Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 16 Mar 2024 22:00:42 -0400 Subject: [PATCH 106/123] Fix "add category" button (#40) --- src/MyWebLog/Handlers/Admin.fs | 2 +- src/MyWebLog/Views/WebLog.fs | 18 +++++++++++------- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 6bca839..8d99828 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -96,7 +96,7 @@ module Category = // GET /admin/categories let all : HttpHandler = fun next ctx -> - adminPage "Categories" true next ctx Views.WebLog.categoryList + adminPage "Categories" true next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new")) // GET /admin/category/{id}/edit let edit catId : HttpHandler = fun next ctx -> task { diff --git a/src/MyWebLog/Views/WebLog.fs b/src/MyWebLog/Views/WebLog.fs index 98d64ca..26bcc9a 100644 --- a/src/MyWebLog/Views/WebLog.fs +++ b/src/MyWebLog/Views/WebLog.fs @@ -51,7 +51,7 @@ let categoryEdit (model: EditCategoryModel) app = /// Category list page -let categoryList app = [ +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) = @@ -84,6 +84,8 @@ let categoryList app = [ 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 [] [ @@ -92,11 +94,13 @@ let categoryList app = [ ] div [ _id "catList"; _class "container" ] [ if app.Categories.Length = 0 then - div [ _id "cat_new" ] [ - p [ _class "text-muted fst-italic text-center" ] [ - raw "This web log has no categories defined" + 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" ] [ @@ -108,7 +112,7 @@ let categoryList app = [ // don't think we need this... // _hxTarget "#catList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" antiCsrf app - div [ _class "row mwl-table-detail"; _id "cat_new" ] [] + div [ _class "row mwl-table-detail"; _id "cat_new" ] [ if includeNew then loadNew ] yield! app.Categories |> Seq.ofArray |> Seq.map categoryDetail |> List.ofSeq ] ] @@ -173,7 +177,7 @@ let dashboard (model: DashboardModel) app = [ a [ _href (relUrl app "admin/categories"); _class "btn btn-secondary me-2" ] [ raw "View All" ] - a [ _href (relUrl app "admin/category/new/edit"); _class "btn btn-secondary" ] [ + a [ _href (relUrl app "admin/categories?new"); _class "btn btn-secondary" ] [ raw "Add a New Category" ] ] -- 2.45.1 From f181f83aa55491272bc5940b84b1adc75b10d77d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 17 Mar 2024 18:30:42 -0400 Subject: [PATCH 107/123] Misc admin theme tweaks --- src/MyWebLog/Handlers/Admin.fs | 5 ++++- src/MyWebLog/Handlers/Upload.fs | 11 +++-------- src/MyWebLog/Views/WebLog.fs | 29 ++++++++++++++++------------- 3 files changed, 23 insertions(+), 22 deletions(-) diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 8d99828..a482305 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -3,6 +3,7 @@ module MyWebLog.Handlers.Admin open System.Threading.Tasks open Giraffe +open Giraffe.Htmx open MyWebLog open MyWebLog.ViewModels open NodaTime @@ -96,7 +97,9 @@ module Category = // GET /admin/categories let all : HttpHandler = fun next ctx -> - adminPage "Categories" true next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new")) + 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 edit catId : HttpHandler = fun next ctx -> task { diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index a52b037..c992eda 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -127,11 +127,6 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> adminPage "Upload a File" true next ctx Views.WebLog.uploadNew - -/// Redirect to the upload list -let showUploads : HttpHandler = - redirectToGet "admin/uploads" - // POST /admin/upload/save let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then @@ -162,7 +157,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { do! upload.CopyToAsync stream do! addMessage ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" } - return! showUploads next ctx + return! redirectToGet "admin/uploads" next ctx else return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx } @@ -172,7 +167,7 @@ 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 + return! list next ctx | Error _ -> return! Error.notFound next ctx } @@ -195,6 +190,6 @@ let deleteFromDisk urlParts : HttpHandler = fun next ctx -> task { File.Delete path removeEmptyDirectories ctx.WebLog filePath do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" } - return! showUploads next ctx + return! list next ctx else return! Error.notFound next ctx } diff --git a/src/MyWebLog/Views/WebLog.fs b/src/MyWebLog/Views/WebLog.fs index 26bcc9a..793826f 100644 --- a/src/MyWebLog/Views/WebLog.fs +++ b/src/MyWebLog/Views/WebLog.fs @@ -29,7 +29,7 @@ let categoryEdit (model: EditCategoryModel) app = |> Seq.map (fun c -> let parents = c.ParentNames - |> Array.map (fun it -> $"{it}   » ") + |> Array.map (fun it -> $"{it} ⟩ ") |> String.concat "" { Name = c.Id; Value = $"{parents}{c.Name}" }) |> Seq.append [ { Name = ""; Value = "– None –" } ] @@ -74,7 +74,7 @@ let categoryList includeNew app = [ _hxSwap $"{HxSwap.InnerHtml} show:#cat_{cat.Id}:top" ] [ raw "Edit" ]; actionSpacer - a [ _href catUrl; _hxDelete catUrl; _class "text-danger" + 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" ] @@ -109,8 +109,6 @@ let categoryList includeNew app = [ ] ] form [ _method "post"; _class "container" ] [ - // don't think we need this... - // _hxTarget "#catList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" 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 @@ -632,7 +630,10 @@ let uploadList (model: DisplayUpload seq) app = [ ] div [ _class "col-3" ] [ raw upload.Path ] div [ _class "col-3" ] [ - raw (match upload.UpdatedOn with Some updated -> updated.ToString "yyyy-MM-dd/HH:mm" | None -> "--") + match upload.UpdatedOn with + | Some updated -> updated.ToString("yyyy-MM-dd/h:mmtt").ToLowerInvariant() + | None -> "--" + |> raw ] ] @@ -680,14 +681,16 @@ let uploadNew app = [ ] ] div [ _class "col-12 col-md-6 pb-3 d-flex align-self-center justify-content-around" ] [ - 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 "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" ] + ] ] ] ] -- 2.45.1 From ac332a67977091c777fb7f00f51be0f485fd27b3 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 19 Mar 2024 22:43:50 -0400 Subject: [PATCH 108/123] Fix Docker builds (#38) --- src/Dockerfile | 1 + src/sqlite.Dockerfile | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Dockerfile b/src/Dockerfile index 48fd7e8..cb3fbd5 100644 --- a/src/Dockerfile +++ b/src/Dockerfile @@ -5,6 +5,7 @@ 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 . ./ diff --git a/src/sqlite.Dockerfile b/src/sqlite.Dockerfile index 68b895f..fe57963 100644 --- a/src/sqlite.Dockerfile +++ b/src/sqlite.Dockerfile @@ -5,6 +5,7 @@ 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 . ./ -- 2.45.1 From dce80fdddcf55c5ccc313b43cf7b4f99b701ceb9 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 22 Mar 2024 21:32:35 -0400 Subject: [PATCH 109/123] Fix theme zipping in Docker (#38) - Default to port 80 --- src/.dockerignore | 2 ++ src/Dockerfile | 11 ++++++----- src/MyWebLog/appsettings.json | 7 +++++++ src/sqlite.Dockerfile | 11 ++++++----- 4 files changed, 21 insertions(+), 10 deletions(-) diff --git a/src/.dockerignore b/src/.dockerignore index f181d71..147d38c 100644 --- a/src/.dockerignore +++ b/src/.dockerignore @@ -1,2 +1,4 @@ **/bin **/obj +**/*.db +**/appsettings.*.json diff --git a/src/Dockerfile b/src/Dockerfile index cb3fbd5..89387d5 100644 --- a/src/Dockerfile +++ b/src/Dockerfile @@ -14,11 +14,12 @@ RUN dotnet publish -f net8.0 -c Release -r linux-x64 --no-self-contained -p:Publ FROM alpine AS theme RUN apk add --no-cache zip -WORKDIR /themes -COPY ./default-theme ./default-theme/ -RUN zip default-theme.zip ./default-theme/* -COPY ./admin-theme ./admin-theme/ -RUN zip admin-theme.zip ./admin-theme/* +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 diff --git a/src/MyWebLog/appsettings.json b/src/MyWebLog/appsettings.json index 102b5a3..d4c8a33 100644 --- a/src/MyWebLog/appsettings.json +++ b/src/MyWebLog/appsettings.json @@ -4,5 +4,12 @@ "LogLevel": { "MyWebLog.Handlers": "Information" } + }, + "Kestrel": { + "Endpoints": { + "Http": { + "Url": "http://0.0.0.0:80" + } + } } } diff --git a/src/sqlite.Dockerfile b/src/sqlite.Dockerfile index fe57963..35929b7 100644 --- a/src/sqlite.Dockerfile +++ b/src/sqlite.Dockerfile @@ -14,11 +14,12 @@ RUN dotnet publish -f net8.0 -c Release -r linux-x64 FROM alpine AS theme RUN apk add --no-cache zip -WORKDIR /themes -COPY ./default-theme ./default-theme/ -RUN zip default-theme.zip ./default-theme/* -COPY ./admin-theme ./admin-theme/ -RUN zip admin-theme.zip ./admin-theme/* +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 as final WORKDIR /app -- 2.45.1 From c20628bb9c0765c66f4dedaa8657cedd601b7245 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 16:46:36 -0400 Subject: [PATCH 110/123] Update deps before release --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 5 +++-- src/MyWebLog.Domain/MyWebLog.Domain.fsproj | 7 ++++--- src/MyWebLog.Tests/MyWebLog.Tests.fsproj | 3 ++- src/MyWebLog/MyWebLog.fsproj | 11 ++++++----- src/MyWebLog/Program.fs | 2 +- 5 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 804465b..a3d9a77 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -7,14 +7,15 @@ - + - + + diff --git a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj index d86aa8a..fa34b80 100644 --- a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj +++ b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj @@ -7,10 +7,11 @@ - - + + - + + diff --git a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj index 35b206e..353d71d 100644 --- a/src/MyWebLog.Tests/MyWebLog.Tests.fsproj +++ b/src/MyWebLog.Tests/MyWebLog.Tests.fsproj @@ -26,8 +26,9 @@ - + + diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 105c91b..227afcb 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -31,12 +31,13 @@ - - - - + + + + - + + diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 293fb17..32abcdc 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -131,7 +131,7 @@ open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.HttpOverrides open Microsoft.Extensions.Caching.Distributed -open NeoSmart.Caching.Sqlite +open NeoSmart.Caching.Sqlite.AspNetCore open RethinkDB.DistributedCache [] -- 2.45.1 From 895b2a72e737b57bf83a290749d4b401050a0fdf Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 17:22:55 -0400 Subject: [PATCH 111/123] Update build files --- build.fs | 2 +- build.fsproj | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/build.fs b/build.fs index e841ab6..9e17e7f 100644 --- a/build.fs +++ b/build.fs @@ -33,7 +33,7 @@ let zipTheme (name : string) (_ : TargetParameter) = |> Zip.zipSpec $"{releasePath}/{name}-theme.zip" /// Frameworks supported by this build -let frameworks = [ "net6.0"; "net7.0" ] +let frameworks = [ "net6.0"; "net7.0"; "net8.0" ] /// Publish the project for the given runtime ID let publishFor rid (_ : TargetParameter) = diff --git a/build.fsproj b/build.fsproj index 449dd30..5821d28 100644 --- a/build.fsproj +++ b/build.fsproj @@ -2,7 +2,7 @@ Exe - net7.0 + net8.0 @@ -10,11 +10,11 @@ - - - - - + + + + + -- 2.45.1 From 2fe104f0c19bf449c6d5b6da8e9ccdfec777ad63 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 18:50:33 -0400 Subject: [PATCH 112/123] Add GitHub Actions YAML --- .github/workflows/ci.yml | 52 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 .github/workflows/ci.yml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..e42df14 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,52 @@ +name: Continuous Integration +on: + push: + branches: [ "main" ] + pull_request: + branches: [ "main" ] + workflow_dispatch: +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 + - 29015:29015 + + 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: dotnet run --project src/MyWebLog.Tests/MyWebLog.Tests.fsproj -f net${{ matrix.dotnet-version }} + \ No newline at end of file -- 2.45.1 From add6a8086b1702829171946eb08d2f67b4dec165 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 19:01:35 -0400 Subject: [PATCH 113/123] Add Rethink URI, run tests after cd --- .github/workflows/ci.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e42df14..8714119 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -5,6 +5,8 @@ on: pull_request: branches: [ "main" ] workflow_dispatch: +env: + MWL_TEST_RETHINK_URI: rethinkdb://localhost/mwl_test jobs: build_and_test: name: Build / Test @@ -48,5 +50,5 @@ jobs: - name: Build (${{ matrix.dotnet-version }}) run: dotnet build src/MyWebLog.sln -f net${{ matrix.dotnet-version }} - name: Test (${{ matrix.dotnet-version }}) - run: dotnet run --project src/MyWebLog.Tests/MyWebLog.Tests.fsproj -f net${{ matrix.dotnet-version }} + run: cd src/MyWebLog.Tests; dotnet run -f net${{ matrix.dotnet-version }} \ No newline at end of file -- 2.45.1 From 5c7e897532f6c8679c5a4b2f3a7cbb01e8a284ac Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 19:17:30 -0400 Subject: [PATCH 114/123] Enable .NET 7 --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8714119..557e284 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -17,7 +17,7 @@ jobs: matrix: dotnet-version: - "6.0" -# - "7.0" + - "7.0" # - "8.0" services: -- 2.45.1 From eaa1824ec314f3be5b4aaf0e768f0cf228de8307 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 19:20:31 -0400 Subject: [PATCH 115/123] Enable .NET 8 --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 557e284..70d4906 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -18,7 +18,7 @@ jobs: dotnet-version: - "6.0" - "7.0" -# - "8.0" + - "8.0" services: postgres: -- 2.45.1 From ad49c9536b8d09eb3837040e10918eec1a8effb0 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 19:36:22 -0400 Subject: [PATCH 116/123] Add release packaging --- .github/workflows/ci.yml | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 70d4906..494a1fa 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -10,7 +10,6 @@ env: jobs: build_and_test: name: Build / Test - runs-on: ubuntu-latest strategy: @@ -51,4 +50,25 @@ jobs: 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 }} - \ No newline at end of file + + publish: + name: Publish .zip / .bz2 Packages + runs-on: ubuntu-latest + needs: build_and_test + + 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: Create Release Packages + run: dotnet run build.fsproj + - name: Upload Artifacts + uses: actions/upload-artifact@v4 + with: + name: release-packages + path: | + release/*x64.zip + release/*.bz2 -- 2.45.1 From 5ba05bdb919dbda4829a0eee7eb6b090d4dacb81 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 19:39:28 -0400 Subject: [PATCH 117/123] Add CI flag to build --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 494a1fa..7715e21 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -64,7 +64,7 @@ jobs: with: dotnet-version: 8.x - name: Create Release Packages - run: dotnet run build.fsproj + run: dotnet run build.fsproj CI - name: Upload Artifacts uses: actions/upload-artifact@v4 with: -- 2.45.1 From aa2707d8a57d248249fed5375b18c34180d0dcbb Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 20:32:07 -0400 Subject: [PATCH 118/123] Use matrix for publish job --- .github/workflows/ci.yml | 58 ++++++++++++++++++++++++++++------------ 1 file changed, 41 insertions(+), 17 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7715e21..84ab515 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -52,23 +52,47 @@ jobs: run: cd src/MyWebLog.Tests; dotnet run -f net${{ matrix.dotnet-version }} publish: - name: Publish .zip / .bz2 Packages + 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: Create Release Packages - run: dotnet run build.fsproj CI - - name: Upload Artifacts - uses: actions/upload-artifact@v4 - with: - name: release-packages - path: | - release/*x64.zip - release/*.bz2 + - 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: release-packages + path: | + *x64.zip + *.bz2 -- 2.45.1 From c9a097a9ea78ad63ec85643eafab7dd53f0625df Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 20:35:28 -0400 Subject: [PATCH 119/123] Fix indentation --- .github/workflows/ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 84ab515..84bc0d5 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -93,6 +93,6 @@ jobs: uses: actions/upload-artifact@v4 with: name: release-packages - path: | - *x64.zip - *.bz2 + path: | + *x64.zip + *.bz2 -- 2.45.1 From d28b18a8d2da0caecf305cad27d9879a78b6b962 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 20:41:59 -0400 Subject: [PATCH 120/123] Remove name from artifact upload --- .github/workflows/ci.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 84bc0d5..cc2ddc9 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -92,7 +92,6 @@ jobs: - name: Upload Artifacts uses: actions/upload-artifact@v4 with: - name: release-packages path: | *x64.zip *.bz2 -- 2.45.1 From 5fc3d11454d7cf0c491011fdf7502cd68efac837 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 20:46:47 -0400 Subject: [PATCH 121/123] Include matrix vars in artifact name --- .github/workflows/ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index cc2ddc9..a40ae15 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -92,6 +92,7 @@ jobs: - name: Upload Artifacts uses: actions/upload-artifact@v4 with: + name: package-${{ matrix.ver }}-${{ matrix.os }} path: | *x64.zip *.bz2 -- 2.45.1 From 2439d017efaee2ae3a3a3ea8d71c1402f9272529 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 23 Mar 2024 21:06:49 -0400 Subject: [PATCH 122/123] Fix indents in CI YAML --- .github/workflows/ci.yml | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a40ae15..92a79d7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -1,9 +1,11 @@ name: Continuous Integration on: push: - branches: [ "main" ] + branches: + - main pull_request: - branches: [ "main" ] + branches: + - main workflow_dispatch: env: MWL_TEST_RETHINK_URI: rethinkdb://localhost/mwl_test @@ -15,9 +17,9 @@ jobs: strategy: matrix: dotnet-version: - - "6.0" - - "7.0" - - "8.0" + - "6.0" + - "7.0" + - "8.0" services: postgres: @@ -34,22 +36,21 @@ jobs: rethink: image: rethinkdb:latest ports: - - 28015:28015 - - 29015:29015 + - 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 }} + - 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 -- 2.45.1 From d8024ac6f452ddd5091f7170b554799975923962 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 25 Mar 2024 22:00:04 -0400 Subject: [PATCH 123/123] Add chapter ref to feed (#6) --- src/MyWebLog/Handlers/Feed.fs | 25 ++++++++++++++++--------- src/MyWebLog/Handlers/Helpers.fs | 3 +++ src/MyWebLog/Handlers/Post.fs | 2 +- 3 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 8c55dbd..25f055f 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -163,17 +163,24 @@ let private addEpisode (webLog: WebLog) (podcast: PodcastOptions) (episode: Epis episode.Subtitle |> Option.iter (fun it -> item.ElementExtensions.Add("subtitle", Namespace.iTunes, it)) 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 typ = - match episode.ChapterType with - | Some mime -> Some mime - | None when chapters.EndsWith ".json" -> Some "application/json+chapters" - | None -> None + 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 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 -> () diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 13a0501..1a26bea 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -268,6 +268,9 @@ let redirectToGet url : HttpHandler = fun _ ctx -> task { return! redirectTo false (ctx.WebLog.RelativeUrl(Permalink url)) earlyReturn ctx } +/// The MIME type for podcast episode JSON chapters +let JSON_CHAPTERS = "application/json+chapters" + /// Handlers for error conditions module Error = diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 79bd624..b1ae54a 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -238,7 +238,7 @@ let chapters (post: Post) : HttpHandler = fun next ctx -> jsonFile["fileName"] <- absoluteUrl ep.Media ctx if defaultArg ep.ChapterWaypoints false then jsonFile["waypoints"] <- true jsonFile["chapters"] <- chapterData - json jsonFile next ctx + (setContentType JSON_CHAPTERS >=> json jsonFile) next ctx | None -> match ep.ChapterFile with | Some file -> redirectTo true file next ctx -- 2.45.1