diff --git a/src/PrayerTracker/App.fs b/src/PrayerTracker/App.fs index 7858a73..4b58bc8 100644 --- a/src/PrayerTracker/App.fs +++ b/src/PrayerTracker/App.fs @@ -7,20 +7,7 @@ open Microsoft.AspNetCore.Hosting [] module Configure = - open Cookies - open Giraffe - open Giraffe.EndpointRouting - open Microsoft.AspNetCore.Localization - open Microsoft.AspNetCore.Server.Kestrel.Core - open Microsoft.EntityFrameworkCore open Microsoft.Extensions.Configuration - open Microsoft.Extensions.DependencyInjection - open Microsoft.Extensions.Hosting - open Microsoft.Extensions.Localization - open Microsoft.Extensions.Logging - open Microsoft.Extensions.Options - open NodaTime - open System.Globalization /// Set up the configuration for the app let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) = @@ -30,10 +17,21 @@ module Configure = .AddEnvironmentVariables() |> ignore + open Microsoft.AspNetCore.Server.Kestrel.Core + /// Configure Kestrel from appsettings.json let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) = (ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel" + open System + open System.Globalization + open Microsoft.AspNetCore.Authentication.Cookies + open Microsoft.AspNetCore.Localization + open Microsoft.EntityFrameworkCore + open Microsoft.Extensions.DependencyInjection + open NodaTime + + /// Configure ASP.NET Core's service collection (dependency injection container) let services (svc : IServiceCollection) = let _ = svc.AddOptions() let _ = svc.AddLocalization(fun options -> options.ResourcesPath <- "Resources") @@ -46,6 +44,12 @@ module Configure = opts.DefaultRequestCulture <- RequestCulture ("en-US", "en-US") opts.SupportedCultures <- supportedCultures opts.SupportedUICultures <- supportedCultures) + let _ = + svc.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme) + .AddCookie(fun opts -> + opts.ExpireTimeSpan <- TimeSpan.FromMinutes 120. + opts.SlidingExpiration <- true + opts.AccessDeniedPath <- "/error/403") let _ = svc.AddDistributedMemoryCache() let _ = svc.AddSession() let _ = svc.AddAntiforgery() @@ -53,18 +57,19 @@ module Configure = let _ = svc.AddSingleton(SystemClock.Instance) let config = svc.BuildServiceProvider().GetRequiredService() - let crypto = config.GetSection "CookieCrypto" - CookieCrypto (crypto["Key"], crypto["IV"]) |> setCrypto - - let _ = svc.AddDbContext( + let _ = svc.AddDbContext( (fun options -> options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore), ServiceLifetime.Scoped, ServiceLifetime.Singleton) () + open Giraffe + let noWeb : HttpHandler = fun next ctx -> redirectTo true ($"""/{string ctx.Request.RouteValues["path"]}""") next ctx + open Giraffe.EndpointRouting + /// Routes for PrayerTracker let routes = [ route "/web/{**path}" noWeb @@ -146,11 +151,15 @@ module Configure = ] ] + open Microsoft.Extensions.Logging + /// Giraffe error handler let errorHandler (ex : exn) (logger : ILogger) = logger.LogError (EventId(), ex, "An unhandled exception has occurred while executing the request.") clearResponse >=> setStatusCode 500 >=> text ex.Message + open Microsoft.Extensions.Hosting + /// Configure logging let logging (log : ILoggingBuilder) = let env = log.Services.BuildServiceProvider().GetService () @@ -158,6 +167,10 @@ module Configure = |> function l -> l.AddConsole().AddDebug() |> ignore + open Microsoft.Extensions.Localization + open Microsoft.Extensions.Options + + /// Configure the application let app (app : IApplicationBuilder) = let env = app.ApplicationServices.GetRequiredService() if env.IsDevelopment () then diff --git a/src/PrayerTracker/Church.fs b/src/PrayerTracker/Church.fs index 7f0a12e..167222c 100644 --- a/src/PrayerTracker/Church.fs +++ b/src/PrayerTracker/Church.fs @@ -16,17 +16,17 @@ let private findStats (db : AppDbContext) churchId = task { /// POST /church/[church-id]/delete let delete chId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let churchId = ChurchId chId - match! ctx.db.TryChurchById churchId with + match! ctx.Db.TryChurchById churchId with | Some church -> - let! _, stats = findStats ctx.db churchId - ctx.db.RemoveEntry church - let! _ = ctx.db.SaveChangesAsync () + let! _, stats = findStats ctx.Db churchId + ctx.Db.RemoveEntry church + let! _ = ctx.Db.SaveChangesAsync () let s = Views.I18N.localizer.Force () addInfo ctx s["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)", church.Name, stats.SmallGroups, stats.PrayerRequests, stats.Users] return! redirectTo false "/churches" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx } open System @@ -40,21 +40,21 @@ let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> ta |> Views.Church.edit EditChurch.empty ctx |> renderHtml next ctx else - match! ctx.db.TryChurchById (ChurchId churchId) with + match! ctx.Db.TryChurchById (ChurchId churchId) with | Some church -> return! viewInfo ctx startTicks |> Views.Church.edit (EditChurch.fromChurch church) ctx |> renderHtml next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx } /// GET /churches let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks let await = Async.AwaitTask >> Async.RunSynchronously - let! churches = ctx.db.AllChurches () - let stats = churches |> List.map (fun c -> await (findStats ctx.db c.Id)) + let! churches = ctx.Db.AllChurches () + let stats = churches |> List.map (fun c -> await (findStats ctx.Db c.Id)) return! viewInfo ctx startTicks |> Views.Church.maintain churches (stats |> Map.ofList) ctx @@ -69,16 +69,16 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c | Ok model -> let! church = if model.IsNew then Task.FromResult (Some { Church.empty with Id = (Guid.NewGuid >> ChurchId) () }) - else ctx.db.TryChurchById (idFromShort ChurchId model.ChurchId) + else ctx.Db.TryChurchById (idFromShort ChurchId model.ChurchId) match church with | Some ch -> model.PopulateChurch ch - |> (if model.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry) - let! _ = ctx.db.SaveChangesAsync () + |> (if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry) + let! _ = ctx.Db.SaveChangesAsync () let s = Views.I18N.localizer.Force () let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower () addInfo ctx s["Successfully {0} church “{1}”", act, model.Name] return! redirectTo false "/churches" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } diff --git a/src/PrayerTracker/CommonFunctions.fs b/src/PrayerTracker/CommonFunctions.fs index 888f61d..c401f23 100644 --- a/src/PrayerTracker/CommonFunctions.fs +++ b/src/PrayerTracker/CommonFunctions.fs @@ -41,47 +41,20 @@ let appVersion = #endif -open Microsoft.AspNetCore.Http -open PrayerTracker - -/// The currently signed-in user (will raise if none exists) -let currentUser (ctx : HttpContext) = - match ctx.Session.user with Some u -> u | None -> nullArg "User" - -/// The currently signed-in small group (will raise if none exists) -let currentGroup (ctx : HttpContext) = - match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup" - - -open System open Giraffe open Giraffe.Htmx -open PrayerTracker.Cookies +open Microsoft.AspNetCore.Http +open PrayerTracker open PrayerTracker.ViewModels /// Create the common view information heading let viewInfo (ctx : HttpContext) startTicks = let msg = - match ctx.Session.messages with + match ctx.Session.Messages with | [] -> [] | x -> - ctx.Session.messages <- [] + ctx.Session.Messages <- [] x - match ctx.Session.user with - | Some u -> - // The idle timeout is 2 hours; if the app pool is recycled or the actual session goes away, we will log the - // user back in transparently using this cookie. Every request resets the timer. - let timeout = - { Id = u.Id.Value - GroupId = (currentGroup ctx).Id.Value - Until = DateTime.UtcNow.AddHours(2.).Ticks - Password = "" - } - ctx.Response.Cookies.Append - (Key.Cookie.timeout, { timeout with Password = saltedTimeoutHash timeout }.toPayload (), - CookieOptions (Expires = Nullable (DateTimeOffset (DateTime timeout.Until)), - HttpOnly = true)) - | None -> () let layout = match ctx.Request.Headers.HxTarget with | Some hdr when hdr = "pt-body" -> ContentOnly @@ -91,8 +64,8 @@ let viewInfo (ctx : HttpContext) startTicks = Version = appVersion Messages = msg RequestStart = startTicks - User = ctx.Session.user - Group = ctx.Session.smallGroup + User = ctx.CurrentUser + Group = ctx.CurrentGroup Layout = layout } @@ -100,16 +73,17 @@ let viewInfo (ctx : HttpContext) startTicks = let renderHtml next ctx view = htmlView view next ctx +open Microsoft.Extensions.Logging + /// Display an error regarding form submission -let bindError (msg : string) next (ctx : HttpContext) = - Console.WriteLine msg - ctx.SetStatusCode 400 - text msg next ctx +let bindError (msg : string) = + handleContext (fun ctx -> + ctx.GetService().CreateLogger("PrayerTracker.Handlers").LogError msg + (setStatusCode 400 >=> text msg) earlyReturn ctx) /// Handler that will return a status code 404 and the text "Not Found" -let fourOhFour next (ctx : HttpContext) = - ctx.SetStatusCode 404 - text "Not Found" next ctx +let fourOhFour (ctx : HttpContext) = + (setStatusCode 404 >=> text "Not Found") earlyReturn ctx /// Handler to validate CSRF prevention token let validateCsrf : HttpHandler = fun next ctx -> task { @@ -120,7 +94,7 @@ let validateCsrf : HttpHandler = fun next ctx -> task { /// Add a message to the session let addUserMessage (ctx : HttpContext) msg = - ctx.Session.messages <- msg :: ctx.Session.messages + ctx.Session.Messages <- msg :: ctx.Session.Messages open Microsoft.AspNetCore.Html @@ -165,94 +139,27 @@ type AccessLevel = open Microsoft.AspNetCore.Http.Extensions open PrayerTracker.Entities -/// Require the given access role (also refreshes "Remember Me" user and group logons) -let requireAccess level : HttpHandler = - - /// Is there currently a user logged on? - let isUserLoggedOn (ctx : HttpContext) = - ctx.Session.user |> Option.isSome - - /// Log a user on from the timeout cookie - let logOnUserFromTimeoutCookie (ctx : HttpContext) = task { - // Make sure the cookie hasn't been tampered with - try - match TimeoutCookie.fromPayload ctx.Request.Cookies[Key.Cookie.timeout] with - | Some c when c.Password = saltedTimeoutHash c -> - let! user = ctx.db.TryUserById (UserId c.Id) - match user with - | Some _ -> - ctx.Session.user <- user - let! grp = ctx.db.TryGroupById (SmallGroupId c.GroupId) - ctx.Session.smallGroup <- grp - | _ -> () - | _ -> () - // If something above doesn't work, the user doesn't get logged in - with _ -> () - } - - /// Attempt to log the user on from their stored cookie - let logOnUserFromCookie (ctx : HttpContext) = task { - match UserCookie.fromPayload ctx.Request.Cookies[Key.Cookie.user] with - | Some c -> - let! user = ctx.db.TryUserLogOnByCookie (UserId c.Id) (SmallGroupId c.GroupId) c.PasswordHash - match user with - | Some _ -> - ctx.Session.user <- user - let! grp = ctx.db.TryGroupById (SmallGroupId c.GroupId) - ctx.Session.smallGroup <- grp - // Rewrite the cookie to extend the expiration - ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh) - | _ -> () - | _ -> () - } - - /// Is there currently a small group (or member thereof) logged on? - let isGroupLoggedOn (ctx : HttpContext) = - ctx.Session.smallGroup |> Option.isSome - - /// Attempt to log the small group on from their stored cookie - let logOnGroupFromCookie (ctx : HttpContext) = task { - match GroupCookie.fromPayload ctx.Request.Cookies[Key.Cookie.group] with - | Some c -> - let! grp = ctx.db.TryGroupLogOnByCookie (SmallGroupId c.GroupId) c.PasswordHash sha1Hash - match grp with - | Some _ -> - ctx.Session.smallGroup <- grp - // Rewrite the cookie to extend the expiration - ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh) - | None -> () - | None -> () - } - - fun next ctx -> task { - // Auto-logon user or class, if required - if not (isUserLoggedOn ctx) then - do! logOnUserFromTimeoutCookie ctx - if not (isUserLoggedOn ctx) then - do! logOnUserFromCookie ctx - if not (isGroupLoggedOn ctx) then do! logOnGroupFromCookie ctx - - match true with - | _ when level |> List.contains Public -> return! next ctx - | _ when level |> List.contains User && isUserLoggedOn ctx -> return! next ctx - | _ when level |> List.contains Group && isGroupLoggedOn ctx -> return! next ctx - | _ when level |> List.contains Admin && isUserLoggedOn ctx -> - match (currentUser ctx).IsAdmin with - | true -> return! next ctx - | false -> - let s = Views.I18N.localizer.Force () - addError ctx s["You are not authorized to view the requested page."] - return! redirectTo false "/unauthorized" next ctx - | _ when level |> List.contains User -> - // Redirect to the user log on page - ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ()) - return! redirectTo false "/user/log-on" next ctx - | _ when level |> List.contains Group -> - // Redirect to the small group log on page - ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ()) - return! redirectTo false "/small-group/log-on" next ctx - | _ -> - let s = Views.I18N.localizer.Force () - addError ctx s["You are not authorized to view the requested page."] - return! redirectTo false "/unauthorized" next ctx - } +/// Require one of the given access roles +let requireAccess levels : HttpHandler = fun next ctx -> task { + match ctx.CurrentUser, ctx.CurrentGroup with + | _, _ when List.contains Public levels -> return! next ctx + | Some _, _ when List.contains User levels -> return! next ctx + | _, Some _ when List.contains Group levels -> return! next ctx + | Some u, _ when List.contains Admin levels && u.IsAdmin -> return! next ctx + | _, _ when List.contains Admin levels -> + let s = Views.I18N.localizer.Force () + addError ctx s["You are not authorized to view the requested page."] + return! redirectTo false "/unauthorized" next ctx + | _, _ when List.contains User levels -> + // Redirect to the user log on page + ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ()) + return! redirectTo false "/user/log-on" next ctx + | _, _ when List.contains Group levels -> + // Redirect to the small group log on page + ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ()) + return! redirectTo false "/small-group/log-on" next ctx + | _, _ -> + let s = Views.I18N.localizer.Force () + addError ctx s["You are not authorized to view the requested page."] + return! redirectTo false "/unauthorized" next ctx +} diff --git a/src/PrayerTracker/Cookies.fs b/src/PrayerTracker/Cookies.fs deleted file mode 100644 index 3ca59f6..0000000 --- a/src/PrayerTracker/Cookies.fs +++ /dev/null @@ -1,143 +0,0 @@ -module PrayerTracker.Cookies - -open Microsoft.AspNetCore.Http -open Newtonsoft.Json -open System -open System.Security.Cryptography -open System.IO - -// fsharplint:disable MemberNames - -/// Cryptography settings to use for encrypting cookies -type CookieCrypto (key : string, iv : string) = - - /// The key for the AES encryptor/decryptor - member _.Key = Convert.FromBase64String key - - /// The initialization vector for the AES encryptor/decryptor - member _.IV = Convert.FromBase64String iv - - -/// Helpers for encrypting/decrypting cookies -[] -module private Crypto = - - /// An instance of the cookie cryptography settings - let mutable crypto = CookieCrypto ("", "") - - /// Encrypt a cookie payload - let encrypt (payload : string) = - use aes = Aes.Create () - use enc = aes.CreateEncryptor (crypto.Key, crypto.IV) - use ms = new MemoryStream () - use cs = new CryptoStream (ms, enc, CryptoStreamMode.Write) - use sw = new StreamWriter (cs) - sw.Write payload - sw.Close () - (ms.ToArray >> Convert.ToBase64String) () - - /// Decrypt a cookie payload - let decrypt payload = - use aes = Aes.Create () - use dec = aes.CreateDecryptor (crypto.Key, crypto.IV) - use ms = new MemoryStream (Convert.FromBase64String payload) - use cs = new CryptoStream (ms, dec, CryptoStreamMode.Read) - use sr = new StreamReader (cs) - sr.ReadToEnd () - - /// Encrypt a cookie - let encryptCookie cookie = - (JsonConvert.SerializeObject >> encrypt) cookie - - /// Decrypt a cookie - let decryptCookie<'T> payload = - (decrypt >> JsonConvert.DeserializeObject<'T> >> box) payload - |> function null -> None | x -> Some (unbox<'T> x) - - -/// Accessor so that the crypto settings instance can be set during startup -let setCrypto c = Crypto.crypto <- c - - -/// Properties stored in the Small Group cookie -type GroupCookie = - { /// The Id of the small group - [] - GroupId : Guid - - /// The password hash of the small group - [] - PasswordHash : string - } -with - - /// Convert these properties to a cookie payload - member this.toPayload () = - encryptCookie this - - /// Create a set of strongly-typed properties from the cookie payload - static member fromPayload x = - try decryptCookie x with _ -> None - - -/// The payload for the timeout cookie -type TimeoutCookie = - { /// The Id of the small group to which the user is currently logged in - [] - GroupId : Guid - - /// The Id of the user who is currently logged in - [] - Id : Guid - - /// The salted timeout hash to ensure that there has been no tampering with the cookie - [] - Password : string - - /// How long this cookie is valid - [] - Until : int64 - } -with - - /// Convert this set of properties to the cookie payload - member this.toPayload () = - encryptCookie this - - /// Create a strongly-typed timeout cookie from the cookie payload - static member fromPayload x = - try decryptCookie x with _ -> None - - -/// The payload for the user's "Remember Me" cookie -type UserCookie = - { /// The Id of the group into to which the user is logged - [< JsonProperty "g">] - GroupId : Guid - - /// The Id of the user - [] - Id : Guid - - /// The user's password hash - [] - PasswordHash : string - } -with - - /// Convert this set of properties to a cookie payload - member this.toPayload () = - encryptCookie this - - /// Create the strongly-typed cookie properties from a cookie payload - static member fromPayload x = - try decryptCookie x with _ -> None - - -/// Create a salted hash to use to validate the idle timeout key -let saltedTimeoutHash (c : TimeoutCookie) = - sha1Hash $"Prayer%A{c.Id}Tracker%A{c.GroupId}Idle%d{c.Until}Timeout" - -/// Cookie options to push an expiration out by 100 days -let autoRefresh = - CookieOptions (Expires = Nullable (DateTimeOffset (DateTime.UtcNow.AddDays 100.)), HttpOnly = true) diff --git a/src/PrayerTracker/Extensions.fs b/src/PrayerTracker/Extensions.fs index 1f7c2a0..4f214c0 100644 --- a/src/PrayerTracker/Extensions.fs +++ b/src/PrayerTracker/Extensions.fs @@ -2,43 +2,23 @@ module PrayerTracker.Extensions open Microsoft.AspNetCore.Http -open Microsoft.Extensions.DependencyInjection -open Microsoft.FSharpLu open Newtonsoft.Json open PrayerTracker.Entities open PrayerTracker.ViewModels -// fsharplint:disable MemberNames - +/// Extensions on the .NET session object type ISession with + /// Set an object in the session member this.SetObject key value = this.SetString (key, JsonConvert.SerializeObject value) /// Get an object from the session member this.GetObject<'T> key = - match this.GetString key with - | null -> Unchecked.defaultof<'T> - | v -> JsonConvert.DeserializeObject<'T> v - - /// The current small group for the session - member this.smallGroup - with get () = this.GetObject Key.Session.currentGroup |> Option.fromObject - and set (v : SmallGroup option) = - match v with - | Some group -> this.SetObject Key.Session.currentGroup group - | None -> this.Remove Key.Session.currentGroup - - /// The current user for the session - member this.user - with get () = this.GetObject Key.Session.currentUser |> Option.fromObject - and set (v : User option) = - match v with - | Some user -> this.SetObject Key.Session.currentUser user - | None -> this.Remove Key.Session.currentUser + match this.GetString key with null -> Unchecked.defaultof<'T> | v -> JsonConvert.DeserializeObject<'T> v /// Current messages for the session - member this.messages + member this.Messages with get () = match box (this.GetObject Key.Session.userMessages) with | null -> List.empty @@ -46,7 +26,27 @@ type ISession with and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v +open Giraffe +open Microsoft.FSharpLu + +/// Extensions on the ASP.NET Core HTTP context type HttpContext with + + /// The currently logged on small group + member this.CurrentGroup + with get () = this.Session.GetObject Key.Session.currentGroup |> Option.fromObject + and set (v : SmallGroup option) = + match v with + | Some group -> this.Session.SetObject Key.Session.currentGroup group + | None -> this.Session.Remove Key.Session.currentGroup + + /// The currently logged on user + member this.CurrentUser + with get () = this.Session.GetObject Key.Session.currentUser |> Option.fromObject + and set (v : User option) = + match v with + | Some user -> this.Session.SetObject Key.Session.currentUser user + | None -> this.Session.Remove Key.Session.currentUser + /// The EF Core database context (via DI) - member this.db - with get () = this.RequestServices.GetRequiredService () + member this.Db = this.GetService () diff --git a/src/PrayerTracker/Home.fs b/src/PrayerTracker/Home.fs index 4a42535..b51e2ab 100644 --- a/src/PrayerTracker/Home.fs +++ b/src/PrayerTracker/Home.fs @@ -13,14 +13,12 @@ let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next |> Views.Home.error code |> renderHtml next ctx - /// GET / let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> viewInfo ctx DateTime.Now.Ticks |> Views.Home.index |> renderHtml next ctx - /// GET /language/[culture] let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> try @@ -44,30 +42,29 @@ let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fu let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/" | r -> r redirectTo false url next ctx - /// GET /legal/privacy-policy let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> viewInfo ctx DateTime.Now.Ticks |> Views.Home.privacyPolicy |> renderHtml next ctx - /// GET /legal/terms-of-service let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> viewInfo ctx DateTime.Now.Ticks |> Views.Home.termsOfService |> renderHtml next ctx +open Microsoft.AspNetCore.Authentication +open Microsoft.AspNetCore.Authentication.Cookies /// GET /log-off -let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> +let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { ctx.Session.Clear () - // Remove cookies if they exist - Key.Cookie.logOffCookies |> List.iter ctx.Response.Cookies.Delete + do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme let s = Views.I18N.localizer.Force () addHtmlInfo ctx s["Log Off Successful • Have a nice day!"] - redirectTo false "/" next ctx - + return! redirectTo false "/" next ctx +} /// GET /unauthorized let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> diff --git a/src/PrayerTracker/PrayerRequest.fs b/src/PrayerTracker/PrayerRequest.fs index 8ea9c7d..c2ac94e 100644 --- a/src/PrayerTracker/PrayerRequest.fs +++ b/src/PrayerTracker/PrayerRequest.fs @@ -8,29 +8,29 @@ open PrayerTracker.ViewModels /// Retrieve a prayer request, and ensure that it belongs to the current class let private findRequest (ctx : HttpContext) reqId = task { - match! ctx.db.TryRequestById reqId with - | Some req when req.SmallGroupId = (currentGroup ctx).Id -> return Ok req + match! ctx.Db.TryRequestById reqId with + | Some req when req.SmallGroupId = ctx.CurrentGroup.Value.Id -> return Ok req | Some _ -> let s = Views.I18N.localizer.Force () addError ctx s["The prayer request you tried to access is not assigned to your group"] - return Result.Error (redirectTo false "/unauthorized") - | None -> return Result.Error fourOhFour + return Result.Error (redirectTo false "/unauthorized" earlyReturn ctx) + | None -> return Result.Error (fourOhFour ctx) } open NodaTime /// Generate a list of requests for the given date -let private generateRequestList ctx date = task { - let grp = currentGroup ctx +let private generateRequestList (ctx : HttpContext) date = task { + let grp = ctx.CurrentGroup.Value let clock = ctx.GetService () let listDate = match date with Some d -> d | None -> grp.LocalDateNow clock - let! reqs = ctx.db.AllRequestsForSmallGroup grp clock (Some listDate) true 0 + let! reqs = ctx.Db.AllRequestsForSmallGroup grp clock (Some listDate) true 0 return { Requests = reqs Date = listDate SmallGroup = grp ShowHeader = true - CanEmail = Option.isSome ctx.Session.user + CanEmail = Option.isSome ctx.CurrentUser Recipients = [] } } @@ -46,7 +46,7 @@ let private parseListDate (date : string option) = /// GET /prayer-request/[request-id]/edit let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let grp = currentGroup ctx + let grp = ctx.CurrentGroup.Value let now = grp.LocalDateNow (ctx.GetService ()) let requestId = PrayerRequestId reqId if requestId.Value = Guid.Empty then @@ -71,7 +71,7 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { { viewInfo ctx startTicks with HelpLink = Some Help.editRequest } |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx |> renderHtml next ctx - | Result.Error e -> return! e next ctx + | Result.Error e -> return! e } /// GET /prayer-requests/email/[date] @@ -79,9 +79,9 @@ let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks let s = Views.I18N.localizer.Force () let listDate = parseListDate (Some date) - let grp = currentGroup ctx + let grp = ctx.CurrentGroup.Value let! list = generateRequestList ctx listDate - let! recipients = ctx.db.AllMembersForSmallGroup grp.Id + let! recipients = ctx.Db.AllMembersForSmallGroup grp.Id use! client = Email.getConnection () do! Email.sendEmails client recipients grp s["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.Name, list.Date].Value @@ -98,11 +98,11 @@ let delete reqId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun match! findRequest ctx requestId with | Ok req -> let s = Views.I18N.localizer.Force () - ctx.db.PrayerRequests.Remove req |> ignore - let! _ = ctx.db.SaveChangesAsync () + ctx.Db.PrayerRequests.Remove req |> ignore + let! _ = ctx.Db.SaveChangesAsync () addInfo ctx s["The prayer request was deleted successfully"] return! redirectTo false "/prayer-requests" next ctx - | Result.Error e -> return! e next ctx + | Result.Error e -> return! e } /// GET /prayer-request/[request-id]/expire @@ -111,20 +111,20 @@ let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task match! findRequest ctx requestId with | Ok req -> let s = Views.I18N.localizer.Force () - ctx.db.UpdateEntry { req with Expiration = Forced } - let! _ = ctx.db.SaveChangesAsync () + ctx.Db.UpdateEntry { req with Expiration = Forced } + let! _ = ctx.Db.SaveChangesAsync () addInfo ctx s["Successfully {0} prayer request", s["Expired"].Value.ToLower ()] return! redirectTo false "/prayer-requests" next ctx - | Result.Error e -> return! e next ctx + | Result.Error e -> return! e } /// GET /prayer-requests/[group-id]/list let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - match! ctx.db.TryGroupById groupId with + match! ctx.Db.TryGroupById groupId with | Some grp when grp.Preferences.IsPublic -> let clock = ctx.GetService () - let! reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0 + let! reqs = ctx.Db.AllRequestsForSmallGroup grp clock None true 0 return! viewInfo ctx startTicks |> Views.PrayerRequest.list @@ -132,7 +132,7 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne Date = grp.LocalDateNow clock SmallGroup = grp ShowHeader = true - CanEmail = Option.isSome ctx.Session.user + CanEmail = Option.isSome ctx.CurrentUser Recipients = [] } |> renderHtml next ctx @@ -140,13 +140,13 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne let s = Views.I18N.localizer.Force () addError ctx s["The request list for the group you tried to view is not public."] return! redirectTo false "/unauthorized" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx } /// GET /prayer-requests/lists let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let! groups = ctx.db.PublicAndProtectedGroups () + let! groups = ctx.Db.PublicAndProtectedGroups () return! viewInfo ctx startTicks |> Views.PrayerRequest.lists groups @@ -158,7 +158,7 @@ let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx /// GET /prayer-requests?search=[search-query] let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let grp = currentGroup ctx + let grp = ctx.CurrentGroup.Value let pageNbr = match ctx.GetQueryStringValue "page" with | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1 @@ -166,7 +166,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx let! m = backgroundTask { match ctx.GetQueryStringValue "search" with | Ok search -> - let! reqs = ctx.db.SearchRequestsForSmallGroup grp search pageNbr + let! reqs = ctx.Db.SearchRequestsForSmallGroup grp search pageNbr return { MaintainRequests.empty with Requests = reqs @@ -174,7 +174,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx PageNbr = Some pageNbr } | Result.Error _ -> - let! reqs = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService ()) None onlyActive pageNbr + let! reqs = ctx.Db.AllRequestsForSmallGroup grp (ctx.GetService ()) None onlyActive pageNbr return { MaintainRequests.empty with Requests = reqs @@ -202,11 +202,11 @@ let restore reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> tas match! findRequest ctx requestId with | Ok req -> let s = Views.I18N.localizer.Force () - ctx.db.UpdateEntry { req with Expiration = Automatic; UpdatedDate = DateTime.Now } - let! _ = ctx.db.SaveChangesAsync () + ctx.Db.UpdateEntry { req with Expiration = Automatic; UpdatedDate = DateTime.Now } + let! _ = ctx.Db.SaveChangesAsync () addInfo ctx s["Successfully {0} prayer request", s["Restored"].Value.ToLower ()] return! redirectTo false "/prayer-requests" next ctx - | Result.Error e -> return! e next ctx + | Result.Error e -> return! e } open System.Threading.Tasks @@ -217,7 +217,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct | Ok m -> let! req = if m.IsNew then Task.FromResult (Some { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () }) - else ctx.db.TryRequestById (idFromShort PrayerRequestId m.RequestId) + else ctx.Db.TryRequestById (idFromShort PrayerRequestId m.RequestId) match req with | Some pr -> let upd8 = @@ -227,26 +227,26 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct Text = ckEditorToText m.Text Expiration = Expiration.fromCode m.Expiration } - let grp = currentGroup ctx + let grp = ctx.CurrentGroup.Value let now = grp.LocalDateNow (ctx.GetService ()) match m.IsNew with | true -> let dt = defaultArg m.EnteredDate now { upd8 with SmallGroupId = grp.Id - UserId = (currentUser ctx).Id + UserId = ctx.CurrentUser.Value.Id EnteredDate = dt UpdatedDate = dt } | false when defaultArg m.SkipDateUpdate false -> upd8 | false -> { upd8 with UpdatedDate = now } - |> if m.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry - let! _ = ctx.db.SaveChangesAsync () + |> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry + let! _ = ctx.Db.SaveChangesAsync () let s = Views.I18N.localizer.Force () let act = if m.IsNew then "Added" else "Updated" addInfo ctx s["Successfully {0} prayer request", s[act].Value.ToLower ()] return! redirectTo false "/prayer-requests" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } diff --git a/src/PrayerTracker/PrayerTracker.fsproj b/src/PrayerTracker/PrayerTracker.fsproj index ac909ae..712cdfe 100644 --- a/src/PrayerTracker/PrayerTracker.fsproj +++ b/src/PrayerTracker/PrayerTracker.fsproj @@ -13,7 +13,6 @@ - diff --git a/src/PrayerTracker/SmallGroup.fs b/src/PrayerTracker/SmallGroup.fs index d97ce28..415fe57 100644 --- a/src/PrayerTracker/SmallGroup.fs +++ b/src/PrayerTracker/SmallGroup.fs @@ -2,59 +2,51 @@ open System open Giraffe -open Microsoft.AspNetCore.Http open PrayerTracker -open PrayerTracker.Cookies open PrayerTracker.Entities open PrayerTracker.ViewModels -/// Set a small group "Remember Me" cookie -let private setGroupCookie (ctx : HttpContext) pwHash = - ctx.Response.Cookies.Append - (Key.Cookie.group, { GroupId = (currentGroup ctx).Id.Value; PasswordHash = pwHash }.toPayload (), - autoRefresh) - /// GET /small-group/announcement let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx -> { viewInfo ctx DateTime.Now.Ticks with HelpLink = Some Help.sendAnnouncement } - |> Views.SmallGroup.announcement (currentUser ctx).IsAdmin ctx + |> Views.SmallGroup.announcement ctx.CurrentUser.Value.IsAdmin ctx |> renderHtml next ctx /// POST /small-group/[group-id]/delete let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let s = Views.I18N.localizer.Force () let groupId = SmallGroupId grpId - match! ctx.db.TryGroupById groupId with + match! ctx.Db.TryGroupById groupId with | Some grp -> - let! reqs = ctx.db.CountRequestsBySmallGroup groupId - let! users = ctx.db.CountUsersBySmallGroup groupId - ctx.db.RemoveEntry grp - let! _ = ctx.db.SaveChangesAsync () + let! reqs = ctx.Db.CountRequestsBySmallGroup groupId + let! users = ctx.Db.CountUsersBySmallGroup groupId + ctx.Db.RemoveEntry grp + let! _ = ctx.Db.SaveChangesAsync () addInfo ctx s["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)", grp.Name, reqs, users] return! redirectTo false "/small-groups" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx } /// POST /small-group/member/[member-id]/delete let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let s = Views.I18N.localizer.Force () let memberId = MemberId mbrId - match! ctx.db.TryMemberById memberId with - | Some mbr when mbr.SmallGroupId = (currentGroup ctx).Id -> - ctx.db.RemoveEntry mbr - let! _ = ctx.db.SaveChangesAsync () + match! ctx.Db.TryMemberById memberId with + | Some mbr when mbr.SmallGroupId = ctx.CurrentGroup.Value.Id -> + ctx.Db.RemoveEntry mbr + let! _ = ctx.Db.SaveChangesAsync () addHtmlInfo ctx s["The group member “{0}” was deleted successfully", mbr.Name] return! redirectTo false "/small-group/members" next ctx | Some _ - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx } /// GET /small-group/[group-id]/edit let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let! churches = ctx.db.AllChurches () + let! churches = ctx.Db.AllChurches () let groupId = SmallGroupId grpId if groupId.Value = Guid.Empty then return! @@ -62,20 +54,20 @@ let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx |> renderHtml next ctx else - match! ctx.db.TryGroupById groupId with + match! ctx.Db.TryGroupById groupId with | Some grp -> return! viewInfo ctx startTicks |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx |> renderHtml next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx } /// GET /small-group/member/[member-id]/edit let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks let s = Views.I18N.localizer.Force () - let grp = currentGroup ctx + let grp = ctx.CurrentGroup.Value let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s let memberId = MemberId mbrId if memberId.Value = Guid.Empty then @@ -84,20 +76,20 @@ let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> |> Views.SmallGroup.editMember EditMember.empty types ctx |> renderHtml next ctx else - match! ctx.db.TryMemberById memberId with + match! ctx.Db.TryMemberById memberId with | Some mbr when mbr.SmallGroupId = grp.Id -> return! viewInfo ctx startTicks |> Views.SmallGroup.editMember (EditMember.fromMember mbr) types ctx |> renderHtml next ctx | Some _ - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx } /// GET /small-group/log-on/[group-id?] let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let! groups = ctx.db.ProtectedGroups () + let! groups = ctx.Db.ProtectedGroups () let groupId = match grpId with Some gid -> shortGuid gid | None -> "" return! { viewInfo ctx startTicks with HelpLink = Some Help.logOn } @@ -105,27 +97,37 @@ let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun nex |> renderHtml next ctx } +open System.Security.Claims +open Microsoft.AspNetCore.Authentication +open Microsoft.AspNetCore.Authentication.Cookies + /// POST /small-group/log-on/submit let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with - | Ok m -> + | Ok model -> let s = Views.I18N.localizer.Force () - match! ctx.db.TryGroupLogOnByPassword (idFromShort SmallGroupId m.SmallGroupId) m.Password with - | Some grp -> - ctx.Session.smallGroup <- Some grp - if defaultArg m.RememberMe false then (setGroupCookie ctx << sha1Hash) m.Password + match! ctx.Db.TryGroupLogOnByPassword (idFromShort SmallGroupId model.SmallGroupId) model.Password with + | Some group -> + ctx.CurrentGroup <- Some group + let claims = Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) |> Seq.singleton + let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) + do! ctx.SignInAsync + (identity.AuthenticationType, ClaimsPrincipal identity, + AuthenticationProperties ( + IssuedUtc = DateTimeOffset.UtcNow, + IsPersistent = defaultArg model.RememberMe false)) addInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]] return! redirectTo false "/prayer-requests/view" next ctx | None -> addError ctx s["Password incorrect - login unsuccessful"] - return! redirectTo false $"/small-group/log-on/{m.SmallGroupId}" next ctx + return! redirectTo false $"/small-group/log-on/{model.SmallGroupId}" next ctx | Result.Error e -> return! bindError e next ctx } /// GET /small-groups let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let! groups = ctx.db.AllGroups () + let! groups = ctx.Db.AllGroups () return! viewInfo ctx startTicks |> Views.SmallGroup.maintain groups ctx @@ -135,9 +137,9 @@ let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { /// GET /small-group/members let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let grp = currentGroup ctx + let grp = ctx.CurrentGroup.Value let s = Views.I18N.localizer.Force () - let! members = ctx.db.AllMembersForSmallGroup grp.Id + let! members = ctx.Db.AllMembersForSmallGroup grp.Id let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s |> Map.ofSeq return! { viewInfo ctx startTicks with HelpLink = Some Help.maintainGroupMembers } @@ -151,9 +153,10 @@ open NodaTime let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks let clock = ctx.GetService () - let! reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 - let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).Id - let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).Id + let group = ctx.CurrentGroup.Value + let! reqs = ctx.Db.AllRequestsForSmallGroup group clock None true 0 + let! reqCount = ctx.Db.CountRequestsBySmallGroup group.Id + let! mbrCount = ctx.Db.CountMembersForSmallGroup group.Id let m = { TotalActiveReqs = List.length reqs AllReqs = reqCount @@ -175,10 +178,10 @@ let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { /// GET /small-group/preferences let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let! tzs = ctx.db.AllTimeZones () + let! tzs = ctx.Db.AllTimeZones () return! { viewInfo ctx startTicks with HelpLink = Some Help.groupPreferences } - |> Views.SmallGroup.preferences (EditPreferences.fromPreferences (currentGroup ctx).Preferences) tzs ctx + |> Views.SmallGroup.preferences (EditPreferences.fromPreferences ctx.CurrentGroup.Value.Preferences) tzs ctx |> renderHtml next ctx } @@ -191,20 +194,20 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c let s = Views.I18N.localizer.Force () let! group = if m.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () }) - else ctx.db.TryGroupById (idFromShort SmallGroupId m.SmallGroupId) + else ctx.Db.TryGroupById (idFromShort SmallGroupId m.SmallGroupId) match group with | Some grp -> m.populateGroup grp |> function | grp when m.IsNew -> - ctx.db.AddEntry grp - ctx.db.AddEntry { grp.Preferences with SmallGroupId = grp.Id } - | grp -> ctx.db.UpdateEntry grp - let! _ = ctx.db.SaveChangesAsync () + ctx.Db.AddEntry grp + ctx.Db.AddEntry { grp.Preferences with SmallGroupId = grp.Id } + | grp -> ctx.Db.UpdateEntry grp + let! _ = ctx.Db.SaveChangesAsync () let act = s[if m.IsNew then "Added" else "Updated"].Value.ToLower () addHtmlInfo ctx s["Successfully {0} group “{1}”", act, m.Name] return! redirectTo false "/small-groups" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } @@ -212,11 +215,11 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with | Ok model -> - let grp = currentGroup ctx + let grp = ctx.CurrentGroup.Value let! mMbr = if model.IsNew then Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = grp.Id }) - else ctx.db.TryMemberById (idFromShort MemberId model.MemberId) + else ctx.Db.TryMemberById (idFromShort MemberId model.MemberId) match mMbr with | Some mbr when mbr.SmallGroupId = grp.Id -> { mbr with @@ -224,35 +227,35 @@ let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun n Email = model.Email Format = match model.Format with "" | null -> None | _ -> Some (EmailFormat.fromCode model.Format) } - |> if model.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry - let! _ = ctx.db.SaveChangesAsync () + |> if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry + let! _ = ctx.Db.SaveChangesAsync () let s = Views.I18N.localizer.Force () let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower () addInfo ctx s["Successfully {0} group member", act] return! redirectTo false "/small-group/members" next ctx | Some _ - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } /// POST /small-group/preferences/save let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with - | Ok m -> + | Ok model -> // Since the class is stored in the session, we'll use an intermediate instance to persist it; once that works, // we can repopulate the session instance. That way, if the update fails, the page should still show the // database values, not the then out-of-sync session ones. - match! ctx.db.TryGroupById (currentGroup ctx).Id with + match! ctx.Db.TryGroupById ctx.CurrentGroup.Value.Id with | Some grp -> - let prefs = m.PopulatePreferences grp.Preferences - ctx.db.UpdateEntry prefs - let! _ = ctx.db.SaveChangesAsync () + let prefs = model.PopulatePreferences grp.Preferences + ctx.Db.UpdateEntry prefs + let! _ = ctx.Db.SaveChangesAsync () // Refresh session instance - ctx.Session.smallGroup <- Some { grp with Preferences = prefs } + ctx.CurrentGroup <- Some { grp with Preferences = prefs } let s = Views.I18N.localizer.Force () addInfo ctx s["Group preferences updated successfully"] return! redirectTo false "/small-group/preferences" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } @@ -263,13 +266,13 @@ open PrayerTracker.Views.CommonFunctions let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks match! ctx.TryBindFormAsync () with - | Ok m -> - let grp = currentGroup ctx - let usr = currentUser ctx + | Ok model -> + let grp = ctx.CurrentGroup.Value + let usr = ctx.CurrentUser.Value let now = grp.LocalTimeNow (ctx.GetService ()) let s = Views.I18N.localizer.Force () // Reformat the text to use the class's font stylings - let requestText = ckEditorToText m.Text + let requestText = ckEditorToText model.Text let htmlText = p [ _style $"font-family:{grp.Preferences.Fonts};font-size:%d{grp.Preferences.TextFontSize}pt;" ] [ rawText requestText ] @@ -277,16 +280,16 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> let plainText = (htmlToPlainText >> wordWrap 74) htmlText // Send the e-mails let! recipients = - match m.SendToClass with - | "N" when usr.IsAdmin -> ctx.db.AllUsersAsMembers () - | _ -> ctx.db.AllMembersForSmallGroup grp.Id + match model.SendToClass with + | "N" when usr.IsAdmin -> ctx.Db.AllUsersAsMembers () + | _ -> ctx.Db.AllMembersForSmallGroup grp.Id use! client = Email.getConnection () do! Email.sendEmails client recipients grp s["Announcement for {0} - {1:MMMM d, yyyy} {2}", grp.Name, now.Date, (now.ToString "h:mm tt").ToLower ()].Value htmlText plainText s // Add to the request list if desired - match m.SendToClass, m.AddToRequestList with + match model.SendToClass, model.AddToRequestList with | "N", _ | _, None -> () | _, Some x when not x -> () @@ -295,24 +298,24 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> Id = (Guid.NewGuid >> PrayerRequestId) () SmallGroupId = grp.Id UserId = usr.Id - RequestType = (Option.get >> PrayerRequestType.fromCode) m.RequestType + RequestType = (Option.get >> PrayerRequestType.fromCode) model.RequestType Text = requestText EnteredDate = now UpdatedDate = now } - |> ctx.db.AddEntry - let! _ = ctx.db.SaveChangesAsync () + |> ctx.Db.AddEntry + let! _ = ctx.Db.SaveChangesAsync () () // Tell 'em what they've won, Johnny! let toWhom = - match m.SendToClass with + match model.SendToClass with | "N" -> s["{0} users", s["PrayerTracker"]].Value | _ -> s["Group Members"].Value.ToLower () - let andAdded = match m.AddToRequestList with Some x when x -> "and added it to the request list" | _ -> "" + let andAdded = match model.AddToRequestList with Some x when x -> "and added it to the request list" | _ -> "" addInfo ctx s["Successfully sent announcement to all {0} {1}", toWhom, s[andAdded]] return! viewInfo ctx startTicks - |> Views.SmallGroup.announcementSent { m with Text = htmlText } + |> Views.SmallGroup.announcementSent { model with Text = htmlText } |> renderHtml next ctx | Result.Error e -> return! bindError e next ctx } diff --git a/src/PrayerTracker/User.fs b/src/PrayerTracker/User.fs index a5b5775..995253b 100644 --- a/src/PrayerTracker/User.fs +++ b/src/PrayerTracker/User.fs @@ -1,21 +1,12 @@ module PrayerTracker.Handlers.User -open Giraffe -open Microsoft.AspNetCore.Http -open PrayerTracker -open PrayerTracker.Cookies -open PrayerTracker.Entities -open PrayerTracker.ViewModels - -/// Set the user's "remember me" cookie -let private setUserCookie (ctx : HttpContext) pwHash = - ctx.Response.Cookies.Append ( - Key.Cookie.user, - { Id = (currentUser ctx).Id.Value; GroupId = (currentGroup ctx).Id.Value; PasswordHash = pwHash }.toPayload (), - autoRefresh) - open System open System.Collections.Generic +open Giraffe +open Microsoft.AspNetCore.Http +open PrayerTracker +open PrayerTracker.Entities +open PrayerTracker.ViewModels /// Retrieve a user from the database by password // If the hashes do not match, determine if it matches a previous scheme, and upgrade them if it does @@ -25,8 +16,8 @@ let private findUserByPassword model (db : AppDbContext) = task { // Already upgraded; match = success let pwHash = pbkdf2Hash (Option.get u.Salt) model.Password if u.PasswordHash = pwHash then - return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List() }, pwHash - else return None, "" + return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List() } + else return None | Some u when u.PasswordHash = sha1Hash model.Password -> // Not upgraded, but password is good; upgrade 'em! // Upgrade 'em! @@ -35,8 +26,8 @@ let private findUserByPassword model (db : AppDbContext) = task { let upgraded = { u with Salt = Some salt; PasswordHash = pwHash } db.UpdateEntry upgraded let! _ = db.SaveChangesAsync () - return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List() }, pwHash - | _ -> return None, "" + return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List() } + | _ -> return None } open System.Threading.Tasks @@ -44,27 +35,25 @@ open System.Threading.Tasks /// POST /user/password/change let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with - | Ok m -> + | Ok model -> let s = Views.I18N.localizer.Force () - let curUsr = currentUser ctx - let! dbUsr = ctx.db.TryUserById curUsr.Id + let curUsr = ctx.CurrentUser.Value + let! dbUsr = ctx.Db.TryUserById curUsr.Id let! user = match dbUsr with | Some usr -> // Check the old password against a possibly non-salted hash - (match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) m.OldPassword - |> ctx.db.TryUserLogOnByCookie curUsr.Id (currentGroup ctx).Id + (match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) model.OldPassword + |> ctx.Db.TryUserLogOnByCookie curUsr.Id ctx.CurrentGroup.Value.Id | _ -> Task.FromResult None match user with - | Some _ when m.NewPassword = m.NewPasswordConfirm -> + | Some _ when model.NewPassword = model.NewPasswordConfirm -> match dbUsr with | Some usr -> // Generate new salt whenever the password is changed let salt = Guid.NewGuid () - ctx.db.UpdateEntry { usr with PasswordHash = pbkdf2Hash salt m.NewPassword; Salt = Some salt } - let! _ = ctx.db.SaveChangesAsync () - // If the user is remembered, update the cookie with the new hash - if ctx.Request.Cookies.Keys.Contains Key.Cookie.user then setUserCookie ctx usr.PasswordHash + ctx.Db.UpdateEntry { usr with PasswordHash = pbkdf2Hash salt model.NewPassword; Salt = Some salt } + let! _ = ctx.Db.SaveChangesAsync () addInfo ctx s["Your password was changed successfully"] | None -> addError ctx s["Unable to change password"] return! redirectTo false "/" next ctx @@ -80,59 +69,75 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f /// POST /user/[user-id]/delete let delete usrId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let userId = UserId usrId - match! ctx.db.TryUserById userId with + match! ctx.Db.TryUserById userId with | Some user -> - ctx.db.RemoveEntry user - let! _ = ctx.db.SaveChangesAsync () + ctx.Db.RemoveEntry user + let! _ = ctx.Db.SaveChangesAsync () let s = Views.I18N.localizer.Force () addInfo ctx s["Successfully deleted user {0}", user.Name] return! redirectTo false "/users" next ctx - | _ -> return! fourOhFour next ctx + | _ -> return! fourOhFour ctx } open System.Net +open System.Security.Claims +open Microsoft.AspNetCore.Authentication +open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Html /// POST /user/log-on let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with | Ok model -> - let s = Views.I18N.localizer.Force () - let! usr, pwHash = findUserByPassword model ctx.db - let! grp = ctx.db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId) - let nextUrl = - match usr with - | Some _ -> - ctx.Session.user <- usr - ctx.Session.smallGroup <- grp - if defaultArg model.RememberMe false then setUserCookie ctx pwHash - addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]] - match model.RedirectUrl with - | None -> "/small-group" - // TODO: ensure "x" is a local URL - | Some x when x = "" -> "/small-group" - | Some x -> x - | _ -> - let grpName = match grp with Some g -> g.Name | _ -> "N/A" - { UserMessage.error with - Text = htmlLocString s["Invalid credentials - log on unsuccessful"] - Description = - [ s["This is likely due to one of the following reasons"].Value - ":
  • " - s["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode model.Email].Value - "
  • " - s["The password entered does not match the password for the given e-mail address."].Value - "
  • " - s["You are not authorized to administer the group “{0}”.", - WebUtility.HtmlEncode grpName].Value - "
