WIP on Marten data store

src/JobsJobsJobs.sln

@@ -17,6 +17,8 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Domain", "JobsJobsJobs\Doma
 EndProject
 Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Api", "JobsJobsJobs\Server\JobsJobsJobs.Server.fsproj", "{8F5A3D1E-562B-4F27-9787-6CB14B35E69E}"
 EndProject
+Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "JobsJobsJobs.Data", "JobsJobsJobs\JobsJobsJobs.Data\JobsJobsJobs.Data.fsproj", "{30CC1E7C-A843-4DAC-9058-E7C6ACBCE85D}"
+EndProject
 Global
 	GlobalSection(SolutionConfigurationPlatforms) = preSolution
 		Debug|Any CPU = Debug|Any CPU
@@ -31,6 +33,10 @@ Global
 		{8F5A3D1E-562B-4F27-9787-6CB14B35E69E}.Debug|Any CPU.Build.0 = Debug|Any CPU
 		{8F5A3D1E-562B-4F27-9787-6CB14B35E69E}.Release|Any CPU.ActiveCfg = Release|Any CPU
 		{8F5A3D1E-562B-4F27-9787-6CB14B35E69E}.Release|Any CPU.Build.0 = Release|Any CPU
+		{30CC1E7C-A843-4DAC-9058-E7C6ACBCE85D}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
+		{30CC1E7C-A843-4DAC-9058-E7C6ACBCE85D}.Debug|Any CPU.Build.0 = Debug|Any CPU
+		{30CC1E7C-A843-4DAC-9058-E7C6ACBCE85D}.Release|Any CPU.ActiveCfg = Release|Any CPU
+		{30CC1E7C-A843-4DAC-9058-E7C6ACBCE85D}.Release|Any CPU.Build.0 = Release|Any CPU
 	EndGlobalSection
 	GlobalSection(SolutionProperties) = preSolution
 		HideSolutionNode = FALSE
@@ -41,5 +47,6 @@ Global
 	GlobalSection(NestedProjects) = preSolution
 		{C81278DA-DA97-4E55-AB39-4B88565B615D} = {FA833B24-B8F6-4CE6-A044-99257EAC02FF}
 		{8F5A3D1E-562B-4F27-9787-6CB14B35E69E} = {FA833B24-B8F6-4CE6-A044-99257EAC02FF}
+		{30CC1E7C-A843-4DAC-9058-E7C6ACBCE85D} = {FA833B24-B8F6-4CE6-A044-99257EAC02FF}
 	EndGlobalSection
 EndGlobal

src/JobsJobsJobs/Domain/Types.fs

@@ -38,6 +38,9 @@ type Citizen =
         /// Whether this is a legacy citizen
         isLegacy : bool
     }
+with
+    /// Unwrapped ID for database PK use
+    member this.DbId = CitizenId.value this.id
 
 /// Support functions for citizens
 module Citizen =
@@ -56,6 +59,18 @@ type Continent =
         /// The name of the continent
         name : string
     }
+with
+    /// Unwrapped ID for database PK use
+    member this.DbId = ContinentId.value this.id
+
+/// Support functions for continents
+module Continent =
+    
+    /// An empty continent
+    let empty =
+        {   id   = ContinentId Guid.Empty
+            name = ""
+        }
 
 
 /// A job listing
@@ -108,7 +123,7 @@ type SecurityInfo =
         Id : CitizenId
         
         /// The number of failed log on attempts (reset to 0 on successful log on)
-        FailedLogOnAttempts : int16
+        FailedLogOnAttempts : int
         
         /// Whether the account is locked
         AccountLocked : bool
@@ -122,6 +137,22 @@ type SecurityInfo =
         /// When the token expires
         TokenExpires : Instant option
     }
+with
+    /// Unwrapped ID for database PK use
+    member this.DbId = CitizenId.value this.Id
+
+/// Functions to support security info
+module SecurityInfo =
+    
+    /// An empty set of security info
+    let empty =
+        {   Id                  = CitizenId Guid.Empty
+            FailedLogOnAttempts = 0
+            AccountLocked       = false
+            Token               = None
+            TokenUsage          = None
+            TokenExpires        = None
+        }
 
 
 /// A skill the job seeker possesses

