From fcd02ecbec403e2f99619146f6c2b5aa61ac984c Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 5 Jul 2026 21:28:58 -0400 Subject: [PATCH] Implement htmax as auto-htmx selection (#59) - Move program support items to MyWebLog namespace - Fix parameter ordering in some tests --- src/MyWebLog.Data/RethinkDbData.fs | 4 +- src/MyWebLog.Domain/SupportTypes.fs | 16 +- src/MyWebLog.Tests/Data/ConvertersTests.fs | 16 ++ src/MyWebLog.Tests/Data/WebLogDataTests.fs | 10 +- .../Domain/SupportTypesTests.fs | 51 +++++-- src/MyWebLog.Tests/Domain/ViewModelsTests.fs | 8 +- src/MyWebLog.Tests/root-weblog.json | 2 +- src/MyWebLog/Handlers/Admin.fs | 5 + src/MyWebLog/MyWebLog.fsproj | 1 + src/MyWebLog/Program.fs | 137 +++--------------- src/MyWebLog/ProgramSupport.fs | 109 ++++++++++++++ src/MyWebLog/Views/WebLog.fs | 7 +- 12 files changed, 213 insertions(+), 153 deletions(-) create mode 100644 src/MyWebLog/ProgramSupport.fs diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 1a557cc..c3f3423 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -267,13 +267,13 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger obj ] write; withRetryOnce; ignoreResult conn } do! rethink { withTable Table.WebLog filter (nameof WebLog.Empty.AutoHtmx) false - update [ nameof WebLog.Empty.AutoHtmx, "No" ] + update [ nameof WebLog.Empty.AutoHtmx, "No" :> obj ] write; withRetryOnce; ignoreResult conn } Utils.Migration.logStep log "v2.2 to v3" "Setting database version to v3" diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 79c24cc..7b78260 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -105,17 +105,17 @@ type AccessLevel = AccessLevel.Weights[needed] <= AccessLevel.Weights[this] -/// How the htmx library will be auto-injected in a web log's theme pages +/// How the htmx library will be auto-injected in a web log's templates [] type AutoHtmxType = - - /// Do not auto-inject htmx into the web log's theme pages + + /// Do not auto-inject htmx into the web log's templates | NoAutoHtmx - - /// Inject the standard htmx library into the web log's theme pages + + /// Inject the standard htmx library into the web log's templates | AutoHtmx - - /// Inject the htmax library bundle into the web log's theme pages + + /// Inject the htmax library bundle into the web log's templates | AutoHtmax /// Parse an auto-htmx type from its string representation @@ -628,7 +628,7 @@ type OpenGraphType = string VideoOther, "Video: Other" string VideoTvShow, "Video: TV Show" string Website, nameof Website ] - + override this.ToString() = match this with | Article -> "article" diff --git a/src/MyWebLog.Tests/Data/ConvertersTests.fs b/src/MyWebLog.Tests/Data/ConvertersTests.fs index 215f4ff..dd69c98 100644 --- a/src/MyWebLog.Tests/Data/ConvertersTests.fs +++ b/src/MyWebLog.Tests/Data/ConvertersTests.fs @@ -6,6 +6,20 @@ open MyWebLog open MyWebLog.Converters.Json open Newtonsoft.Json +/// Unit tests for the AutoHtmxTypeConverter type +let autoHtmxTypeConverterTests = testList "AutoHtmxTypeConverter" [ + let opts = JsonSerializerSettings() + opts.Converters.Add(AutoHtmxTypeConverter()) + test "succeeds when serializing" { + let after = JsonConvert.SerializeObject(AutoHtmax, opts) + Expect.equal after "\"Max\"" "Auto htmx type serialized incorrectly" + } + test "succeeds when deserializing" { + let after = JsonConvert.DeserializeObject("\"Yes\"", opts) + Expect.equal after AutoHtmx "Auto htmx type not serialized incorrectly" + } +] + /// Unit tests for the CategoryIdConverter type let categoryIdConverterTests = testList "CategoryIdConverter" [ let opts = JsonSerializerSettings() @@ -264,6 +278,7 @@ open NodaTime.Serialization.JsonNet 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) "Auto htmx type converter not found" 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" @@ -290,6 +305,7 @@ let configureTests = test "Json.configure succeeds" { /// All tests for the Data.Converters file let all = testList "Converters" [ + autoHtmxTypeConverterTests categoryIdConverterTests commentIdConverterTests commentStatusConverterTests diff --git a/src/MyWebLog.Tests/Data/WebLogDataTests.fs b/src/MyWebLog.Tests/Data/WebLogDataTests.fs index 5e197b3..aca500e 100644 --- a/src/MyWebLog.Tests/Data/WebLogDataTests.fs +++ b/src/MyWebLog.Tests/Data/WebLogDataTests.fs @@ -30,7 +30,7 @@ let ``Add succeeds`` (data: IData) = task { IsTagEnabled = false Copyright = Some "go for it" CustomFeeds = [] } - AutoHtmx = true + AutoHtmx = AutoHtmax Uploads = Disk RedirectRules = [ { From = "/here"; To = "/there"; IsRegex = false } ] AutoOpenGraph = false } @@ -46,7 +46,7 @@ let ``Add succeeds`` (data: IData) = task { 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.AutoHtmx AutoHtmax "Auto htmx type is incorrect" Expect.equal it.Uploads Disk "Upload destination is incorrect" Expect.equal it.RedirectRules [ { From = "/here"; To = "/there"; IsRegex = false } ] "Redirect rules are incorrect" Expect.isFalse it.AutoOpenGraph "Auto OpenGraph flag is incorrect" @@ -91,7 +91,7 @@ let ``FindById succeeds when a web log is found`` (data: IData) = task { Expect.equal it.ThemeId (ThemeId "default") "Theme ID is incorrect" Expect.equal it.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.AutoHtmx AutoHtmx "Auto htmx type is incorrect" Expect.equal it.Uploads Database "Upload destination is incorrect" Expect.isEmpty it.RedirectRules "Redirect rules are incorrect" let rss = it.Rss @@ -165,10 +165,10 @@ let ``UpdateRssOptions succeeds when the web log does not exist`` (data: IData) let ``UpdateSettings succeeds when the web log exists`` (data: IData) = task { let! 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 } + do! data.WebLog.UpdateSettings { webLog.Value with AutoHtmx = NoAutoHtmx; 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.equal updated.Value.AutoHtmx NoAutoHtmx "Auto htmx type not updated correctly" Expect.isNone updated.Value.Subtitle "Subtitle not updated correctly" } diff --git a/src/MyWebLog.Tests/Domain/SupportTypesTests.fs b/src/MyWebLog.Tests/Domain/SupportTypesTests.fs index 3e3164f..05a9965 100644 --- a/src/MyWebLog.Tests/Domain/SupportTypesTests.fs +++ b/src/MyWebLog.Tests/Domain/SupportTypesTests.fs @@ -31,16 +31,16 @@ let nodaTests = testList "Noda" [ let accessLevelTests = testList "AccessLevel" [ testList "Parse" [ test "succeeds for \"Author\"" { - Expect.equal Author (AccessLevel.Parse "Author") "Author not parsed correctly" + Expect.equal (AccessLevel.Parse "Author") Author "Author not parsed correctly" } test "succeeds for \"Editor\"" { - Expect.equal Editor (AccessLevel.Parse "Editor") "Editor not parsed correctly" + Expect.equal (AccessLevel.Parse "Editor") Editor "Editor not parsed correctly" } test "succeeds for \"WebLogAdmin\"" { - Expect.equal WebLogAdmin (AccessLevel.Parse "WebLogAdmin") "WebLogAdmin not parsed correctly" + Expect.equal (AccessLevel.Parse "WebLogAdmin") WebLogAdmin "WebLogAdmin not parsed correctly" } test "succeeds for \"Administrator\"" { - Expect.equal Administrator (AccessLevel.Parse "Administrator") "Administrator not parsed correctly" + Expect.equal (AccessLevel.Parse "Administrator") Administrator "Administrator not parsed correctly" } test "fails when given an unrecognized value" { Expect.throwsT @@ -113,17 +113,47 @@ let accessLevelTests = testList "AccessLevel" [ ] ] +/// Tests for the AutoHtmxType type +let autoHtmxTypeTests = testList "AutoHtmxType" [ + testList "Parse" [ + test "succeeds for \"NoAutoHtmx\"" { + Expect.equal (AutoHtmxType.Parse "No") NoAutoHtmx "No not parsed correctly" + } + test "succeeds for \"AutoHtmx\"" { + Expect.equal (AutoHtmxType.Parse "Yes") AutoHtmx "Yes not parsed correctly" + } + test "succeeds for \"AutoHtmax\"" { + Expect.equal (AutoHtmxType.Parse "Max") AutoHtmax "Max not parsed correctly" + } + test "fails for unrecognized value" { + Expect.throwsT + (fun () -> ignore (AutoHtmxType.Parse "Sure")) "Invalid value should have raised an exception" + } + ] + testList "ToString" [ + test "NoAutoHtmx succeeds" { + Expect.equal (string NoAutoHtmx) "No" "NoAutoHtmx string incorrect" + } + test "AutoHtmx succeeds" { + Expect.equal (string AutoHtmx) "Yes" "AutoHtmx string incorrect" + } + test "AutoHtmax succeeds" { + Expect.equal (string AutoHtmax) "Max" "AutoHtmax string incorrect" + } + ] +] + /// Tests for the CommentStatus type let commentStatusTests = testList "CommentStatus" [ testList "Parse" [ test "succeeds for \"Approved\"" { - Expect.equal Approved (CommentStatus.Parse "Approved") "Approved not parsed correctly" + Expect.equal (CommentStatus.Parse "Approved") Approved "Approved not parsed correctly" } test "succeeds for \"Pending\"" { - Expect.equal Pending (CommentStatus.Parse "Pending") "Pending not parsed correctly" + Expect.equal (CommentStatus.Parse "Pending") Pending "Pending not parsed correctly" } test "succeeds for \"Spam\"" { - Expect.equal Spam (CommentStatus.Parse "Spam") "Spam not parsed correctly" + Expect.equal (CommentStatus.Parse "Spam") Spam "Spam not parsed correctly" } test "fails for unrecognized value" { Expect.throwsT @@ -147,13 +177,13 @@ let commentStatusTests = testList "CommentStatus" [ let explicitRatingTests = testList "ExplicitRating" [ testList "Parse" [ test "succeeds for \"yes\"" { - Expect.equal Yes (ExplicitRating.Parse "yes") "\"yes\" not parsed correctly" + Expect.equal (ExplicitRating.Parse "yes") Yes "\"yes\" not parsed correctly" } test "succeeds for \"no\"" { - Expect.equal No (ExplicitRating.Parse "no") "\"no\" not parsed correctly" + Expect.equal (ExplicitRating.Parse "no") No "\"no\" not parsed correctly" } test "succeeds for \"clean\"" { - Expect.equal Clean (ExplicitRating.Parse "clean") "\"clean\" not parsed correctly" + Expect.equal (ExplicitRating.Parse "clean") Clean "\"clean\" not parsed correctly" } test "fails for unrecognized value" { Expect.throwsT @@ -780,6 +810,7 @@ let uploadDestinationTests = testList "UploadDestination" [ let all = testList "SupportTypes" [ nodaTests accessLevelTests + autoHtmxTypeTests commentStatusTests explicitRatingTests episodeTests diff --git a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs index 0b51333..3608040 100644 --- a/src/MyWebLog.Tests/Domain/ViewModelsTests.fs +++ b/src/MyWebLog.Tests/Domain/ViewModelsTests.fs @@ -1363,7 +1363,7 @@ let settingsModelTests = testList "SettingsModel" [ PostsPerPage = 18 TimeZone = "America/Denver" ThemeId = ThemeId "my-theme" - AutoHtmx = true + AutoHtmx = AutoHtmx AutoOpenGraph = false } Expect.equal model.Name "The Web Log" "Name not filled properly" Expect.equal model.Slug "the-web-log" "Slug not filled properly" @@ -1372,7 +1372,7 @@ let settingsModelTests = testList "SettingsModel" [ 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.AutoHtmx (string AutoHtmx) "AutoHtmx should have been set" Expect.equal model.Uploads "Database" "Uploads not filled properly" Expect.isFalse model.AutoOpenGraph "AutoOpenGraph should have been unset" } @@ -1391,7 +1391,7 @@ let settingsModelTests = testList "SettingsModel" [ PostsPerPage = 8 TimeZone = "America/Chicago" ThemeId = "test-theme" - AutoHtmx = true + AutoHtmx = (string AutoHtmax) Uploads = "Disk" AutoOpenGraph = false }.Update WebLog.Empty Expect.equal webLog.Name "Interesting" "Name not filled properly" @@ -1401,7 +1401,7 @@ let settingsModelTests = testList "SettingsModel" [ 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.AutoHtmx AutoHtmax "AutoHtmx should have been set" Expect.equal webLog.Uploads Disk "Uploads not filled properly" Expect.isFalse webLog.AutoOpenGraph "AutoOpenGraph should have been unset" } diff --git a/src/MyWebLog.Tests/root-weblog.json b/src/MyWebLog.Tests/root-weblog.json index 9c820c8..b9f6e15 100644 --- a/src/MyWebLog.Tests/root-weblog.json +++ b/src/MyWebLog.Tests/root-weblog.json @@ -41,7 +41,7 @@ } ] }, - "AutoHtmx": true, + "AutoHtmx": "Yes", "Uploads": "Database", "RedirectRules": [] }, diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 0c6d83a..05bddcc 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -516,12 +516,17 @@ module WebLog = |> List.sortBy _.Title.ToLower() |> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ] let! themes = data.Theme.All() + let htmxOpts = + [ string NoAutoHtmx, "None" + string AutoHtmx, "htmx Library" + string AutoHtmax, "htmax Bundle" ] let uploads = [ Database; Disk ] return! Views.WebLog.webLogSettings (SettingsModel.FromWebLog ctx.WebLog) themes pages + htmxOpts uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss) |> adminPage "Web Log Settings" next ctx diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index cad7156..e8709c9 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -26,6 +26,7 @@ + diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 61df3c6..6fc65e2 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -1,117 +1,4 @@ -open Microsoft.AspNetCore.Http -open Microsoft.Extensions.Logging -open MyWebLog - -/// Middleware to derive the current web log -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 { - /// Create the full path of the request - let path = $"{ctx.Request.Scheme}://{ctx.Request.Host.Value}{ctx.Request.Path.Value}" - match WebLogCache.tryGet path with - | Some webLog -> - if isDebug then log.LogDebug $"Resolved web log {webLog.Id} for {path}" - ctx.Items["webLog"] <- webLog - if PageListCache.exists ctx then () else do! PageListCache.update ctx - if CategoryCache.exists ctx then () else do! CategoryCache.update ctx - if webLog.ExtraPath <> "" then - ctx.Request.PathBase <- PathString(webLog.ExtraPath) - ctx.Request.Path <- PathString(ctx.Request.Path.Value[webLog.ExtraPath.Length ..]) - return! next.Invoke ctx - | None -> - if isDebug then log.LogDebug $"No resolved web log for {path}" - ctx.Response.StatusCode <- 404 - } - - -open System -open Giraffe.Htmx - -/// Middleware to check redirects for the current web log -type RedirectRuleMiddleware(next: RequestDelegate, _log: ILogger) = - - /// Shorthand for case-insensitive string equality - let ciEquals str1 str2 = - String.Equals(str1, str2, StringComparison.InvariantCultureIgnoreCase) - - member _.InvokeAsync(ctx: HttpContext) = task { - let path = ctx.Request.Path.Value.ToLower() - let matched = - WebLogCache.redirectRules ctx.WebLog.Id - |> List.tryPick (fun rule -> - match rule with - | WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) -> - if ciEquals path urlFrom then Some urlTo else None - | WebLogCache.CachedRedirectRule.RegEx (regExFrom, patternTo) -> - if regExFrom.IsMatch path then Some (regExFrom.Replace(path, patternTo)) else None) - match matched with - | Some url when url.StartsWith "http" && ctx.Request.IsHtmx -> - do! ctx.Response.WriteAsync $"""""" - | Some url -> ctx.Response.Redirect(url, permanent = true) - | None -> return! next.Invoke ctx - } - - -open System.IO -open BitBadger.Documents -open Microsoft.Extensions.Configuration -open Microsoft.Extensions.DependencyInjection -open MyWebLog.Data -open Newtonsoft.Json -open Npgsql - -/// Logic to obtain a data connection and implementation based on configured values -module DataImplementation = - - open MyWebLog.Converters - open RethinkDb.Driver.FSharp - open RethinkDb.Driver.Net - - /// Create an NpgsqlDataSource from the connection string, configuring appropriately - let createNpgsqlDataSource (cfg: IConfiguration) = - let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL") - let _ = builder.UseNodaTime() - // let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore)) - (builder.Build >> Postgres.Configuration.useDataSource) () - - /// Get the configured data implementation - let get (sp: IServiceProvider) : IData = - let config = sp.GetRequiredService() - let await it = (Async.AwaitTask >> Async.RunSynchronously) it - let connStr name = config.GetConnectionString name - let hasConnStr name = (connStr >> isNull >> not) name - let createSQLite connStr : IData = - Sqlite.Configuration.useConnectionString connStr - let log = sp.GetRequiredService>() - let conn = Sqlite.Configuration.dbConn () - log.LogInformation $"Using SQLite database {conn.DataSource}" - SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault())) - - if hasConnStr "SQLite" then - createSQLite (connStr "SQLite") - elif hasConnStr "RethinkDB" then - let log = sp.GetRequiredService>() - let _ = Json.configure Converter.Serializer - let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB") - let conn = await (rethinkCfg.CreateConnectionAsync log) - RethinkDbData(conn, rethinkCfg, log) - elif hasConnStr "PostgreSQL" then - createNpgsqlDataSource config - use conn = Postgres.Configuration.dataSource().CreateConnection() - let log = sp.GetRequiredService>() - log.LogInformation $"Using PostgreSQL database {conn.Database}" - PostgresData(log, Json.configure (JsonSerializer.CreateDefault())) - else - if not (Directory.Exists "./data") then Directory.CreateDirectory "./data" |> ignore - createSQLite "Data Source=./data/myweblog.db;Cache=Shared" - - -open System.Threading.Tasks - -/// Show a list of valid command-line interface commands +/// Show a list of valid command-line interface commands let showHelp () = printfn " " printfn "COMMAND WHAT IT DOES" @@ -127,20 +14,30 @@ 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() + System.Threading.Tasks.Task.FromResult() -open BitBadger.AspNetCore.CanonicalDomains -open Giraffe -open Giraffe.EndpointRouting +open System +open System.IO open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Builder -open Microsoft.Extensions.Caching.Distributed -open Microsoft.AspNetCore.HttpOverrides open Microsoft.AspNetCore.Hosting +open Microsoft.AspNetCore.Http +open Microsoft.AspNetCore.HttpOverrides +open Microsoft.Extensions.Caching.Distributed +open Microsoft.Extensions.Configuration +open Microsoft.Extensions.DependencyInjection open Microsoft.Data.Sqlite +open BitBadger.AspNetCore.CanonicalDomains +open BitBadger.Documents +open Giraffe +open Giraffe.EndpointRouting open NeoSmart.Caching.Sqlite +open Newtonsoft.Json +open Npgsql open RethinkDB.DistributedCache +open MyWebLog +open MyWebLog.Data [] let main args = diff --git a/src/MyWebLog/ProgramSupport.fs b/src/MyWebLog/ProgramSupport.fs new file mode 100644 index 0000000..4c85acf --- /dev/null +++ b/src/MyWebLog/ProgramSupport.fs @@ -0,0 +1,109 @@ +namespace MyWebLog + +open Microsoft.AspNetCore.Http +open Microsoft.Extensions.Logging + +/// Middleware to derive the current web log +type WebLogMiddleware(next: RequestDelegate, log: ILogger) = + + /// Is the debug level enabled on the logger? + let isDebug = log.IsEnabled LogLevel.Debug + + member _.InvokeAsync(ctx: HttpContext) = task { + /// Create the full path of the request + let path = $"{ctx.Request.Scheme}://{ctx.Request.Host.Value}{ctx.Request.Path.Value}" + match WebLogCache.tryGet path with + | Some webLog -> + if isDebug then log.LogDebug $"Resolved web log {webLog.Id} for {path}" + ctx.Items["webLog"] <- webLog + if PageListCache.exists ctx then () else do! PageListCache.update ctx + if CategoryCache.exists ctx then () else do! CategoryCache.update ctx + if webLog.ExtraPath <> "" then + ctx.Request.PathBase <- PathString(webLog.ExtraPath) + ctx.Request.Path <- PathString(ctx.Request.Path.Value[webLog.ExtraPath.Length ..]) + return! next.Invoke ctx + | None -> + log.LogWarning $"No resolved web log for {path}" + ctx.Response.StatusCode <- 404 + } + + +open System +open Giraffe.Htmx + +/// Middleware to check redirects for the current web log +type RedirectRuleMiddleware(next: RequestDelegate, _log: ILogger) = + + /// Shorthand for case-insensitive string equality + let ciEquals str1 str2 = + String.Equals(str1, str2, StringComparison.InvariantCultureIgnoreCase) + + member _.InvokeAsync(ctx: HttpContext) = task { + let path = ctx.Request.Path.Value.ToLower() + let matched = + WebLogCache.redirectRules ctx.WebLog.Id + |> List.tryPick (fun rule -> + match rule with + | WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) -> + if ciEquals path urlFrom then Some urlTo else None + | WebLogCache.CachedRedirectRule.RegEx (regExFrom, patternTo) -> + if regExFrom.IsMatch path then Some (regExFrom.Replace(path, patternTo)) else None) + match matched with + | Some url when url.StartsWith "http" && ctx.Request.IsHtmx -> + do! ctx.Response.WriteAsync $"""""" + | Some url -> ctx.Response.Redirect(url, permanent = true) + | None -> return! next.Invoke ctx + } + + +/// Logic to obtain a data connection and implementation based on configured values +module DataImplementation = + + open System.IO + open Microsoft.Extensions.Configuration + open Microsoft.Extensions.DependencyInjection + open BitBadger.Documents + open Newtonsoft.Json + open Npgsql + open RethinkDb.Driver.FSharp + open RethinkDb.Driver.Net + open MyWebLog.Data + open MyWebLog.Converters + + /// Create an NpgsqlDataSource from the connection string, configuring appropriately + let createNpgsqlDataSource (cfg: IConfiguration) = + let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL") + let _ = builder.UseNodaTime() + // let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore)) + (builder.Build >> Postgres.Configuration.useDataSource) () + + /// Get the configured data implementation + let get (sp: IServiceProvider) : IData = + let config = sp.GetRequiredService() + let await it = (Async.AwaitTask >> Async.RunSynchronously) it + let connStr name = config.GetConnectionString name + let hasConnStr name = (connStr >> isNull >> not) name + let createSQLite connStr : IData = + Sqlite.Configuration.useConnectionString connStr + let log = sp.GetRequiredService>() + let conn = Sqlite.Configuration.dbConn () + log.LogInformation $"Using SQLite database {conn.DataSource}" + SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault())) + + if hasConnStr "SQLite" then + createSQLite (connStr "SQLite") + elif hasConnStr "RethinkDB" then + let log = sp.GetRequiredService>() + let _ = Json.configure Converter.Serializer + let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB") + let conn = await (rethinkCfg.CreateConnectionAsync log) + RethinkDbData(conn, rethinkCfg, log) + elif hasConnStr "PostgreSQL" then + createNpgsqlDataSource config + use conn = Postgres.Configuration.dataSource().CreateConnection() + let log = sp.GetRequiredService>() + log.LogInformation $"Using PostgreSQL database {conn.Database}" + PostgresData(log, Json.configure (JsonSerializer.CreateDefault())) + else + if not (Directory.Exists "./data") then Directory.CreateDirectory "./data" |> ignore + createSQLite "Data Source=./data/myweblog.db;Cache=Shared" diff --git a/src/MyWebLog/Views/WebLog.fs b/src/MyWebLog/Views/WebLog.fs index 24c87d3..58f8166 100644 --- a/src/MyWebLog/Views/WebLog.fs +++ b/src/MyWebLog/Views/WebLog.fs @@ -701,8 +701,8 @@ let uploadNew app = [ /// Web log settings page let webLogSettings - (model: SettingsModel) (themes: Theme list) (pages: Page list) (uploads: UploadDestination list) - (rss: EditRssModel) (app: AppViewContext) = [ + (model: SettingsModel) (themes: Theme list) (pages: Page list) (htmxOpts: (string * string) list) + (uploads: UploadDestination list) (rss: EditRssModel) (app: AppViewContext) = [ let feedDetail (feed: CustomFeed) = let source = match feed.Source with @@ -786,7 +786,8 @@ let webLogSettings 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 [] + selectField [ _required ] (nameof model.AutoHtmx) "Auto-Load htmx" model.AutoHtmx htmxOpts + fst snd [] span [ _class "form-text fst-italic" ] [ a [ _href "https://htmx.org"; _target "_blank"; _relNoOpener ] [ raw "What is this?" ] ]