" - ] - |> String.concat "" - |> (HtmlString >> Some) - } - |> addUserMessage ctx - "/user/log-on" - return! redirectTo false nextUrl next ctx + let s = Views.I18N.localizer.Force () + let! usr = findUserByPassword model ctx.Db + match! ctx.Db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId) with + | Some group -> + let! nextUrl = backgroundTask { + match usr with + | Some user -> + ctx.CurrentUser <- usr + ctx.CurrentGroup <- Some group + let claims = seq { + Claim (ClaimTypes.NameIdentifier, shortGuid user.Id.Value) + Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) + Claim (ClaimTypes.Role, if user.IsAdmin then "Admin" else "User") + } + let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) + do! ctx.SignInAsync + (identity.AuthenticationType, ClaimsPrincipal identity, + AuthenticationProperties ( + IssuedUtc = DateTimeOffset.UtcNow, + IsPersistent = defaultArg model.RememberMe false)) + addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]] + return + match model.RedirectUrl with + | None -> "/small-group" + | Some x when x = ""-> "/small-group" + | Some x when x.IndexOf "://" < 0 -> x + | _ -> "/small-group" + | _ -> + { UserMessage.error with + Text = htmlLocString s["Invalid credentials - log on unsuccessful"] + Description = + [ s["This is likely due to one of the following reasons"].Value + ":
  • " + s["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode model.Email].Value + "
  • " + s["The password entered does not match the password for the given e-mail address."].Value + "
  • " + s["You are not authorized to administer the group “{0}”.", + WebUtility.HtmlEncode group.Name].Value + "
