src/MyWebLog.Data/MyWebLog.Data.fsproj

@@ -6,9 +6,11 @@
 
 	<ItemGroup>
 		<PackageReference Include="Microsoft.Data.Sqlite" Version="6.0.7" />
+		<PackageReference Include="Microsoft.Extensions.Caching.Abstractions" Version="6.0.0" />
 		<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="6.0.0" />
 		<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
 		<PackageReference Include="Newtonsoft.Json" Version="13.0.1" />
+		<PackageReference Include="NodaTime" Version="3.1.2" />
 		<PackageReference Include="Npgsql" Version="6.0.6" />
 		<PackageReference Include="Npgsql.FSharp" Version="5.3.0" />
 		<PackageReference Include="RethinkDb.Driver" Version="2.3.150" />
@@ -31,16 +33,17 @@
 		<Compile Include="SQLite\SQLiteWebLogData.fs" />
 		<Compile Include="SQLite\SQLiteWebLogUserData.fs" />
 		<Compile Include="SQLiteData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlHelpers.fs" />
-		<Compile Include="PostgreSql\PostgreSqlCategoryData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlPageData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlPostData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlTagMapData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlThemeData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlUploadData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlWebLogData.fs" />
-		<Compile Include="PostgreSql\PostgreSqlWebLogUserData.fs" />
-        <Compile Include="PostgreSqlData.fs" />
+		<Compile Include="Postgres\PostgresHelpers.fs" />
+		<Compile Include="Postgres\PostgresCache.fs" />
+		<Compile Include="Postgres\PostgresCategoryData.fs" />
+		<Compile Include="Postgres\PostgresPageData.fs" />
+		<Compile Include="Postgres\PostgresPostData.fs" />
+		<Compile Include="Postgres\PostgresTagMapData.fs" />
+		<Compile Include="Postgres\PostgresThemeData.fs" />
+		<Compile Include="Postgres\PostgresUploadData.fs" />
+		<Compile Include="Postgres\PostgresWebLogData.fs" />
+		<Compile Include="Postgres\PostgresWebLogUserData.fs" />
+        <Compile Include="PostgresData.fs" />
 	</ItemGroup>
 
 </Project>

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
+[<AutoOpen>]
+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<Instant>        "expire_at"
+                    SlidingExpiration  = row.fieldValueOrNone<Duration> "sliding_expiration"
+                    AbsoluteExpiration = row.fieldValueOrNone<Instant>  "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

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 =

src/MyWebLog.Data/Postgres/PostgresHelpers.fs

@@ -1,6 +1,6 @@
 /// Helper functions for the PostgreSQL data implementation
 [<AutoOpen>]
-module MyWebLog.Data.PostgreSql.PostgreSqlHelpers
+module MyWebLog.Data.Postgres.PostgresHelpers
 
 open System.Threading.Tasks
 open MyWebLog

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
     

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
     

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 =

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 () =

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 =

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
     

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 =

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<PostgreSqlData>) =
+type PostgresData (conn : NpgsqlConnection, log : ILogger<PostgresData>) =
 
     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 {
 

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<ILogger<PostgreSqlData>> ()
+            let log  = sp.GetRequiredService<ILogger<PostgresData>> ()
             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<IConfiguration> ()
         builder.Services.AddScoped<NpgsqlConnection> (fun sp ->
             new NpgsqlConnection (cfg.GetConnectionString "PostgreSQL"))
         |> ignore
-        builder.Services.AddScoped<IData, PostgreSqlData> () |> ignore
+        builder.Services.AddScoped<IData, PostgresData> () |> 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