src/JobsJobsJobs/JobsJobsJobs.Data/Data.fs

@@ -0,0 +1,250 @@
+namespace JobsJobsJobs.Data
+
+open JobsJobsJobs.Domain
+open Marten
+open Marten.PLv8
+open Microsoft.Extensions.Configuration
+
+/// Connection management for the Marten document store
+module Connection =
+    
+    open Weasel.Core
+    
+    /// The configuration from which a document store will be created
+    let mutable private config : IConfiguration option = None
+    
+    /// Lazy initialization for the Marten document store, constructed when setUp() is called
+    let private lazyStore = lazy (task {
+        match config with
+        | Some cfg ->
+            let store =
+                DocumentStore.For(fun opts ->
+                    opts.Connection (cfg.GetConnectionString "PostgreSQL")
+                    opts.RegisterDocumentTypes [
+                        typeof<Citizen>; typeof<Continent>; typeof<Listing>; typeof<Profile>; typeof<SecurityInfo>
+                        typeof<Success>
+                    ]
+                    opts.AutoCreateSchemaObjects <- AutoCreate.CreateOrUpdate
+                    opts.UseJavascriptTransformsAndPatching ()
+                    
+                    let _ = opts.Schema.For<Citizen>().Identity (fun c -> c.DbId)
+                    let _ = opts.Schema.For<SecurityInfo>().Identity (fun si -> si.DbId)
+                    ())
+            do! store.Storage.ApplyAllConfiguredChangesToDatabaseAsync ()
+            return Ok store
+        | None -> return Error "Connection.setUp() must be called before accessing a document session"
+    })
+
+    /// Set up the data connection from the given configuration
+    let setUp (cfg : IConfiguration) =
+        config <- Some cfg
+        ignore (lazyStore.Force ())
+    
+    /// A read-only document session
+    let querySession () =
+        match lazyStore.Force().Result with
+        | Ok store -> store.QuerySession ()
+        | Error msg -> raise (invalidOp msg)
+    
+    /// A read/write document session
+    let docSession () =
+        match lazyStore.Force().Result with
+        | Ok store -> store.LightweightSession ()
+        | Error msg -> raise (invalidOp msg)
+
+
+/// Helper functions for data retrieval
+[<AutoOpen>]
+module private Helpers =
+    
+    open System.Threading
+    
+    /// Convert a possibly-null record type to an option
+    let optional<'T> (value : 'T) = if isNull (box value) then None else Some value
+    
+    /// Shorthand for no cancellation token
+    let noCnx = CancellationToken.None
+
+
+open System.Linq
+open Connection
+open Marten.PLv8.Patching
+
+/// Citizen data access functions
+[<RequireQualifiedAccess>]
+module Citizens =
+
+    /// Delete a citizen by their ID
+    let deleteById citizenId = backgroundTask {
+        use session = docSession ()
+        session.Delete<Citizen> (CitizenId.value citizenId)
+        do! session.SaveChangesAsync ()
+    }
+    
+    /// Find a citizen by their ID
+    let findById citizenId = backgroundTask {
+        use session = querySession ()
+        let! citizen = session.LoadAsync<Citizen> (CitizenId.value citizenId)
+        return
+            match optional citizen with
+            | Some c when not c.isLegacy -> Some c
+            | Some _
+            | None -> None
+    }
+    
+    /// Save a citizen
+    let save (citizen : Citizen) = backgroundTask {
+        use session = docSession ()
+        session.Store<Citizen> citizen
+        do! session.SaveChangesAsync ()
+    }
+    
+    /// Attempt a user log on
+    let tryLogOn email (pwCheck : string -> bool) now = backgroundTask {
+        use session = docSession ()
+        let! tryCitizen =
+            session.Query<Citizen>().Where(fun c -> c.email = email && not c.isLegacy).SingleOrDefaultAsync ()
+        match optional tryCitizen with
+        | Some citizen ->
+            let! tryInfo = session.LoadAsync<SecurityInfo> citizen.DbId
+            let! info = backgroundTask {
+                match optional tryInfo with
+                | Some it -> return it
+                | None ->
+                    let it = { SecurityInfo.empty with Id = citizen.id }
+                    session.Store<SecurityInfo> it
+                    do! session.SaveChangesAsync ()
+                    return it
+            }
+            if info.AccountLocked then return Error "Log on unsuccessful (Account Locked)"
+            elif pwCheck citizen.passwordHash then
+                session.Patch<SecurityInfo>(citizen.DbId).Set((fun si -> si.FailedLogOnAttempts), 0)
+                session.Patch<Citizen>(citizen.DbId).Set((fun c -> c.lastSeenOn), now)
+                do! session.SaveChangesAsync ()
+                return Ok { citizen with lastSeenOn = now }
+            else
+                let locked = info.FailedLogOnAttempts >= 4
+                session.Patch<SecurityInfo>(citizen.DbId).Increment(fun si -> si.FailedLogOnAttempts)
+                if locked then session.Patch<SecurityInfo>(citizen.DbId).Set((fun si -> si.AccountLocked), true)
+                do! session.SaveChangesAsync ()
+                return Error $"""Log on unsuccessful{if locked then " - Account is now locked" else ""}"""
+        | None -> return Error "Log on unsuccessful"
+    }
+
+
+/// Continent data access functions
+[<RequireQualifiedAccess>]
+module Continents =
+    
+    /// Retrieve all continents
+    let all () = backgroundTask {
+        use session = querySession ()
+        let! it = session.Query<Continent>().ToListAsync<Continent> noCnx
+        return List.ofSeq it
+    }
+    
+    /// Retrieve a continent by its ID
+    let findById continentId = backgroundTask {
+        use session = querySession ()
+        let! tryContinent = session.LoadAsync<Continent> (ContinentId.value continentId)
+        return optional tryContinent
+    }
+
+
+open System
+open JobsJobsJobs.Domain.SharedTypes
+
+/// Job listing access functions
+[<RequireQualifiedAccess>]
+module Listings =
+    
+    open System.Collections.Generic
+    
+    /// Find all job listings posted by the given citizen
+    let findByCitizen citizenId = backgroundTask {
+        use  session    = querySession ()
+        let  continents = Dictionary<ContinentId, Continent> ()
+        let! listings   =
+            session.Query<Listing>()
+                .Include((fun l -> l.continentId :> obj), continents)
+                .Where(fun l -> l.citizenId = citizenId && not l.isLegacy)
+                .ToListAsync ()
+        return
+            listings
+            |> Seq.map (fun l -> { listing = l; continent = continents[l.continentId] })
+            |> List.ofSeq
+    }
+    
+    /// Find a listing by its ID
+    let findById listingId = backgroundTask {
+        use  session    = querySession ()
+        let! tryListing = session.LoadAsync<Listing> (ListingId.value listingId)
+        match optional tryListing with
+        | Some listing when not listing.isLegacy -> return Some listing
+        | Some _
+        | None -> return None
+    }
+    
+    /// Find a listing by its ID for viewing (includes continent information)
+    let findByIdForView listingId = backgroundTask {
+        use session = querySession ()
+        let mutable continent = Continent.empty
+        let! tryListing =
+            session.Query<Listing>()
+                .Include((fun l -> l.continentId :> obj), fun c -> continent <- c)
+                .Where(fun l -> l.id = listingId && not l.isLegacy)
+                .SingleOrDefaultAsync ()
+        match optional tryListing with
+        | Some listing -> return Some { listing = listing; continent = continent }
+        | None -> return None
+    }
+    
+    /// Save a listing
+    let save (listing : Listing) = backgroundTask {
+        use session = docSession ()
+        session.Store listing
+        do! session.SaveChangesAsync ()
+    }
+    
+    /// Search job listings
+    let search (search : ListingSearch) = backgroundTask {
+        use session     = querySession ()
+        let continents  = Dictionary<ContinentId, Continent> ()
+        let searchQuery =
+            seq<Listing -> bool> {
+                match search.continentId with
+                | Some contId ->
+                    fun (l : Listing) -> l.continentId = (ContinentId.ofString contId)
+                | None -> ()
+                match search.region with
+                | Some region -> fun (l : Listing) -> l.region.Contains (region, StringComparison.OrdinalIgnoreCase)
+                | None -> ()
+                if search.remoteWork <> "" then
+                    fun (l : Listing) -> l.remoteWork = (search.remoteWork = "yes")
+                // match search.text with
+                // | Some text -> fun (l : Listing) -> l.text.Contains (text, StringComparison.OrdinalIgnoreCase)
+                // | None -> ()
+            }
+            |> Seq.fold
+                   (fun q filter -> Queryable.Where(q, filter))
+                   (session.Query<Listing>()
+                        .Include((fun l -> l.continentId :> obj), continents)
+                        .Where(fun l -> not l.isExpired && not l.isLegacy))
+        let! results = searchQuery.ToListAsync ()
+        return
+            results
+            |> Seq.map (fun l -> { listing = l; continent = continents[l.continentId] })
+            |> List.ofSeq
+    }
+
+/// Success story data access functions
+[<RequireQualifiedAccess>]
+module Successes =
+    
+    /// Save a success story
+    let save (success : Success) = backgroundTask {
+        use session = docSession ()
+        session.Store<Success> success
+        do! session.SaveChangesAsync ()
+    }
+    

