From f778df8e1de2908ccc927d1d94f7d5fe31a9e405 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 8 Jan 2023 21:41:29 -0500 Subject: [PATCH] Log on / log off works - Messages are not showing - Add sessions --- src/JobsJobsJobs/Data/Cache.fs | 231 ++++++++++++++++++ src/JobsJobsJobs/Data/Data.fs | 4 +- .../Data/JobsJobsJobs.Data.fsproj | 1 + src/JobsJobsJobs/Server/App.fs | 110 ++++----- src/JobsJobsJobs/Server/Auth.fs | 2 +- src/JobsJobsJobs/Server/Email.fs | 2 +- src/JobsJobsJobs/Server/Handlers.fs | 204 ++++++++++++---- src/JobsJobsJobs/Server/ViewModels.fs | 4 + src/JobsJobsJobs/Server/Views/Citizen.fs | 5 +- src/JobsJobsJobs/Server/Views/Layout.fs | 2 +- src/JobsJobsJobs/Server/wwwroot/script.js | 1 + src/JobsJobsJobs/Server/wwwroot/style.css | 2 +- 12 files changed, 457 insertions(+), 111 deletions(-) create mode 100644 src/JobsJobsJobs/Data/Cache.fs diff --git a/src/JobsJobsJobs/Data/Cache.fs b/src/JobsJobsJobs/Data/Cache.fs new file mode 100644 index 0000000..53064d9 --- /dev/null +++ b/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 +[] +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 "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! _ = + 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 diff --git a/src/JobsJobsJobs/Data/Data.fs b/src/JobsJobsJobs/Data/Data.fs index f8d398f..47f4ec8 100644 --- a/src/JobsJobsJobs/Data/Data.fs +++ b/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 () } diff --git a/src/JobsJobsJobs/Data/JobsJobsJobs.Data.fsproj b/src/JobsJobsJobs/Data/JobsJobsJobs.Data.fsproj index 7274c80..18d9762 100644 --- a/src/JobsJobsJobs/Data/JobsJobsJobs.Data.fsproj +++ b/src/JobsJobsJobs/Data/JobsJobsJobs.Data.fsproj @@ -7,6 +7,7 @@ + diff --git a/src/JobsJobsJobs/Server/App.fs b/src/JobsJobsJobs/Server/App.fs index 0bf3407..977515c 100644 --- a/src/JobsJobsJobs/Server/App.fs +++ b/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 + + +[] +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 SystemClock.Instance let _ = svc.AddLogging () let _ = svc.AddCors () - let _ = svc.AddSingleton (SystemTextJson.Serializer Json.options) - let cfg = svc.BuildServiceProvider().GetRequiredService () - - // 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(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 (cfg.GetSection "Auth") + let _ = svc.AddAntiforgery () // Set up the data store + let cfg = svc.BuildServiceProvider().GetRequiredService () let _ = DataConnection.setUp cfg |> Async.AwaitTask |> Async.RunSynchronously - () + let _ = svc.AddSingleton (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 () -[] -let main _ = - Host.CreateDefaultBuilder() - .ConfigureWebHostDefaults(fun webHostBuilder -> - webHostBuilder - .Configure(configureApp) - .ConfigureServices(configureServices) - |> ignore) - .Build() - .Run () 0 diff --git a/src/JobsJobsJobs/Server/Auth.fs b/src/JobsJobsJobs/Server/Auth.fs index ca2e6a2..707dcc2 100644 --- a/src/JobsJobsJobs/Server/Auth.fs +++ b/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 diff --git a/src/JobsJobsJobs/Server/Email.fs b/src/JobsJobsJobs/Server/Email.fs index 86aef47..8ceb611 100644 --- a/src/JobsJobsJobs/Server/Email.fs +++ b/src/JobsJobsJobs/Server/Email.fs @@ -1,4 +1,4 @@ -module JobsJobsJobs.Api.Email +module JobsJobsJobs.Server.Email open System.Net open JobsJobsJobs.Domain diff --git a/src/JobsJobsJobs/Server/Handlers.fs b/src/JobsJobsJobs/Server/Handlers.fs index ce41142..059046b 100644 --- a/src/JobsJobsJobs/Server/Handlers.fs +++ b/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 @@ -39,10 +42,22 @@ module Error = log.LogInformation "Returning 404" 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 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 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,9 +175,18 @@ 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 { match! (antiForgery ctx).IsRequestValidAsync ctx with @@ -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 [] 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 () - + let! form = ctx.BindFormAsync () 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 ("
  • ", errors) - return! (sendError $"Please correct the following errors:
    • {errMsg}
    " >=> refreshPage ()) - next ctx + do! addError $"Please correct the following errors:
    • {errMsg}
    " ctx + return! refreshPage () next ctx } + /// Handlers for /api/citizen routes [] 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 ] diff --git a/src/JobsJobsJobs/Server/ViewModels.fs b/src/JobsJobsJobs/Server/ViewModels.fs index 5da311b..8f4aea0 100644 --- a/src/JobsJobsJobs/Server/ViewModels.fs +++ b/src/JobsJobsJobs/Server/ViewModels.fs @@ -2,6 +2,7 @@ module JobsJobsJobs.ViewModels /// View model for the log on page +[] 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 } diff --git a/src/JobsJobsJobs/Server/Views/Citizen.fs b/src/JobsJobsJobs/Server/Views/Citizen.fs index 963c0d6..a58df6f 100644 --- a/src/JobsJobsJobs/Server/Views/Citizen.fs +++ b/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" diff --git a/src/JobsJobsJobs/Server/Views/Layout.fs b/src/JobsJobsJobs/Server/Views/Layout.fs index 72f70b5..ac1d0a6 100644 --- a/src/JobsJobsJobs/Server/Views/Layout.fs +++ b/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" diff --git a/src/JobsJobsJobs/Server/wwwroot/script.js b/src/JobsJobsJobs/Server/wwwroot/script.js index 635707a..538f608 100644 --- a/src/JobsJobsJobs/Server/wwwroot/script.js +++ b/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")) } diff --git a/src/JobsJobsJobs/Server/wwwroot/style.css b/src/JobsJobsJobs/Server/wwwroot/style.css index 28679a0..a2cf30d 100644 --- a/src/JobsJobsJobs/Server/wwwroot/style.css +++ b/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;