src/JobsJobsJobs/Data/Cache.fs

@@ -0,0 +1,231 @@
+namespace JobsJobsJobs.Data
+
+open System.Threading
+open System.Threading.Tasks
+open Microsoft.Extensions.Caching.Distributed
+open NodaTime
+open Npgsql.FSharp
+
+/// Helper types and functions for the cache
+[<AutoOpen>]
+module private CacheHelpers =
+    
+    open System
+    open Npgsql
+
+    /// 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 ()
+    
+    /// Get the first result of the given query
+    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))
+    
+    /// 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)
+        p.ParameterName, Sql.parameter p
+    
+    /// Create a parameter for the expire-at time
+    let expireParam =
+        typedParam "expireAt"
+
+open DataConnection
+
+/// A distributed cache implementation in PostgreSQL used to handle sessions for myWebLog
+type DistributedCache () =
+    
+    // ~~~ INITIALIZATION ~~~
+    
+    do
+        task {
+            let conn = connection ()
+            let! exists =
+                conn
+                |> Sql.query $"
+                    SELECT EXISTS
+                        (SELECT 1 FROM pg_tables WHERE schemaname = 'public' AND tablename = 'session')
+                      AS does_exist"
+                |> Sql.executeRowAsync (fun row -> row.bool "does_exist")
+            if not exists then
+                let! _ =
+                    conn
+                    |> Sql.query
+                        "CREATE TABLE session (
+                            id                  TEXT        NOT NULL PRIMARY KEY,
+                            payload             BYTEA       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 conn = connection ()
+        let idParam = "@id", Sql.string key
+        let! tryEntry =
+            conn
+            |> 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! _ =
+                    conn
+                    |> 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! _ =
+                connection ()
+                |> 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! _ =
+            connection ()
+            |> 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! _ =
+            connection ()
+            |> 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 _.Get key = get key CancellationToken.None |> sync
+        member _.GetAsync (key, token) = get key token
+        member _.Refresh key = refresh key CancellationToken.None |> sync
+        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

src/JobsJobsJobs/Data/Data.fs

@@ -73,7 +73,9 @@ module DataConnection =
     
     /// Set up the data connection from the given configuration
     let setUp (cfg : IConfiguration) = backgroundTask {
-        dataSource <- Some (NpgsqlDataSource.Create (cfg.GetConnectionString "PostgreSQL"))
+        let builder = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PostgreSQL")
+        let _ = builder.UseNodaTime ()
+        dataSource <- Some (builder.Build ())
         do! createTables ()
     }
 

src/JobsJobsJobs/Data/JobsJobsJobs.Data.fsproj

@@ -7,6 +7,7 @@
     <ItemGroup>
         <Compile Include="Json.fs" />
         <Compile Include="Data.fs" />
+        <Compile Include="Cache.fs" />
     </ItemGroup>
 
     <ItemGroup>

src/JobsJobsJobs/Server/App.fs

@@ -1,74 +1,68 @@
-/// The main API application for Jobs, Jobs, Jobs
-module JobsJobsJobs.Api.App
+/// The main web server application for Jobs, Jobs, Jobs
+module JobsJobsJobs.Server.App
 
-open Microsoft.AspNetCore.Builder
-open Microsoft.AspNetCore.Hosting
-open Microsoft.Extensions.DependencyInjection
-open Microsoft.Extensions.Hosting
+open System
+open System.Text
 open Giraffe
 open Giraffe.EndpointRouting
-
-/// Configure the ASP.NET Core pipeline to use Giraffe
-let configureApp (app : IApplicationBuilder) =
-    app.UseCors(fun p -> p.AllowAnyOrigin().AllowAnyHeader() |> ignore)
-        .UseStaticFiles()
-        .UseRouting()
-        .UseAuthentication()
-        .UseAuthorization()
-        .UseGiraffeErrorHandler(Handlers.Error.unexpectedError)
-        .UseEndpoints(fun e ->
-            e.MapGiraffeEndpoints Handlers.allEndpoints
-            e.MapFallbackToFile "index.html" |> ignore)
-    |> ignore
-
-open System.Text
-open Microsoft.AspNetCore.Authentication.JwtBearer
-open Microsoft.Extensions.Configuration
-open Microsoft.IdentityModel.Tokens
-open NodaTime
 open JobsJobsJobs.Data
-open JobsJobsJobs.Domain.SharedTypes
+open Microsoft.AspNetCore.Authentication.Cookies
+open Microsoft.AspNetCore.Builder
+open Microsoft.AspNetCore.Http
+open Microsoft.AspNetCore.HttpOverrides
+open Microsoft.Extensions.Caching.Distributed
+open Microsoft.Extensions.Configuration
+open Microsoft.Extensions.DependencyInjection
+open Microsoft.Extensions.Hosting
+open NodaTime
+
+
+[<EntryPoint>]
+let main args =
+    
+    let builder = WebApplication.CreateBuilder args
+    let svc     = builder.Services
 
-/// Configure dependency injection
-let configureServices (svc : IServiceCollection) =
     let _ = svc.AddGiraffe ()
     let _ = svc.AddSingleton<IClock> SystemClock.Instance
     let _ = svc.AddLogging ()
     let _ = svc.AddCors ()
-    
     let _ = svc.AddSingleton<Json.ISerializer> (SystemTextJson.Serializer Json.options)
-    let cfg = svc.BuildServiceProvider().GetRequiredService<IConfiguration> ()
-    
-    // Set up JWTs for API access
-    let _ =
-        svc.AddAuthentication(fun o ->
-            o.DefaultAuthenticateScheme <- JwtBearerDefaults.AuthenticationScheme
-            o.DefaultChallengeScheme    <- JwtBearerDefaults.AuthenticationScheme
-            o.DefaultScheme             <- JwtBearerDefaults.AuthenticationScheme)
-            .AddJwtBearer(fun opt ->
-                opt.RequireHttpsMetadata      <- false
-                opt.TokenValidationParameters <- TokenValidationParameters (
-                    ValidateIssuer   = true,
-                    ValidateAudience = true,
-                    ValidAudience    = "https://noagendacareers.com",
-                    ValidIssuer      = "https://noagendacareers.com",
-                    IssuerSigningKey = SymmetricSecurityKey (
-                        Encoding.UTF8.GetBytes (cfg.GetSection "Auth").["ServerSecret"])))
+    let _ = svc.Configure<ForwardedHeadersOptions>(fun (opts : ForwardedHeadersOptions) ->
+                opts.ForwardedHeaders <- ForwardedHeaders.XForwardedFor ||| ForwardedHeaders.XForwardedProto)
+    let _ = svc.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme)
+                .AddCookie(fun o ->
+                    o.ExpireTimeSpan    <- TimeSpan.FromMinutes 60
+                    o.SlidingExpiration <- true
+                    o.AccessDeniedPath  <- "/error/not-authorized"
+                    o.ClaimsIssuer      <- "https://noagendacareers.com")
     let _ = svc.AddAuthorization ()