src/JobsJobsJobs/JobsJobsJobs.Data/JobsJobsJobs.Data.fsproj

@@ -0,0 +1,24 @@
+<Project Sdk="Microsoft.NET.Sdk">
+
+    <PropertyGroup>
+        <TargetFramework>net6.0</TargetFramework>
+        <GenerateDocumentationFile>true</GenerateDocumentationFile>
+    </PropertyGroup>
+
+    <ItemGroup>
+        <Compile Include="Json.fs" />
+        <Compile Include="Data.fs" />
+    </ItemGroup>
+
+    <ItemGroup>
+      <ProjectReference Include="..\Domain\JobsJobsJobs.Domain.fsproj" />
+    </ItemGroup>
+
+    <ItemGroup>
+      <PackageReference Include="FSharp.SystemTextJson" Version="0.19.13" />
+      <PackageReference Include="Marten" Version="5.8.0" />
+      <PackageReference Include="Marten.NodaTime" Version="5.8.0" />
+      <PackageReference Include="Marten.PLv8" Version="5.8.0" />
+    </ItemGroup>
+
+</Project>

src/JobsJobsJobs/JobsJobsJobs.Data/Json.fs

@@ -0,0 +1,24 @@
+module JobsJobsJobs.Data.Json
+
+open System
+open System.Text.Json
+open System.Text.Json.Serialization
+open JobsJobsJobs.Domain
+
+/// Convert citizen IDs to their string-GUID representation
+type CitizenIdJsonConverter () =
+    inherit JsonConverter<CitizenId> ()
+    override this.Read(reader, _, _) =
+        CitizenId (Guid.Parse (reader.GetString ())) 
+    override this.Write(writer, value, _) =
+        writer.WriteStringValue ((CitizenId.value value).ToString ())
+
+
+/// JsonSerializer options that use the custom converters
+let options =
+    let opts = JsonSerializerOptions ()
+    [   CitizenIdJsonConverter () :> JsonConverter
+        JsonFSharpConverter    ()
+    ]
+    |> List.iter opts.Converters.Add
+    opts