" + ] + |> String.concat "" + |> (HtmlString >> Some) + } + |> addUserMessage ctx + return "/user/log-on" + } + return! redirectTo false nextUrl next ctx + | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } @@ -147,13 +152,13 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task |> Views.User.edit EditUser.empty ctx |> renderHtml next ctx else - match! ctx.db.TryUserById userId with + match! ctx.Db.TryUserById userId with | Some user -> return! viewInfo ctx startTicks |> Views.User.edit (EditUser.fromUser user) ctx |> renderHtml next ctx - | _ -> return! fourOhFour next ctx + | _ -> return! fourOhFour ctx } @@ -161,7 +166,7 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks let s = Views.I18N.localizer.Force () - let! groups = ctx.db.GroupList () + let! groups = ctx.Db.GroupList () let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl match url with | Some _ -> @@ -178,7 +183,7 @@ let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx /// GET /users let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let! users = ctx.db.AllUsers () + let! users = ctx.Db.AllUsers () return! viewInfo ctx startTicks |> Views.User.maintain users ctx @@ -199,7 +204,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c | Ok m -> let! user = if m.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () }) - else ctx.db.TryUserById (idFromShort UserId m.UserId) + else ctx.Db.TryUserById (idFromShort UserId m.UserId) let saltedUser = match user with | Some u -> @@ -214,8 +219,8 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c match saltedUser with | Some u -> let updatedUser = m.PopulateUser u (pbkdf2Hash (Option.get u.Salt)) - updatedUser |> if m.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry - let! _ = ctx.db.SaveChangesAsync () + updatedUser |> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry + let! _ = ctx.Db.SaveChangesAsync () let s = Views.I18N.localizer.Force () if m.IsNew then let h = CommonFunctions.htmlString @@ -230,7 +235,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c else addInfo ctx s["Successfully {0} user", s["Updated"].Value.ToLower ()] return! redirectTo false "/users" next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } @@ -245,7 +250,7 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun addError ctx s["You must select at least one group to assign"] return! redirectTo false $"/user/{model.UserId}/small-groups" next ctx | _ -> - match! ctx.db.TryUserByIdWithGroups (idFromShort UserId model.UserId) with + match! ctx.Db.TryUserByIdWithGroups (idFromShort UserId model.UserId) with | Some user -> let groups = model.SmallGroups.Split ',' @@ -253,17 +258,17 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun |> List.ofArray user.SmallGroups |> Seq.filter (fun x -> not (groups |> List.exists (fun y -> y = x.SmallGroupId))) - |> ctx.db.UserGroupXref.RemoveRange + |> ctx.Db.UserGroupXref.RemoveRange groups |> Seq.ofList |> Seq.filter (fun x -> not (user.SmallGroups |> Seq.exists (fun y -> y.SmallGroupId = x))) |> Seq.map (fun x -> { UserSmallGroup.empty with UserId = user.Id; SmallGroupId = x }) |> List.ofSeq - |> List.iter ctx.db.AddEntry - let! _ = ctx.db.SaveChangesAsync () + |> List.iter ctx.Db.AddEntry + let! _ = ctx.Db.SaveChangesAsync () addInfo ctx s["Successfully updated group permissions for {0}", model.UserName] return! redirectTo false "/users" next ctx - | _ -> return! fourOhFour next ctx + | _ -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx } @@ -272,13 +277,13 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks let userId = UserId usrId - match! ctx.db.TryUserByIdWithGroups userId with + match! ctx.Db.TryUserByIdWithGroups userId with | Some user -> - let! groups = ctx.db.GroupList () + let! groups = ctx.Db.GroupList () let curGroups = user.SmallGroups |> Seq.map (fun g -> shortGuid g.SmallGroupId.Value) |> List.ofSeq return! viewInfo ctx startTicks |> Views.User.assignGroups (AssignGroups.fromUser user) groups curGroups ctx |> renderHtml next ctx - | None -> return! fourOhFour next ctx + | None -> return! fourOhFour ctx }