-    let _ = svc.Configure<AuthOptions> (cfg.GetSection "Auth")
+    let _ = svc.AddAntiforgery ()
     
     // Set up the data store
+    let cfg = svc.BuildServiceProvider().GetRequiredService<IConfiguration> ()
     let _ = DataConnection.setUp cfg |> Async.AwaitTask |> Async.RunSynchronously
-    ()
+    let _ = svc.AddSingleton<IDistributedCache> (fun _ -> DistributedCache () :> IDistributedCache)
+    let _ = svc.AddSession(fun opts ->
+                opts.IdleTimeout        <- TimeSpan.FromMinutes 60
+                opts.Cookie.HttpOnly    <- true
+                opts.Cookie.IsEssential <- true)
+    
+    let app = builder.Build ()
+
+    let _ = app.UseForwardedHeaders ()
+    let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
+    let _ = app.UseStaticFiles ()
+    let _ = app.UseRouting ()
+    let _ = app.UseAuthentication ()
+    let _ = app.UseAuthorization ()
+    let _ = app.UseSession ()
+    let _ = app.UseGiraffeErrorHandler Handlers.Error.unexpectedError
+    let _ = app.UseEndpoints (
+        fun e ->
+            e.MapGiraffeEndpoints Handlers.allEndpoints
+            e.MapFallbackToFile "index.html" |> ignore)
+
+    app.Run ()
 
-[<EntryPoint>]
-let main _ =
-    Host.CreateDefaultBuilder()
-        .ConfigureWebHostDefaults(fun webHostBuilder ->
-            webHostBuilder
-                .Configure(configureApp)
-                .ConfigureServices(configureServices)
-            |> ignore)
-        .Build()
-        .Run ()
     0

src/JobsJobsJobs/Server/Auth.fs

@@ -1,5 +1,5 @@
 /// Authorization / authentication functions