src/JobsJobsJobs/Server/App.fs

@@ -24,13 +24,12 @@ let configureApp (app : IApplicationBuilder) =
 
 open Newtonsoft.Json
 open NodaTime
-open Marten
 open Microsoft.AspNetCore.Authentication.JwtBearer
 open Microsoft.Extensions.Configuration
 open Microsoft.Extensions.Logging
 open Microsoft.IdentityModel.Tokens
 open System.Text
-open JobsJobsJobs.Domain
+open JobsJobsJobs.Data
 open JobsJobsJobs.Domain.SharedTypes
 
 /// Configure dependency injection
@@ -47,6 +46,7 @@ let configureServices (svc : IServiceCollection) =
     let svcs = svc.BuildServiceProvider ()
     let cfg  = svcs.GetRequiredService<IConfiguration> ()
     
+    // Set up JWTs for API access
     let _ =
         svc.AddAuthentication(fun o ->
             o.DefaultAuthenticateScheme <- JwtBearerDefaults.AuthenticationScheme
@@ -68,16 +68,8 @@ let configureServices (svc : IServiceCollection) =
     let log   = svcs.GetRequiredService<ILoggerFactory>().CreateLogger "JobsJobsJobs.Api.Data.Startup"
     let conn  = Data.Startup.createConnection dbCfg log
     let _ = svc.AddSingleton conn |> ignore
-    //Data.Startup.establishEnvironment dbCfg log conn |> Async.AwaitTask |> Async.RunSynchronously
+    // Set up the Marten data store
-    
+    let _ = Connection.setUp cfg
-    let _ =
-        svc.AddMarten(fun (opts : StoreOptions) ->
-            opts.Connection (cfg.GetConnectionString "PostgreSQL")
-            opts.RegisterDocumentTypes [
-                typeof<Citizen>; typeof<Continent>; typeof<Listing>; typeof<Profile>; typeof<SecurityInfo>
-                typeof<Success>
-            ])
-            .UseLightweightSessions()
     ()
 
 [<EntryPoint>]

src/JobsJobsJobs/Server/Handlers.fs

@@ -119,6 +119,7 @@ module Helpers =
 
 
 open System
+open JobsJobsJobs.Data
 
 /// Handlers for /api/citizen routes
 [<RequireQualifiedAccess>]
@@ -171,18 +172,15 @@ module Citizen =
     }
     
     // GET: /api/citizen/[id]
