diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index eec8ee5..3ba45e5 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -6,9 +6,11 @@ + + @@ -31,16 +33,17 @@ - - - - - - - - - - + + + + + + + + + + + diff --git a/src/MyWebLog.Data/Postgres/PostgresCache.fs b/src/MyWebLog.Data/Postgres/PostgresCache.fs new file mode 100644 index 0000000..c01db67 --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresCache.fs @@ -0,0 +1,216 @@ +namespace MyWebLog.Data.Postgres + +open System.Threading +open System.Threading.Tasks +open Microsoft.Extensions.Caching.Distributed +open NodaTime +open Npgsql +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 + } + + /// Run a task synchronously + let sync<'T> (it : Task<'T>) = it |> (Async.AwaitTask >> Async.RunSynchronously) + + /// Get the current instant + let getNow () = SystemClock.Instance.GetCurrentInstant () + + /// Create a parameter for the expire-at time + let expireParam (it : Instant) = + "@expireAt", Sql.parameter (NpgsqlParameter ("@expireAt", it)) + + /// Create a parameter for a possibly-missing NodaTime type + let optParam<'T> name (it : 'T option) = + let p = NpgsqlParameter ($"@%s{name}", if Option.isSome it then box it.Value else null) + p.ParameterName, Sql.parameter p + + +/// A distributed cache implementation in PostgreSQL used to handle sessions for myWebLog +type DistributedCache (connStr : string) = + + // ~~~ INITIALIZATION ~~~ + + do + task { + let! exists = + Sql.connect connStr + |> Sql.query $" + SELECT EXISTS + (SELECT 1 FROM pg_tables WHERE schemaname = 'public' AND tablename = 'session') + AS {existsName}" + |> Sql.executeRowAsync Map.toExists + if not exists then + let! _ = + Sql.connect connStr + |> Sql.query + "CREATE TABLE session ( + id TEXT NOT NULL PRIMARY KEY, + payload BYETA NOT NULL, + expire_at TIMESTAMPTZ NOT NULL, + sliding_expiration INTERVAL, + absolute_expiration TIMESTAMPTZ); + CREATE INDEX idx_session_expiration ON session (expire_at)" + |> Sql.executeNonQueryAsync + () + } |> sync + + // ~~~ SUPPORT FUNCTIONS ~~~ + + /// Get an entry, updating it for sliding expiration + let getEntry key = backgroundTask { + let idParam = "@id", Sql.string key + let! tryEntry = + Sql.connect connStr + |> Sql.query "SELECT * FROM session WHERE id = @id" + |> Sql.parameters [ idParam ] + |> Sql.executeAsync (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" }) + |> tryHead + match tryEntry with + | Some entry -> + let now = getNow () + let slideExp = defaultArg entry.SlidingExpiration Duration.MinValue + let absExp = defaultArg entry.AbsoluteExpiration Instant.MinValue + let needsRefresh, item = + if entry.ExpireAt = absExp then false, entry + elif slideExp = Duration.MinValue && absExp = Instant.MinValue then false, entry + elif absExp > Instant.MinValue && entry.ExpireAt.Plus slideExp > absExp then + true, { entry with ExpireAt = absExp } + else true, { entry with ExpireAt = now.Plus slideExp } + if needsRefresh then + let! _ = + Sql.connect connStr + |> Sql.query "UPDATE session SET expire_at = @expireAt WHERE id = @id" + |> Sql.parameters [ expireParam item.ExpireAt; idParam ] + |> Sql.executeNonQueryAsync + () + return if item.ExpireAt > now then Some entry else None + | None -> return None + } + + /// The last time expired entries were purged (runs every 30 minutes) + let mutable lastPurge = Instant.MinValue + + /// Purge expired entries every 30 minutes + let purge () = backgroundTask { + let now = getNow () + if lastPurge.Plus (Duration.FromMinutes 30L) < now then + let! _ = + Sql.connect connStr + |> Sql.query "DELETE FROM session WHERE expire_at < @expireAt" + |> Sql.parameters [ expireParam now ] + |> Sql.executeNonQueryAsync + lastPurge <- now + } + + /// Remove a cache entry + let removeEntry key = backgroundTask { + let! _ = + Sql.connect connStr + |> Sql.query "DELETE FROM session WHERE id = @id" + |> Sql.parameters [ "@id", Sql.string key ] + |> Sql.executeNonQueryAsync + () + } + + /// Save an entry + let saveEntry (opts : DistributedCacheEntryOptions) key payload = backgroundTask { + let now = getNow () + let expireAt, slideExp, absExp = + if opts.SlidingExpiration.HasValue then + let slide = Duration.FromTimeSpan opts.SlidingExpiration.Value + now.Plus slide, Some slide, None + elif opts.AbsoluteExpiration.HasValue then + let exp = Instant.FromDateTimeOffset opts.AbsoluteExpiration.Value + exp, None, Some exp + elif opts.AbsoluteExpirationRelativeToNow.HasValue then + let exp = now.Plus (Duration.FromTimeSpan opts.AbsoluteExpirationRelativeToNow.Value) + exp, None, Some exp + else + // Default to 1 hour sliding expiration + let slide = Duration.FromHours 1 + now.Plus slide, Some slide, None + let! _ = + Sql.connect connStr + |> Sql.query + "INSERT INTO session ( + id, payload, expire_at, sliding_expiration, absolute_expiration + ) VALUES ( + @id, @payload, @expireAt, @slideExp, @absExp + ) ON CONFLICT (id) DO UPDATE + SET payload = EXCLUDED.payload, + expire_at = EXCLUDED.expire_at, + sliding_expiration = EXCLUDED.sliding_expiration, + absolute_expiration = EXCLUDED.absolute_expiration" + |> Sql.parameters + [ "@id", Sql.string key + "@payload", Sql.bytea payload + expireParam expireAt + optParam "slideExp" slideExp + optParam "absExp" absExp ] + |> Sql.executeNonQueryAsync + () + } + + // ~~~ IMPLEMENTATION FUNCTIONS ~~~ + + /// Retrieve the data for a cache entry + let get key (_ : CancellationToken) = backgroundTask { + match! getEntry key with + | Some entry -> + do! purge () + return entry.Payload + | None -> return null + } + + /// Refresh an entry + let refresh key (cancelToken : CancellationToken) = backgroundTask { + let! _ = get key cancelToken + () + } + + /// Remove an entry + let remove key (_ : CancellationToken) = backgroundTask { + do! removeEntry key + do! purge () + } + + /// Set an entry + let set key value options (_ : CancellationToken) = backgroundTask { + do! saveEntry options key value + do! purge () + } + + interface IDistributedCache with + member this.Get key = get key CancellationToken.None |> sync + member this.GetAsync (key, token) = get key token + member this.Refresh key = refresh key CancellationToken.None |> sync + member this.RefreshAsync (key, token) = refresh key token + member this.Remove key = remove key CancellationToken.None |> sync + member this.RemoveAsync (key, token) = remove key token + member this.Set (key, value, options) = set key value options CancellationToken.None |> sync + member this.SetAsync (key, value, options, token) = set key value options token diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs similarity index 98% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlCategoryData.fs rename to src/MyWebLog.Data/Postgres/PostgresCategoryData.fs index 4a13f9b..32db33a 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlCategoryData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -1,11 +1,12 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open MyWebLog open MyWebLog.Data open Npgsql open Npgsql.FSharp -type PostgreSqlCategoryData (conn : NpgsqlConnection) = +/// PostgreSQL myWebLog category data implementation +type PostgresCategoryData (conn : NpgsqlConnection) = /// Count all categories for the given web log let countAll webLogId = diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlHelpers.fs b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs similarity index 99% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlHelpers.fs rename to src/MyWebLog.Data/Postgres/PostgresHelpers.fs index addcf81..4cf2729 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlHelpers.fs +++ b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs @@ -1,6 +1,6 @@ /// Helper functions for the PostgreSQL data implementation [] -module MyWebLog.Data.PostgreSql.PostgreSqlHelpers +module MyWebLog.Data.Postgres.PostgresHelpers open System.Threading.Tasks open MyWebLog diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs similarity index 99% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlPageData.fs rename to src/MyWebLog.Data/Postgres/PostgresPageData.fs index 1a099fe..fd4e57a 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlPageData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -1,4 +1,4 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open MyWebLog open MyWebLog.Data @@ -7,7 +7,7 @@ open Npgsql open Npgsql.FSharp /// PostgreSQL myWebLog page data implementation -type PostgreSqlPageData (conn : NpgsqlConnection) = +type PostgresPageData (conn : NpgsqlConnection) = // SUPPORT FUNCTIONS diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs similarity index 99% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlPostData.fs rename to src/MyWebLog.Data/Postgres/PostgresPostData.fs index da694c1..9652fa4 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlPostData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -1,4 +1,4 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open System open MyWebLog @@ -8,7 +8,7 @@ open Npgsql open Npgsql.FSharp /// PostgreSQL myWebLog post data implementation -type PostgreSqlPostData (conn : NpgsqlConnection) = +type PostgresPostData (conn : NpgsqlConnection) = // SUPPORT FUNCTIONS diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs similarity index 97% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlTagMapData.fs rename to src/MyWebLog.Data/Postgres/PostgresTagMapData.fs index dce9f4a..c0b9c51 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlTagMapData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -1,4 +1,4 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open MyWebLog open MyWebLog.Data @@ -6,7 +6,7 @@ open Npgsql open Npgsql.FSharp /// PostgreSQL myWebLog tag mapping data implementation -type PostgreSqlTagMapData (conn : NpgsqlConnection) = +type PostgresTagMapData (conn : NpgsqlConnection) = /// Find a tag mapping by its ID for the given web log let findById tagMapId webLogId = diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlThemeData.fs b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs similarity index 98% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlThemeData.fs rename to src/MyWebLog.Data/Postgres/PostgresThemeData.fs index 8c7c2f3..472ff95 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlThemeData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs @@ -1,4 +1,4 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open MyWebLog open MyWebLog.Data @@ -6,7 +6,7 @@ open Npgsql open Npgsql.FSharp /// PostreSQL myWebLog theme data implementation -type PostgreSqlThemeData (conn : NpgsqlConnection) = +type PostgresThemeData (conn : NpgsqlConnection) = /// Retrieve all themes (except 'admin'; excludes template text) let all () = backgroundTask { @@ -135,7 +135,7 @@ type PostgreSqlThemeData (conn : NpgsqlConnection) = /// PostreSQL myWebLog theme data implementation -type PostgreSqlThemeAssetData (conn : NpgsqlConnection) = +type PostgresThemeAssetData (conn : NpgsqlConnection) = /// Get all theme assets (excludes data) let all () = diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlUploadData.fs b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs similarity index 97% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlUploadData.fs rename to src/MyWebLog.Data/Postgres/PostgresUploadData.fs index b92a5f0..2bf4f1f 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlUploadData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs @@ -1,4 +1,4 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open MyWebLog open MyWebLog.Data @@ -6,7 +6,7 @@ open Npgsql open Npgsql.FSharp /// PostgreSQL myWebLog uploaded file data implementation -type PostgreSqlUploadData (conn : NpgsqlConnection) = +type PostgresUploadData (conn : NpgsqlConnection) = /// The INSERT statement for an uploaded file let upInsert = diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs similarity index 99% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlWebLogData.fs rename to src/MyWebLog.Data/Postgres/PostgresWebLogData.fs index e6b0b53..2cd9605 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlWebLogData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -1,4 +1,4 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open MyWebLog open MyWebLog.Data @@ -6,7 +6,7 @@ open Npgsql open Npgsql.FSharp /// PostgreSQL myWebLog web log data implementation -type PostgreSqlWebLogData (conn : NpgsqlConnection) = +type PostgresWebLogData (conn : NpgsqlConnection) = // SUPPORT FUNCTIONS diff --git a/src/MyWebLog.Data/PostgreSql/PostgreSqlWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs similarity index 98% rename from src/MyWebLog.Data/PostgreSql/PostgreSqlWebLogUserData.fs rename to src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs index 32f539a..014b9ca 100644 --- a/src/MyWebLog.Data/PostgreSql/PostgreSqlWebLogUserData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -1,4 +1,4 @@ -namespace MyWebLog.Data.PostgreSql +namespace MyWebLog.Data.Postgres open MyWebLog open MyWebLog.Data @@ -6,7 +6,7 @@ open Npgsql open Npgsql.FSharp /// PostgreSQL myWebLog user data implementation -type PostgreSqlWebLogUserData (conn : NpgsqlConnection) = +type PostgresWebLogUserData (conn : NpgsqlConnection) = /// The INSERT statement for a user let userInsert = diff --git a/src/MyWebLog.Data/PostgreSqlData.fs b/src/MyWebLog.Data/PostgresData.fs similarity index 94% rename from src/MyWebLog.Data/PostgreSqlData.fs rename to src/MyWebLog.Data/PostgresData.fs index 0497722..a0a5e3a 100644 --- a/src/MyWebLog.Data/PostgreSqlData.fs +++ b/src/MyWebLog.Data/PostgresData.fs @@ -1,24 +1,24 @@ namespace MyWebLog.Data open Microsoft.Extensions.Logging -open MyWebLog.Data.PostgreSql +open MyWebLog.Data.Postgres open Npgsql open Npgsql.FSharp /// Data implementation for PostgreSQL -type PostgreSqlData (conn : NpgsqlConnection, log : ILogger) = +type PostgresData (conn : NpgsqlConnection, log : ILogger) = interface IData with - member _.Category = PostgreSqlCategoryData conn - member _.Page = PostgreSqlPageData conn - member _.Post = PostgreSqlPostData conn - member _.TagMap = PostgreSqlTagMapData conn - member _.Theme = PostgreSqlThemeData conn - member _.ThemeAsset = PostgreSqlThemeAssetData conn - member _.Upload = PostgreSqlUploadData conn - member _.WebLog = PostgreSqlWebLogData conn - member _.WebLogUser = PostgreSqlWebLogUserData conn + member _.Category = PostgresCategoryData conn + member _.Page = PostgresPageData conn + member _.Post = PostgresPostData conn + member _.TagMap = PostgresTagMapData conn + member _.Theme = PostgresThemeData conn + member _.ThemeAsset = PostgresThemeAssetData conn + member _.Upload = PostgresUploadData conn + member _.WebLog = PostgresWebLogData conn + member _.WebLogUser = PostgresWebLogUserData conn member _.StartUp () = backgroundTask { diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index bd9ef78..971f2be 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -60,10 +60,10 @@ module DataImplementation = let conn = await (rethinkCfg.CreateConnectionAsync log) upcast RethinkDbData (conn, rethinkCfg, log) elif hasConnStr "PostgreSQL" then - let log = sp.GetRequiredService> () + let log = sp.GetRequiredService> () let conn = new NpgsqlConnection (connStr "PostgreSQL") log.LogInformation $"Using PostgreSQL database {conn.Host}:{conn.Port}/{conn.Database}" - PostgreSqlData (conn, log) + PostgresData (conn, log) else upcast createSQLite "Data Source=./myweblog.db;Cache=Shared" @@ -144,13 +144,13 @@ let rec main args = // Use SQLite for caching as well let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath) |> ignore - | :? PostgreSqlData -> + | :? PostgresData -> // ADO.NET connections are designed to work as per-request instantiation let cfg = sp.GetRequiredService () builder.Services.AddScoped (fun sp -> new NpgsqlConnection (cfg.GetConnectionString "PostgreSQL")) |> ignore - builder.Services.AddScoped () |> ignore + builder.Services.AddScoped () |> ignore // Use SQLite for caching (for now) let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath) |> ignore