-module JobsJobsJobs.Api.Auth
+module JobsJobsJobs.Server.Auth
 
 open System
 open System.Text

src/JobsJobsJobs/Server/Email.fs

@@ -1,4 +1,4 @@
-module JobsJobsJobs.Api.Email
+module JobsJobsJobs.Server.Email
 
 open System.Net
 open JobsJobsJobs.Domain

src/JobsJobsJobs/Server/Handlers.fs

@@ -1,5 +1,5 @@
 /// Route handlers for Giraffe endpoints
-module JobsJobsJobs.Api.Handlers
+module JobsJobsJobs.Server.Handlers
 
 open Giraffe
 open JobsJobsJobs.Domain
@@ -15,9 +15,12 @@ module Vue =
     let app = htmlFile "wwwroot/index.html"
 
 
+open Giraffe.Htmx
+
 /// Handlers for error conditions
 module Error =
   
+    open System.Net
     open System.Threading.Tasks
 
     /// URL prefixes for the Vue app
@@ -40,9 +43,21 @@ module Error =
             return! RequestErrors.NOT_FOUND $"The URL {path} was not recognized as a valid URL" next ctx
     }
     
-    /// Handler that returns a 403 NOT AUTHORIZED response
-    let notAuthorized : HttpHandler =
-        setStatusCode 403 >=> fun _ _ -> Task.FromResult<HttpContext option> None
+    /// Is the request from htmx?
+    let isHtmx (ctx : HttpContext) =
+        ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
+    
+    /// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response
+    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 >=> redirectTo false redirectUrl) next ctx
+            else redirectTo false redirectUrl next ctx
+        else
+            if isHtmx ctx then
+                (setHttpHeader "X-Toast" $"error|||You are not authorized to access the URL {ctx.Request.Path.Value}"
+                 >=> setStatusCode 401) earlyReturn ctx
+            else setStatusCode 401 earlyReturn ctx
 
     /// Handler to log 500s and return a message we can display in the application
     let unexpectedError (ex: exn) (log : ILogger) =
@@ -57,7 +72,7 @@ open NodaTime
 module Helpers =
 
     open System.Security.Claims
-    open Giraffe.Htmx
+    open System.Text.Json
     open Microsoft.AspNetCore.Antiforgery
     open Microsoft.Extensions.Configuration
     open Microsoft.Extensions.DependencyInjection
@@ -108,16 +123,51 @@ module Helpers =
     let csrf ctx =
         (antiForgery ctx).GetAndStoreTokens ctx
     
+    /// The key to use to indicate if we have loaded the session
+    let private sessionLoadedKey = "session-loaded"
+
+    /// Load the session if we have not yet
+    let private loadSession (ctx : HttpContext) = task {
+        if not (ctx.Items.ContainsKey sessionLoadedKey) then
+            do! ctx.Session.LoadAsync ()
+            ctx.Items.Add (sessionLoadedKey, "yes")
+    }
+
+    /// Save the session if we have loaded it
+    let private saveSession (ctx : HttpContext) = task {
+        if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync ()
+    }
+
+    /// Get the messages from the session (destructively)
+    let messages ctx = task {
+        do! loadSession ctx
+        let msgs =
+            match ctx.Session.GetString "messages" with
+            | null -> []
+            | m -> JsonSerializer.Deserialize<string list> m
+        if not (List.isEmpty msgs) then ctx.Session.Remove "messages"
+        return List.rev msgs
+    }
+
     /// Add a message to the response
-    let sendMessage (msg : string) : HttpHandler =
-        setHttpHeader "X-Message" msg
+    let addMessage (level : string) (msg : string) ctx = task {
+        do! loadSession ctx
+        let! msgs = messages ctx
+        ctx.Session.SetString ("messages", JsonSerializer.Serialize ($"{level}|||{msg}" :: msgs))
+    }
+    
+    /// Add a success message to the response
+    let addSuccess msg ctx = task {
+        do! addMessage "success" msg ctx
+    }
     
     /// Add an error message to the response
-    let sendError (msg : string) : HttpHandler =
-        sendMessage $"error|||{msg}"
+    let addError msg ctx = task {
+        do! addMessage "error" msg ctx
+    }
     
     /// Render a page-level view