-    let get (citizenId : Guid) : HttpHandler = authorize >=> fun next ctx -> task {
+    let get citizenId : HttpHandler = authorize >=> fun next ctx -> task {
-        use session = querySession ctx
+        match! Citizens.findById (CitizenId citizenId) with
-        match! session.LoadAsync<Citizen> citizenId |> opt with
         | Some citizen -> return! json citizen next ctx
         | None -> return! Error.notFound next ctx
     }
 
     // DELETE: /api/citizen
     let delete : HttpHandler = authorize >=> fun next ctx -> task {
-        use session = docSession ctx
+        do! Citizens.deleteById (currentCitizenId ctx)
-        session.Delete<Citizen> (CitizenId.value (currentCitizenId ctx))
-        do! session.SaveChangesAsync ()
         return! ok next ctx
     }
 
@@ -193,8 +191,7 @@ module Continent =
   
     // GET: /api/continent/all
     let all : HttpHandler = fun next ctx -> task {
-        use session = querySession ctx
+        let! continents = Continents.all ()
-        let! continents = session.Query<Continent>().ToListAsync noCnx
         return! json continents next ctx
     }
 
@@ -224,27 +221,26 @@ module Instances =
 module Listing =
 
     open NodaTime
-    open System
 
     /// Parse the string we receive from JSON into a NodaTime local date
     let private parseDate = DateTime.Parse >> LocalDate.FromDateTime
 
     // GET: /api/listings/mine
     let mine : HttpHandler = authorize >=> fun next ctx -> task {
-        let! listings = Data.Listing.findByCitizen (currentCitizenId ctx) (conn ctx)
+        let! listings = Listings.findByCitizen (currentCitizenId ctx)
         return! json listings next ctx
     }
 
     // GET: /api/listing/[id]
     let get listingId : HttpHandler = authorize >=> fun next ctx -> task {
-        match! Data.Listing.findById (ListingId listingId) (conn ctx) with
+        match! Listings.findById (ListingId listingId) with
         | Some listing -> return! json listing next ctx
         | None -> return! Error.notFound next ctx
     }
   
     // GET: /api/listing/view/[id]
     let view listingId : HttpHandler = authorize >=> fun next ctx -> task {
-        match! Data.Listing.findByIdForView (ListingId listingId) (conn ctx) with
+        match! Listings.findByIdForView (ListingId listingId) with
         | Some listing -> return! json listing next ctx
         | None -> return! Error.notFound next ctx
     }
@@ -253,8 +249,7 @@ module Listing =
     let add : HttpHandler = authorize >=> fun next ctx -> task {
         let! form = ctx.BindJsonAsync<ListingForm> ()
         let  now  = (clock ctx).GetCurrentInstant ()
-        use  session = docSession ctx
+        do! Listings.save {
-        session.Store<Listing>({
             id            = ListingId.create ()
             citizenId     = currentCitizenId ctx
             createdOn     = now
@@ -268,19 +263,18 @@ module Listing =
             neededBy      = (form.neededBy |> Option.map parseDate)
             wasFilledHere = None
             isLegacy      = false
-        })
+        }
-        do! session.SaveChangesAsync ()
         return! ok next ctx
     }
 
     // PUT: /api/listing/[id]
     let update listingId : HttpHandler = authorize >=> fun next ctx -> task {
         let dbConn = conn ctx
-        match! Data.Listing.findById (ListingId listingId) dbConn with
+        match! Listings.findById (ListingId listingId) with
         | Some listing when listing.citizenId <> (currentCitizenId ctx) -> return! Error.notAuthorized next ctx
         | Some listing ->
             let! form = ctx.BindJsonAsync<ListingForm> ()
-            do! Data.Listing.update
+            do! Listings.save
                     { listing with
                         title       = form.title
                         continentId = ContinentId.ofString form.continentId
@@ -289,7 +283,7 @@ module Listing =
                         text        = Text form.text
                         neededBy    = form.neededBy |> Option.map parseDate
                         updatedOn   = (clock ctx).GetCurrentInstant ()
-                    } dbConn
+                    }
             return! ok next ctx
         | None -> return! Error.notFound next ctx
       }