-    let render pageTitle content : HttpHandler = fun _ ctx -> task {
+    let render pageTitle (next : HttpFunc) (ctx : HttpContext) content = task {
         let renderFunc = if ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh then Layout.partial else Layout.full
         let renderCtx : Layout.PageRenderContext = {
             IsLoggedOn = Option.isSome (tryUser ctx)
@@ -125,8 +175,17 @@ module Helpers =
             PageTitle  = pageTitle
             Content    = content
         }
-        return! ctx.WriteHtmlViewAsync (renderFunc renderCtx)
+        let! msgs = messages ctx
+        let! newCtx = task {
+            if List.isEmpty msgs then return Some ctx
+            else return! (msgs |> List.map (fun m -> setHttpHeader "X-Toast" m) |> List.reduce (>=>)) next ctx
         }
+        return! newCtx.Value.WriteHtmlViewAsync (renderFunc renderCtx)
+    }
+
+    /// Render as a composable HttpHandler
+    let renderHandler pageTitle content : HttpHandler = fun next ctx ->
+        render pageTitle next ctx content
 
     /// Validate the anti cross-site request forgery token in the current request
     let validateCsrf : HttpHandler = fun next ctx -> task {
@@ -135,16 +194,42 @@ module Helpers =
         | false -> return! RequestErrors.BAD_REQUEST "CSRF token invalid" earlyReturn ctx
     }
 
+    /// Require a user to be logged on for a route
+    let requireUser = requiresAuthentication Error.notAuthorized
+    
+    /// Is the request from htmx?
+    // TODO: need to only define this once
+    let isHtmx (ctx : HttpContext) =
+        ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
+
+    /// Redirect to another page, saving the session before redirecting
+    let redirectToGet (url : string) next ctx = task {
+        do! saveSession ctx
+        let action =
+            if     not (isNull url)
+                && not (url = "")
+                        // "/" or "/foo" but not "//" or "/\"
+                && (   (url[0] = '/' && (url.Length = 1 || (url[1] <> '/' && url[1] <> '\\')))
+                        // "~/" or "~/foo"
+                    || (url.Length > 1 && url[0] = '~' && url[1] = '/')) then
+                if isHtmx ctx then withHxRedirect url else redirectTo false url
+            else RequestErrors.BAD_REQUEST ""
+        return! action next ctx
+    }
+
 
 open System
 open JobsJobsJobs.Data
 open JobsJobsJobs.ViewModels
 
+
 /// Handlers for /citizen routes
 [<RequireQualifiedAccess>]
 module Citizen =
     
-    open Microsoft.Extensions.Configuration
+    open Microsoft.AspNetCore.Authentication
+    open Microsoft.AspNetCore.Authentication.Cookies
+    open System.Security.Claims
 
     /// Support module for /citizen routes
     module private Support =
@@ -169,49 +254,71 @@ module Citizen =
                 qAndA
         
     // GET: /citizen/confirm/[token]
-    let confirm token = fun next ctx -> task {
+    let confirm token next ctx = task {
         let! isConfirmed = Citizens.confirmAccount token
-        return! render "Account Confirmation" (Citizen.confirmAccount isConfirmed) next ctx
+        return! Citizen.confirmAccount isConfirmed |> render "Account Confirmation" next ctx
+    }
+
+    // GET: /citizen/dashboard
+    let dashboard = requireUser >=> fun next ctx -> task {
+        let  citizenId = CitizenId.ofString (tryUser ctx).Value
+        let! citizen   = Citizens.findById citizenId
+        let! profile   = Profiles.findById citizenId
+        let! prfCount  = Profiles.count ()
+        return! Citizen.dashboard citizen.Value profile prfCount |> render "Dashboard" next ctx
     }
 
     // GET: /citizen/deny/[token]
-    let deny token = fun next ctx -> task {
+    let deny token next ctx = task {
         let! wasDeleted = Citizens.denyAccount token
-        return! render "Account Deletion" (Citizen.denyAccount wasDeleted) next ctx
+        return! Citizen.denyAccount wasDeleted |> render "Account Deletion" next ctx
+    }
+
+    // GET: /citizen/log-off
+    let logOff = requireUser >=> fun next ctx -> task {
+        do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
+        do! addSuccess "Log off successful" ctx
+        return! redirectToGet "/" next ctx
     }
 
     // GET: /citizen/log-on
     let logOn : HttpHandler = fun next ctx ->
-        render "Log On" (Citizen.logOn { ErrorMessage = None; Email = ""; Password = "" } (csrf ctx)) next ctx
+        let returnTo =
+            if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None
+        Citizen.logOn { ErrorMessage = None; Email = ""; Password = ""; ReturnTo = returnTo } (csrf ctx)
+        |> render "Log On" next ctx
 
     // POST: /citizen/log-on
-    // TODO: convert
     let doLogOn = validateCsrf >=> fun next ctx -> task {
-        let! form = ctx.BindJsonAsync<LogOnForm> ()
-        
+        let! form = ctx.BindFormAsync<LogOnViewModel> ()
         match! Citizens.tryLogOn form.Email form.Password Auth.Passwords.verify Auth.Passwords.hash (now ctx) with
         | Ok citizen ->
-            return!
-                json
-                    { Jwt       = Auth.createJwt citizen (authConfig ctx)
-                      CitizenId = CitizenId.toString citizen.Id
-                      Name      = Citizen.name citizen
-                    } next ctx
-        | Error msg -> return! RequestErrors.BAD_REQUEST msg next ctx
+            let claims = seq {
+                Claim (ClaimTypes.NameIdentifier, CitizenId.toString citizen.Id)
+                Claim (ClaimTypes.Name,           Citizen.name citizen)
+            }
+            let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme)
+
+            do! ctx.SignInAsync (identity.AuthenticationType, ClaimsPrincipal identity,
+                AuthenticationProperties (IssuedUtc = DateTimeOffset.UtcNow))
+            do! addSuccess "Log on successful" ctx
+            return! redirectToGet (defaultArg form.ReturnTo "/citizen/dashboard") next ctx
+        | Error msg ->
+            do! addError msg ctx
+            return! Citizen.logOn { form with Password = "" } (csrf ctx) |> render "Log On" next ctx
     }
 
     // GET: /citizen/register
-    let register : HttpHandler = fun next ctx ->
+    let register next ctx =
         // Get two different indexes for NA-knowledge challenge questions
         let q1Index = System.Random.Shared.Next(0, 5)
         let mutable q2Index = System.Random.Shared.Next(0, 5)
         while q1Index = q2Index do
             q2Index <- System.Random.Shared.Next(0, 5)
         let qAndA = Support.questions ctx
-        render "Register"
-            (Citizen.register (fst qAndA[q1Index]) (fst qAndA[q2Index])
-                { RegisterViewModel.empty with Question1Index = q1Index; Question2Index = q2Index } (csrf ctx)) next ctx
-    
+        Citizen.register (fst qAndA[q1Index]) (fst qAndA[q2Index])
+            { RegisterViewModel.empty with Question1Index = q1Index; Question2Index = q2Index } (csrf ctx)
+        |> render "Register" next ctx
     
     // POST: /citizen/register
     let doRegistration = validateCsrf >=> fun next ctx -> task {
@@ -232,12 +339,12 @@ module Citizen =
                  "Question answers are incorrect"
         ]
         let refreshPage () =
-            render "Register"
-                (Citizen.register (fst qAndA[form.Question1Index]) (fst qAndA[form.Question2Index])
-                    { form with Password = "" } (csrf ctx))
+            Citizen.register (fst qAndA[form.Question1Index]) (fst qAndA[form.Question2Index])
+                    { form with Password = "" } (csrf ctx) |> renderHandler "Register"
+                
         if badForm then
-            let handle = sendError "The form posted was invalid; please complete it again" >=> register
-            return! handle next ctx
+            do! addError "The form posted was invalid; please complete it again" ctx
+            return! register next ctx
         else if List.isEmpty errors then
             let now    = now ctx
             let noPass =
@@ -265,16 +372,17 @@ module Citizen =
                 let  logFac        = logger ctx
                 let  log           = logFac.CreateLogger "JobsJobsJobs.Handlers.Citizen"
                 log.LogInformation $"Confirmation e-mail for {citizen.Email} received {emailResponse}"
-                return! render "Registration Successful" Citizen.registered next ctx
+                return! Citizen.registered |> render "Registration Successful" next ctx
             else
-                return! (sendError "There is already an account registered to the e-mail address provided"
-                         >=> refreshPage ()) next ctx
+                do! addError "There is already an account registered to the e-mail address provided" ctx
+                return! refreshPage () next ctx
         else
             let errMsg = String.Join ("</li><li>", errors)
-            return! (sendError $"Please correct the following errors:<ul><li>{errMsg}</li></ul>" >=> refreshPage ())
-                    next ctx
+            do! addError $"Please correct the following errors:<ul><li>{errMsg}</li></ul>" ctx
+            return! refreshPage () next ctx
     }
 
+
 /// Handlers for /api/citizen routes
 [<RequireQualifiedAccess>]
 module CitizenApi =
@@ -338,19 +446,19 @@ module Home =
 
     // GET: /
     let home : HttpHandler =
-        render "Welcome" Home.home
+        renderHandler "Welcome" Home.home
 
     // GET: /how-it-works
     let howItWorks : HttpHandler =
-        render "How It Works" Home.howItWorks
+        renderHandler "How It Works" Home.howItWorks
     
     // GET: /privacy-policy
     let privacyPolicy : HttpHandler =
-        render "Privacy Policy" Home.privacyPolicy
+        renderHandler "Privacy Policy" Home.privacyPolicy
     
     // GET: /terms-of-service
     let termsOfService : HttpHandler =
-        render "Terms of Service" Home.termsOfService
+        renderHandler "Terms of Service" Home.termsOfService
 
 
 /// Handlers for /api/listing[s] routes
@@ -608,7 +716,9 @@ let allEndpoints = [
     subRoute "/citizen" [
         GET_HEAD [
             routef "/confirm/%s" Citizen.confirm
+            route  "/dashboard"  Citizen.dashboard
             routef "/deny/%s"    Citizen.deny
+            route  "/log-off"    Citizen.logOff
             route  "/log-on"     Citizen.logOn
             route  "/register"   Citizen.register
         ]

src/JobsJobsJobs/Server/ViewModels.fs

@@ -2,6 +2,7 @@
 module JobsJobsJobs.ViewModels
 
 /// View model for the log on page
+[<CLIMutable>]
 type LogOnViewModel =
     {   /// A message regarding an error encountered during a log on attempt
         ErrorMessage : string option
@@ -11,6 +12,9 @@ type LogOnViewModel =
 
         /// The password of the user attempting to log on
         Password : string
+
+        /// The URL where the user should be redirected after logging on
+        ReturnTo : string option
     }
 
 

src/JobsJobsJobs/Server/Views/Citizen.fs

@@ -68,7 +68,7 @@ let dashboard (citizen : Citizen) (profile : Profile option) profileCount =
                     h5 [ _class "card-header" ] [ rawText "Other Citizens" ]
                     div [ _class "card-body" ] [
                         h6 [ _class "card-subtitle mb-3 text-muted fst-italic" ] [
-                            rawText (if profileCount = 0 then "No" else $"{profileCount} Total")
+                            rawText (if profileCount = 0L then "No" else $"{profileCount} Total")
                             rawText " Employment Profile"; rawText (if profileCount <> 1 then "s" else "")
                         ]
                         p [ _class "card-text" ] [
@@ -123,6 +123,9 @@ let logOn (m : LogOnViewModel) csrf =
         | None -> ()
         form [ _class "row g-3 pb-3"; _hxPost "/citizen/log-on" ] [
             antiForgery csrf
+            match m.ReturnTo with
+            | Some returnTo -> input [ _type "hidden"; _name (nameof m.ReturnTo); _value returnTo ]
+            | None -> ()
             div [ _class "col-12 col-md-6" ] [
                 div [ _class "form-floating" ] [
                     input [ _type        "email"

src/JobsJobsJobs/Server/Views/Layout.fs

@@ -63,7 +63,7 @@ let private links ctx =
             navLink "/listings/mine"   "sign-text"    "My Job Listings"
             navLink "/profile/edit"    "pencil"       "My Employment Profile"
             div [ _class "separator" ] []
-            navLink "/citizen/log-off" "mdiLogoutVariant" "Log Off"
+            navLink "/citizen/log-off" "logout-variant" "Log Off"
         else
             navLink "/"                "home"              "Home"
             navLink "/profile/seeking" "view-list-outline" "Job Seekers"

src/JobsJobsJobs/Server/wwwroot/script.js

@@ -76,6 +76,7 @@ this.jjj = {
 htmx.on("htmx:afterOnLoad", function (evt) {
   const hdrs = evt.detail.xhr.getAllResponseHeaders()
   // Show a message if there was one in the response
+  console.info(`Here are the headers: ${hdrs}`)
   if (hdrs.indexOf("x-toast") >= 0) {
     jjj.showToast(evt.detail.xhr.getResponseHeader("x-toast"))
   }

src/JobsJobsJobs/Server/wwwroot/style.css

@@ -155,7 +155,7 @@ nav.jjj-nav > a {
 }
 nav.jjj-nav > a > i {
   vertical-align: top;
-  margin-right: 1rem;
+  margin-right: .25rem;
 }
 nav.jjj-nav > a > i.mdi::before {
   line-height: 24px;