@@ -298,21 +292,26 @@ module Listing =
     let expire listingId : HttpHandler = authorize >=> fun next ctx -> task {
         let dbConn = conn ctx
         let now    = clock(ctx).GetCurrentInstant ()
-        match! Data.Listing.findById (ListingId listingId) dbConn with
+        match! Listings.findById (ListingId listingId) with
         | Some listing when listing.citizenId <> (currentCitizenId ctx) -> return! Error.notAuthorized next ctx
         | Some listing ->
             let! form = ctx.BindJsonAsync<ListingExpireForm> ()
-            do! Data.Listing.expire listing.id form.fromHere now dbConn
+            do! Listings.save
+                    { listing with
+                        isExpired     = true
+                        wasFilledHere = Some form.fromHere
+                        updatedOn     = now
+                    }
             match form.successStory with
             | Some storyText ->
-                do! Data.Success.save
+                do! Successes.save
                         { id         = SuccessId.create()
                           citizenId  = currentCitizenId ctx
                           recordedOn = now
                           fromHere   = form.fromHere
                           source     = "listing"
                           story      = (Text >> Some) storyText
-                          } dbConn
+                          }
             | None -> ()
             return! ok next ctx
         | None -> return! Error.notFound next ctx
@@ -321,7 +320,7 @@ module Listing =
     // GET: /api/listing/search
     let search : HttpHandler = authorize >=> fun next ctx -> task {
         let  search  = ctx.BindQueryString<ListingSearch> ()
-        let! results = Data.Listing.search search (conn ctx)
+        let! results = Listings.search search
         return! json results next ctx
     }
   

src/JobsJobsJobs/Server/JobsJobsJobs.Server.fsproj

@@ -16,6 +16,7 @@
   
   <ItemGroup>
     <ProjectReference Include="..\Domain\JobsJobsJobs.Domain.fsproj" />
+    <ProjectReference Include="..\JobsJobsJobs.Data\JobsJobsJobs.Data.fsproj" />
   </ItemGroup>
 
   <ItemGroup>
@@ -24,9 +25,6 @@
   
   <ItemGroup>
     <PackageReference Include="Giraffe" Version="6.0.0" />
-    <PackageReference Include="Marten" Version="5.8.0" />
-    <PackageReference Include="Marten.NodaTime" Version="5.8.0" />
-    <PackageReference Include="Marten.PLv8" Version="5.8.0" />
     <PackageReference Include="Microsoft.AspNetCore.Authentication.JwtBearer" Version="6.0.6" />
     <PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
     <PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.0.0" />