diff --git a/src/Directory.Build.props b/src/Directory.Build.props index 47fecfd..9e16426 100644 --- a/src/Directory.Build.props +++ b/src/Directory.Build.props @@ -1,9 +1,9 @@ - 7.5.0.0 - 7.5.0.0 + 7.6.0.0 + 7.6.0.0 danieljsummers Bit Badger Solutions - 7.5.0 + 7.6.0 diff --git a/src/PrayerTracker.Data/DataAccess.fs b/src/PrayerTracker.Data/DataAccess.fs index 2dc2215..6dfebcd 100644 --- a/src/PrayerTracker.Data/DataAccess.fs +++ b/src/PrayerTracker.Data/DataAccess.fs @@ -1,7 +1,6 @@ [] module PrayerTracker.DataAccess -open FSharp.Control.Tasks.ContextInsensitive open Microsoft.EntityFrameworkCore open PrayerTracker.Entities open System.Collections.Generic diff --git a/src/PrayerTracker.Data/Entities.fs b/src/PrayerTracker.Data/Entities.fs index 6718779..1780d11 100644 --- a/src/PrayerTracker.Data/Entities.fs +++ b/src/PrayerTracker.Data/Entities.fs @@ -6,6 +6,8 @@ open NodaTime open System open System.Collections.Generic +// fsharplint:disable RecordFieldNames MemberNames + (*-- SUPPORT TYPES --*) /// How as-of dates should (or should not) be displayed with requests diff --git a/src/PrayerTracker.Data/Migrations/20161217153124_InitialDatabase.fs b/src/PrayerTracker.Data/Migrations/20161217153124_InitialDatabase.fs index 7f5b230..c228771 100644 --- a/src/PrayerTracker.Data/Migrations/20161217153124_InitialDatabase.fs +++ b/src/PrayerTracker.Data/Migrations/20161217153124_InitialDatabase.fs @@ -10,6 +10,7 @@ open PrayerTracker open PrayerTracker.Entities open System +// fsharplint:disable RecordFieldNames type ChurchTable = { churchId : OperationBuilder diff --git a/src/PrayerTracker.Data/PrayerTracker.Data.fsproj b/src/PrayerTracker.Data/PrayerTracker.Data.fsproj index b00699a..b7eeb49 100644 --- a/src/PrayerTracker.Data/PrayerTracker.Data.fsproj +++ b/src/PrayerTracker.Data/PrayerTracker.Data.fsproj @@ -1,7 +1,7 @@  - net5.0 + net6.0 @@ -14,10 +14,9 @@ - - - - + + + diff --git a/src/PrayerTracker.Tests/PrayerTracker.Tests.fsproj b/src/PrayerTracker.Tests/PrayerTracker.Tests.fsproj index ebe2fbf..14f1306 100644 --- a/src/PrayerTracker.Tests/PrayerTracker.Tests.fsproj +++ b/src/PrayerTracker.Tests/PrayerTracker.Tests.fsproj @@ -2,7 +2,7 @@ Exe - net5.0 + net6.0 @@ -15,9 +15,9 @@ - + - + diff --git a/src/PrayerTracker.Tests/UI/CommonFunctionsTests.fs b/src/PrayerTracker.Tests/UI/CommonFunctionsTests.fs index 156345f..437feed 100644 --- a/src/PrayerTracker.Tests/UI/CommonFunctionsTests.fs +++ b/src/PrayerTracker.Tests/UI/CommonFunctionsTests.fs @@ -1,7 +1,7 @@ module PrayerTracker.UI.CommonFunctionsTests open Expecto -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open Microsoft.AspNetCore.Mvc.Localization open Microsoft.Extensions.Localization open PrayerTracker.Tests.TestLocalization diff --git a/src/PrayerTracker.UI/Church.fs b/src/PrayerTracker.UI/Church.fs index 167390c..cdeed04 100644 --- a/src/PrayerTracker.UI/Church.fs +++ b/src/PrayerTracker.UI/Church.fs @@ -1,6 +1,6 @@ module PrayerTracker.Views.Church -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open PrayerTracker.Entities open PrayerTracker.ViewModels diff --git a/src/PrayerTracker.UI/CommonFunctions.fs b/src/PrayerTracker.UI/CommonFunctions.fs index 9fa8aea..8d55bc8 100644 --- a/src/PrayerTracker.UI/CommonFunctions.fs +++ b/src/PrayerTracker.UI/CommonFunctions.fs @@ -2,8 +2,9 @@ module PrayerTracker.Views.CommonFunctions open Giraffe -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open Microsoft.AspNetCore.Antiforgery +open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Mvc.Localization open Microsoft.Extensions.Localization @@ -125,6 +126,13 @@ let _onsubmit = attr "onsubmit" let _scoped = flag "scoped" +/// The name this function used to have when the view engine was part of Giraffe +let renderHtmlNode = RenderView.AsString.htmlNode + +/// Render an HTML node, then return the value as an HTML string +let renderHtmlString = renderHtmlNode >> HtmlString + + /// Utility methods to help with time zones (and localization of their names) module TimeZones = diff --git a/src/PrayerTracker.UI/Home.fs b/src/PrayerTracker.UI/Home.fs index 2ad9fda..b987660 100644 --- a/src/PrayerTracker.UI/Home.fs +++ b/src/PrayerTracker.UI/Home.fs @@ -1,7 +1,7 @@ /// Views associated with the home page, or those that don't fit anywhere else module PrayerTracker.Views.Home -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open Microsoft.AspNetCore.Html open PrayerTracker.ViewModels open System.IO @@ -204,7 +204,7 @@ let termsOfService vi = let raw = rawLocText sw let ppLink = a [ _href "/web/legal/privacy-policy" ] [ str (s.["Privacy Policy"].Value.ToLower ()) ] - |> (renderHtmlNode >> HtmlString) + |> renderHtmlString [ p [ _class "pt-right-text" ] [ small [] [ em [] [ raw l.["(as of May 24, 2018)"] ] ] ] h3 [] [ str "1. "; raw l.["Acceptance of Terms"] ] diff --git a/src/PrayerTracker.UI/Layout.fs b/src/PrayerTracker.UI/Layout.fs index 1b9c558..4d299ab 100644 --- a/src/PrayerTracker.UI/Layout.fs +++ b/src/PrayerTracker.UI/Layout.fs @@ -1,7 +1,7 @@ /// Layout items for PrayerTracker module PrayerTracker.Views.Layout -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open PrayerTracker open PrayerTracker.ViewModels open System diff --git a/src/PrayerTracker.UI/PrayerRequest.fs b/src/PrayerTracker.UI/PrayerRequest.fs index 60550d5..c8771e5 100644 --- a/src/PrayerTracker.UI/PrayerRequest.fs +++ b/src/PrayerTracker.UI/PrayerRequest.fs @@ -1,7 +1,7 @@ module PrayerTracker.Views.PrayerRequest open Giraffe -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open Microsoft.AspNetCore.Http open NodaTime open PrayerTracker diff --git a/src/PrayerTracker.UI/PrayerTracker.UI.fsproj b/src/PrayerTracker.UI/PrayerTracker.UI.fsproj index fb49b75..4253ebc 100644 --- a/src/PrayerTracker.UI/PrayerTracker.UI.fsproj +++ b/src/PrayerTracker.UI/PrayerTracker.UI.fsproj @@ -1,7 +1,7 @@  - net5.0 + net6.0 @@ -18,13 +18,14 @@ - - + + + - + diff --git a/src/PrayerTracker.UI/SmallGroup.fs b/src/PrayerTracker.UI/SmallGroup.fs index 068dd6d..0fdce40 100644 --- a/src/PrayerTracker.UI/SmallGroup.fs +++ b/src/PrayerTracker.UI/SmallGroup.fs @@ -1,6 +1,6 @@ module PrayerTracker.Views.SmallGroup -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open Microsoft.Extensions.Localization open PrayerTracker open PrayerTracker.Entities diff --git a/src/PrayerTracker.UI/User.fs b/src/PrayerTracker.UI/User.fs index 965d0f8..86504b0 100644 --- a/src/PrayerTracker.UI/User.fs +++ b/src/PrayerTracker.UI/User.fs @@ -1,6 +1,6 @@ module PrayerTracker.Views.User -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open PrayerTracker.Entities open PrayerTracker.ViewModels diff --git a/src/PrayerTracker.UI/ViewModels.fs b/src/PrayerTracker.UI/ViewModels.fs index 52c8b24..478171e 100644 --- a/src/PrayerTracker.UI/ViewModels.fs +++ b/src/PrayerTracker.UI/ViewModels.fs @@ -557,7 +557,7 @@ module UserLogOn = } -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine /// This represents a list of requests type RequestList = @@ -651,7 +651,7 @@ with |> ul [] br [] ] - |> renderHtmlNodes + |> RenderView.AsString.htmlNodes /// Generate this list as plain text member this.asText (s : IStringLocalizer) = diff --git a/src/PrayerTracker/App.fs b/src/PrayerTracker/App.fs index 0d1d00d..3ce04d6 100644 --- a/src/PrayerTracker/App.fs +++ b/src/PrayerTracker/App.fs @@ -9,7 +9,7 @@ module Configure = open Cookies open Giraffe - open Giraffe.TokenRouter + open Giraffe.EndpointRouting open Microsoft.AspNetCore.Localization open Microsoft.AspNetCore.Server.Kestrel.Core open Microsoft.EntityFrameworkCore @@ -49,22 +49,22 @@ module Configure = .AddDistributedMemoryCache() .AddSession() .AddAntiforgery() + .AddRouting() .AddSingleton(SystemClock.Instance) |> ignore let config = svc.BuildServiceProvider().GetRequiredService() let crypto = config.GetSection "CookieCrypto" CookieCrypto (crypto.["Key"], crypto.["IV"]) |> setCrypto svc.AddDbContext( - fun options -> - options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore) + (fun options -> + options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore), + ServiceLifetime.Scoped, ServiceLifetime.Singleton) |> ignore /// Routes for PrayerTracker - let webApp = - router Handlers.CommonFunctions.fourOhFour [ - // Traditional web app routes - subRoute"/web" [ - GET [ + let routes = + [ subRoute "/web" [ + GET_HEAD [ subRoute "/church" [ route "es" Handlers.Church.maintain routef "/%O/edit" Handlers.Church.edit @@ -144,7 +144,8 @@ module Configure = // Temp redirect to new URLs route "/" (redirectTo false "/web/") ] - + + /// 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 @@ -171,9 +172,10 @@ module Configure = app.UseGiraffeErrorHandler errorHandler) .UseStatusCodePagesWithReExecute("/error/{0}") .UseStaticFiles() + .UseRouting() .UseSession() .UseRequestLocalization(app.ApplicationServices.GetService>().Value) - .UseGiraffe(webApp) + .UseEndpoints (fun e -> e.MapGiraffeEndpoints routes) |> ignore Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService () diff --git a/src/PrayerTracker/Church.fs b/src/PrayerTracker/Church.fs index 2832fef..b25225b 100644 --- a/src/PrayerTracker/Church.fs +++ b/src/PrayerTracker/Church.fs @@ -1,6 +1,5 @@ module PrayerTracker.Handlers.Church -open FSharp.Control.Tasks.V2.ContextInsensitive open Giraffe open PrayerTracker open PrayerTracker.Entities @@ -10,99 +9,90 @@ open System open System.Threading.Tasks /// Find statistics for the given church -let private findStats (db : AppDbContext) churchId = - task { - let! grps = db.CountGroupsByChurch churchId - let! reqs = db.CountRequestsByChurch churchId - let! usrs = db.CountUsersByChurch churchId - return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs } - } +let private findStats (db : AppDbContext) churchId = task { + let! grps = db.CountGroupsByChurch churchId + let! reqs = db.CountRequestsByChurch churchId + let! usrs = db.CountUsersByChurch churchId + return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs } + } /// POST /church/[church-id]/delete let delete churchId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF - >=> fun next ctx -> - let db = ctx.dbContext () - task { - match! db.TryChurchById churchId with - | Some church -> - let! _, stats = findStats db churchId - db.RemoveEntry church - let! _ = 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 "/web/churches" next ctx - | None -> return! fourOhFour next ctx - } + >=> fun next ctx -> task { + match! ctx.db.TryChurchById churchId with + | Some church -> + 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 "/web/churches" next ctx + | None -> return! fourOhFour next ctx + } /// GET /church/[church-id]/edit let edit churchId : HttpHandler = requireAccess [ Admin ] - >=> fun next ctx -> + >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - task { - match churchId with - | x when x = Guid.Empty -> - return! - viewInfo ctx startTicks - |> Views.Church.edit EditChurch.empty ctx - |> renderHtml next ctx - | _ -> - let db = ctx.dbContext () - match! db.TryChurchById churchId with - | Some church -> - return! - viewInfo ctx startTicks - |> Views.Church.edit (EditChurch.fromChurch church) ctx - |> renderHtml next ctx - | None -> return! fourOhFour next ctx - } + match churchId with + | x when x = Guid.Empty -> + return! + viewInfo ctx startTicks + |> Views.Church.edit EditChurch.empty ctx + |> renderHtml next ctx + | _ -> + match! ctx.db.TryChurchById churchId with + | Some church -> + return! + viewInfo ctx startTicks + |> Views.Church.edit (EditChurch.fromChurch church) ctx + |> renderHtml next ctx + | None -> return! fourOhFour next ctx + } /// GET /churches let maintain : HttpHandler = requireAccess [ Admin ] - >=> fun next ctx -> - let startTicks = DateTime.Now.Ticks - let await = Async.AwaitTask >> Async.RunSynchronously - let db = ctx.dbContext () - task { - let! churches = db.AllChurches () - let stats = churches |> List.map (fun c -> await (findStats db c.churchId)) - return! - viewInfo ctx startTicks - |> Views.Church.maintain churches (stats |> Map.ofList) ctx - |> renderHtml next ctx - } + >=> 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.churchId)) + return! + viewInfo ctx startTicks + |> Views.Church.maintain churches (stats |> Map.ofList) ctx + |> renderHtml next ctx + } /// POST /church/save let save : HttpHandler = requireAccess [ Admin ] >=> validateCSRF - >=> fun next ctx -> - task { - match! ctx.TryBindFormAsync () with - | Ok m -> - let db = ctx.dbContext () - let! church = - match m.isNew () with - | true -> Task.FromResult(Some { Church.empty with churchId = Guid.NewGuid () }) - | false -> db.TryChurchById m.churchId - match church with - | Some ch -> - m.populateChurch ch - |> (match m.isNew () with true -> db.AddEntry | false -> db.UpdateEntry) - let! _ = db.SaveChangesAsync () - let s = Views.I18N.localizer.Force () - let act = s.[match m.isNew () with true -> "Added" | _ -> "Updated"].Value.ToLower () - addInfo ctx s.["Successfully {0} church “{1}”", act, m.name] - return! redirectTo false "/web/churches" next ctx - | None -> return! fourOhFour next ctx - | Error e -> return! bindError e next ctx - } + >=> fun next ctx -> task { + match! ctx.TryBindFormAsync () with + | Ok m -> + let! church = + match m.isNew () with + | true -> Task.FromResult(Some { Church.empty with churchId = Guid.NewGuid () }) + | false -> ctx.db.TryChurchById m.churchId + match church with + | Some ch -> + m.populateChurch ch + |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry) + let! _ = ctx.db.SaveChangesAsync () + let s = Views.I18N.localizer.Force () + let act = s.[match m.isNew () with true -> "Added" | _ -> "Updated"].Value.ToLower () + addInfo ctx s.["Successfully {0} church “{1}”", act, m.name] + return! redirectTo false "/web/churches" next ctx + | None -> return! fourOhFour next ctx + | Error e -> return! bindError e next ctx + } diff --git a/src/PrayerTracker/CommonFunctions.fs b/src/PrayerTracker/CommonFunctions.fs index 00f5a46..158376f 100644 --- a/src/PrayerTracker/CommonFunctions.fs +++ b/src/PrayerTracker/CommonFunctions.fs @@ -2,7 +2,6 @@ [] module PrayerTracker.Handlers.CommonFunctions -open FSharp.Control.Tasks.V2.ContextInsensitive open Giraffe open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Html @@ -54,31 +53,23 @@ let appVersion = |> String.concat "" #endif -/// An option of the currently signed-in user -let tryCurrentUser (ctx : HttpContext) = - ctx.Session.GetUser () - /// The currently signed-in user (will raise if none exists) -let currentUser ctx = - match tryCurrentUser ctx with Some u -> u | None -> nullArg "User" - -/// An option of the currently signed-in small group -let tryCurrentGroup (ctx : HttpContext) = - ctx.Session.GetSmallGroup () +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 = - match tryCurrentGroup ctx with Some g -> g | None -> nullArg "SmallGroup" +let currentGroup (ctx : HttpContext) = + match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup" /// Create the common view information heading let viewInfo (ctx : HttpContext) startTicks = let msg = - match ctx.Session.GetMessages () with + match ctx.Session.messages with | [] -> [] | x -> - ctx.Session.SetMessages [] + ctx.Session.messages <- [] x - match tryCurrentUser ctx with + 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. @@ -96,8 +87,8 @@ let viewInfo (ctx : HttpContext) startTicks = version = appVersion messages = msg requestStart = startTicks - user = ctx.Session.GetUser () - group = ctx.Session.GetSmallGroup () + user = ctx.Session.user + group = ctx.Session.smallGroup } /// The view is the last parameter, so it can be composed @@ -118,20 +109,17 @@ let fourOhFour next (ctx : HttpContext) = /// Handler to validate CSRF prevention token let validateCSRF : HttpHandler = - fun next ctx -> - let antiForgery = ctx.GetService () - task { - let! isValid = antiForgery.IsRequestValidAsync ctx - match isValid with - | true -> return! next ctx - | false -> - return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx - } + fun next ctx -> task { + match! (ctx.GetService ()).IsRequestValidAsync ctx with + | true -> return! next ctx + | false -> + return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx + } /// Add a message to the session let addUserMessage (ctx : HttpContext) msg = - msg :: ctx.Session.GetMessages () |> ctx.Session.SetMessages + ctx.Session.messages <- msg :: ctx.Session.messages /// Convert a localized string to an HTML string let htmlLocString (x : LocalizedString) = @@ -174,99 +162,94 @@ let requireAccess level : HttpHandler = /// Is there currently a user logged on? let isUserLoggedOn (ctx : HttpContext) = - ctx.Session.GetUser () |> Option.isSome + 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 db = ctx.dbContext () - let! user = db.TryUserById c.Id - match user with - | Some _ -> - ctx.Session.SetUser user - let! grp = db.TryGroupById c.GroupId - ctx.Session.SetSmallGroup grp - | _ -> () - | _ -> () - // If something above doesn't work, the user doesn't get logged in - with _ -> () + 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 c.Id + match user with + | Some _ -> + ctx.Session.user <- user + let! grp = ctx.db.TryGroupById 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 db = ctx.dbContext () - let! user = db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash - match user with - | Some _ -> - ctx.Session.SetUser user - let! grp = db.TryGroupById c.GroupId - ctx.Session.SetSmallGroup grp - // Rewrite the cookie to extend the expiration - ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh) - | _ -> () - | _ -> () - } + let logOnUserFromCookie (ctx : HttpContext) = task { + match UserCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.user] with + | Some c -> + let! user = ctx.db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash + match user with + | Some _ -> + ctx.Session.user <- user + let! grp = ctx.db.TryGroupById 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.GetSmallGroup () |> Option.isSome + 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.dbContext ()).TryGroupLogOnByCookie c.GroupId c.PasswordHash sha1Hash + let! grp = ctx.db.TryGroupLogOnByCookie c.GroupId c.PasswordHash sha1Hash match grp with | Some _ -> - ctx.Session.SetSmallGroup grp + 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 - match isUserLoggedOn ctx with - | true -> () - | false -> - do! logOnUserFromTimeoutCookie ctx - match isUserLoggedOn ctx with - | true -> () - | false -> - do! logOnUserFromCookie ctx - match isGroupLoggedOn ctx with true -> () | false -> do! logOnGroupFromCookie ctx + fun next ctx -> FSharp.Control.Tasks.Affine.task { + // Auto-logon user or class, if required + match isUserLoggedOn ctx with + | true -> () + | false -> + do! logOnUserFromTimeoutCookie ctx + match isUserLoggedOn ctx with + | true -> () + | false -> + do! logOnUserFromCookie ctx + match isGroupLoggedOn ctx with true -> () | false -> 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 "/web/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 "/web/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 "/web/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 "/web/unauthorized" next 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 "/web/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 "/web/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 "/web/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 "/web/unauthorized" next ctx + } diff --git a/src/PrayerTracker/Cookies.fs b/src/PrayerTracker/Cookies.fs index 6eca03f..13fc471 100644 --- a/src/PrayerTracker/Cookies.fs +++ b/src/PrayerTracker/Cookies.fs @@ -6,6 +6,7 @@ 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) = @@ -24,7 +25,7 @@ module private Crypto = /// Encrypt a cookie payload let encrypt (payload : string) = - use aes = new AesManaged () + use aes = Aes.Create () use enc = aes.CreateEncryptor (crypto.Key, crypto.IV) use ms = new MemoryStream () use cs = new CryptoStream (ms, enc, CryptoStreamMode.Write) @@ -35,7 +36,7 @@ module private Crypto = /// Decrypt a cookie payload let decrypt payload = - use aes = new AesManaged () + 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) diff --git a/src/PrayerTracker/Email.fs b/src/PrayerTracker/Email.fs index 87dc18c..1ab9ce0 100644 --- a/src/PrayerTracker/Email.fs +++ b/src/PrayerTracker/Email.fs @@ -1,7 +1,6 @@ /// Methods for sending e-mails module PrayerTracker.Email -open FSharp.Control.Tasks.ContextInsensitive open MailKit.Net.Smtp open MailKit.Security open Microsoft.Extensions.Localization @@ -14,12 +13,11 @@ let private fromAddress = "prayer@bitbadger.solutions" /// Get an SMTP client connection // FIXME: make host configurable -let getConnection () = - task { - let client = new SmtpClient () - do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None) - return client - } +let getConnection () = task { + let client = new SmtpClient () + do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None) + return client + } /// Create a mail message object, filled with everything but the body content let createMessage (grp : SmallGroup) subj = @@ -60,21 +58,20 @@ let createTextMessage grp subj body (s : IStringLocalizer) = msg /// Send e-mails to a class -let sendEmails (client : SmtpClient) (recipients : Member list) grp subj html text s = - task { - let htmlMsg = createHtmlMessage grp subj html s - let plainTextMsg = createTextMessage grp subj text s +let sendEmails (client : SmtpClient) (recipients : Member list) grp subj html text s = task { + let htmlMsg = createHtmlMessage grp subj html s + let plainTextMsg = createTextMessage grp subj text s - for mbr in recipients do - let emailType = match mbr.format with Some f -> EmailFormat.fromCode f | None -> grp.preferences.defaultEmailType - let emailTo = MailboxAddress (mbr.memberName, mbr.email) - match emailType with - | HtmlFormat -> - htmlMsg.To.Add emailTo - do! client.SendAsync htmlMsg - htmlMsg.To.Clear () - | PlainTextFormat -> - plainTextMsg.To.Add emailTo - do! client.SendAsync plainTextMsg - plainTextMsg.To.Clear () - } + for mbr in recipients do + let emailType = match mbr.format with Some f -> EmailFormat.fromCode f | None -> grp.preferences.defaultEmailType + let emailTo = MailboxAddress (mbr.memberName, mbr.email) + match emailType with + | HtmlFormat -> + htmlMsg.To.Add emailTo + do! client.SendAsync htmlMsg + htmlMsg.To.Clear () + | PlainTextFormat -> + plainTextMsg.To.Add emailTo + do! client.SendAsync plainTextMsg + plainTextMsg.To.Clear () + } diff --git a/src/PrayerTracker/Extensions.fs b/src/PrayerTracker/Extensions.fs index f8c93c7..29b5ce2 100644 --- a/src/PrayerTracker/Extensions.fs +++ b/src/PrayerTracker/Extensions.fs @@ -2,11 +2,13 @@ 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 type ISession with /// Set an object in the session @@ -19,28 +21,32 @@ type ISession with | null -> Unchecked.defaultof<'T> | v -> JsonConvert.DeserializeObject<'T> v - member this.GetSmallGroup () = - this.GetObject Key.Session.currentGroup |> Option.fromObject - member this.SetSmallGroup (group : SmallGroup option) = - match group with - | Some g -> this.SetObject Key.Session.currentGroup g - | None -> this.Remove Key.Session.currentGroup + /// 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 - member this.GetUser () = - this.GetObject Key.Session.currentUser |> Option.fromObject - member this.SetUser (user: User option) = - match user with - | Some u -> this.SetObject Key.Session.currentUser u - | None -> this.Remove Key.Session.currentUser + /// 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 - member this.GetMessages () = - match box (this.GetObject Key.Session.userMessages) with - | null -> List.empty - | msgs -> unbox msgs - member this.SetMessages (messages : UserMessage list) = - this.SetObject Key.Session.userMessages messages + /// Current messages for the session + member this.messages + with get () = + match box (this.GetObject Key.Session.userMessages) with + | null -> List.empty + | msgs -> unbox msgs + and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v type HttpContext with - /// Get the EF database context from DI - member this.dbContext () : AppDbContext = downcast this.RequestServices.GetService typeof + /// The EF Core database context (via DI) + member this.db + with get () = this.RequestServices.GetRequiredService () diff --git a/src/PrayerTracker/PrayerRequest.fs b/src/PrayerTracker/PrayerRequest.fs index f272c6a..0b68fef 100644 --- a/src/PrayerTracker/PrayerRequest.fs +++ b/src/PrayerTracker/PrayerRequest.fs @@ -1,6 +1,5 @@ module PrayerTracker.Handlers.PrayerRequest -open FSharp.Control.Tasks.V2.ContextInsensitive open Giraffe open Microsoft.AspNetCore.Http open NodaTime @@ -11,16 +10,15 @@ open System open System.Threading.Tasks /// Retrieve a prayer request, and ensure that it belongs to the current class -let private findRequest (ctx : HttpContext) reqId = - task { - match! ctx.dbContext().TryRequestById reqId with - | Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> 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 Error (redirectTo false "/web/unauthorized") - | None -> return Error fourOhFour - } +let private findRequest (ctx : HttpContext) reqId = task { + match! ctx.db.TryRequestById reqId with + | Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> 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 Error (redirectTo false "/web/unauthorized") + | None -> return Error fourOhFour + } /// Generate a list of requests for the given date let private generateRequestList ctx date = @@ -30,12 +28,12 @@ let private generateRequestList ctx date = match date with | Some d -> d | None -> grp.localDateNow clock - let reqs = ctx.dbContext().AllRequestsForSmallGroup grp clock (Some listDate) true 0 + let reqs = ctx.db.AllRequestsForSmallGroup grp clock (Some listDate) true 0 { requests = reqs |> List.ofSeq date = listDate listGroup = grp showHeader = true - canEmail = tryCurrentUser ctx |> Option.isSome + canEmail = ctx.Session.user |> Option.isSome recipients = [] } @@ -49,139 +47,130 @@ let private parseListDate (date : string option) = /// GET /prayer-request/[request-id]/edit let edit (reqId : PrayerRequestId) : HttpHandler = requireAccess [ User ] - >=> fun next ctx -> + >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks let grp = currentGroup ctx let now = grp.localDateNow (ctx.GetService ()) - task { - match reqId = Guid.Empty with - | true -> - return! - { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } - |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx - |> renderHtml next ctx - | false -> - match! findRequest ctx reqId with - | Ok req -> - let s = Views.I18N.localizer.Force () - match req.isExpired now grp.preferences.daysToExpire with - | true -> - { UserMessage.warning with - text = htmlLocString s.["This request is expired."] - description = - s.["To make it active again, update it as necessary, leave “{0}” and “{1}” unchecked, and it will return as an active request.", - s.["Expire Immediately"], s.["Check to not update the date"]] - |> (htmlLocString >> Some) - } - |> addUserMessage ctx - | false -> () - return! - { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } - |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx - |> renderHtml next ctx - | Error e -> return! e next ctx - } + match reqId = Guid.Empty with + | true -> + return! + { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } + |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx + |> renderHtml next ctx + | false -> + match! findRequest ctx reqId with + | Ok req -> + let s = Views.I18N.localizer.Force () + match req.isExpired now grp.preferences.daysToExpire with + | true -> + { UserMessage.warning with + text = htmlLocString s.["This request is expired."] + description = + s.["To make it active again, update it as necessary, leave “{0}” and “{1}” unchecked, and it will return as an active request.", + s.["Expire Immediately"], s.["Check to not update the date"]] + |> (htmlLocString >> Some) + } + |> addUserMessage ctx + | false -> () + return! + { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } + |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx + |> renderHtml next ctx + | Error e -> return! e next ctx + } /// GET /prayer-requests/email/[date] let email date : HttpHandler = requireAccess [ User ] - >=> fun next ctx -> - let startTicks = DateTime.Now.Ticks - let s = Views.I18N.localizer.Force () - let listDate = parseListDate (Some date) - let grp = currentGroup ctx - task { - let list = generateRequestList ctx listDate - let! recipients = ctx.dbContext().AllMembersForSmallGroup grp.smallGroupId - use! client = Email.getConnection () - do! Email.sendEmails client recipients - grp s.["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value - (list.asHtml s) (list.asText s) s - return! - viewInfo ctx startTicks - |> Views.PrayerRequest.email { list with recipients = recipients } - |> renderHtml next ctx - } + >=> 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 list = generateRequestList ctx listDate + let! recipients = ctx.db.AllMembersForSmallGroup grp.smallGroupId + use! client = Email.getConnection () + do! Email.sendEmails client recipients + grp s.["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value + (list.asHtml s) (list.asText s) s + return! + viewInfo ctx startTicks + |> Views.PrayerRequest.email { list with recipients = recipients } + |> renderHtml next ctx + } /// POST /prayer-request/[request-id]/delete let delete reqId : HttpHandler = requireAccess [ User ] >=> validateCSRF - >=> fun next ctx -> - task { - match! findRequest ctx reqId with - | Ok req -> - let db = ctx.dbContext () - let s = Views.I18N.localizer.Force () - db.PrayerRequests.Remove req |> ignore - let! _ = db.SaveChangesAsync () - addInfo ctx s.["The prayer request was deleted successfully"] - return! redirectTo false "/web/prayer-requests" next ctx - | Error e -> return! e next ctx - } + >=> fun next ctx -> task { + match! findRequest ctx reqId with + | Ok req -> + let s = Views.I18N.localizer.Force () + ctx.db.PrayerRequests.Remove req |> ignore + let! _ = ctx.db.SaveChangesAsync () + addInfo ctx s.["The prayer request was deleted successfully"] + return! redirectTo false "/web/prayer-requests" next ctx + | Error e -> return! e next ctx + } /// GET /prayer-request/[request-id]/expire let expire reqId : HttpHandler = requireAccess [ User ] - >=> fun next ctx -> - task { - match! findRequest ctx reqId with - | Ok req -> - let db = ctx.dbContext () - let s = Views.I18N.localizer.Force () - db.UpdateEntry { req with expiration = Forced } - let! _ = db.SaveChangesAsync () - addInfo ctx s.["Successfully {0} prayer request", s.["Expired"].Value.ToLower ()] - return! redirectTo false "/web/prayer-requests" next ctx - | Error e -> return! e next ctx - } + >=> fun next ctx -> task { + match! findRequest ctx reqId with + | Ok req -> + let s = Views.I18N.localizer.Force () + 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 "/web/prayer-requests" next ctx + | Error e -> return! e next ctx + } /// GET /prayer-requests/[group-id]/list let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] - >=> fun next ctx -> + >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let db = ctx.dbContext () - task { - match! db.TryGroupById groupId with - | Some grp when grp.preferences.isPublic -> - let clock = ctx.GetService () - let reqs = db.AllRequestsForSmallGroup grp clock None true 0 - return! - viewInfo ctx startTicks - |> Views.PrayerRequest.list - { requests = List.ofSeq reqs - date = grp.localDateNow clock - listGroup = grp - showHeader = true - canEmail = (tryCurrentUser >> Option.isSome) ctx - recipients = [] - } - |> renderHtml next ctx - | Some _ -> - 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 "/web/unauthorized" next ctx - | None -> return! fourOhFour next ctx - } + 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 + return! + viewInfo ctx startTicks + |> Views.PrayerRequest.list + { requests = List.ofSeq reqs + date = grp.localDateNow clock + listGroup = grp + showHeader = true + canEmail = ctx.Session.user |> Option.isSome + recipients = [] + } + |> renderHtml next ctx + | Some _ -> + 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 "/web/unauthorized" next ctx + | None -> return! fourOhFour next ctx + } /// GET /prayer-requests/lists let lists : HttpHandler = requireAccess [ AccessLevel.Public ] - >=> fun next ctx -> - let startTicks = DateTime.Now.Ticks - task { - let! grps = ctx.dbContext().PublicAndProtectedGroups () - return! - viewInfo ctx startTicks - |> Views.PrayerRequest.lists grps - |> renderHtml next ctx - } + >=> fun next ctx -> task { + let startTicks = DateTime.Now.Ticks + let! grps = ctx.db.PublicAndProtectedGroups () + return! + viewInfo ctx startTicks + |> Views.PrayerRequest.lists grps + |> renderHtml next ctx + } /// GET /prayer-requests[/inactive?] @@ -191,108 +180,97 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let startTicks = DateTime.Now.Ticks - let db = ctx.dbContext () let grp = currentGroup ctx - task { - let pageNbr = - match ctx.GetQueryStringValue "page" with - | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1 - | Error _ -> 1 - let m = - match ctx.GetQueryStringValue "search" with - | Ok srch -> - { MaintainRequests.empty with - requests = db.SearchRequestsForSmallGroup grp srch pageNbr - searchTerm = Some srch - pageNbr = Some pageNbr - } - | Error _ -> - { MaintainRequests.empty with - requests = db.AllRequestsForSmallGroup grp (ctx.GetService ()) None onlyActive pageNbr - onlyActive = Some onlyActive - pageNbr = match onlyActive with true -> None | false -> Some pageNbr - } - return! - { viewInfo ctx startTicks with helpLink = Some Help.maintainRequests } - |> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx - |> renderHtml next ctx - } + let pageNbr = + match ctx.GetQueryStringValue "page" with + | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1 + | Error _ -> 1 + let m = + match ctx.GetQueryStringValue "search" with + | Ok srch -> + { MaintainRequests.empty with + requests = ctx.db.SearchRequestsForSmallGroup grp srch pageNbr + searchTerm = Some srch + pageNbr = Some pageNbr + } + | Error _ -> + { MaintainRequests.empty with + requests = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService ()) None onlyActive pageNbr + onlyActive = Some onlyActive + pageNbr = match onlyActive with true -> None | false -> Some pageNbr + } + { viewInfo ctx startTicks with helpLink = Some Help.maintainRequests } + |> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx + |> renderHtml next ctx /// GET /prayer-request/print/[date] let print date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> - let listDate = parseListDate (Some date) - task { - let list = generateRequestList ctx listDate - return! - Views.PrayerRequest.print list appVersion - |> renderHtml next ctx - } + let list = parseListDate (Some date) |> generateRequestList ctx + Views.PrayerRequest.print list appVersion + |> renderHtml next ctx + /// GET /prayer-request/[request-id]/restore let restore reqId : HttpHandler = requireAccess [ User ] - >=> fun next ctx -> - task { - match! findRequest ctx reqId with - | Ok req -> - let db = ctx.dbContext () - let s = Views.I18N.localizer.Force () - db.UpdateEntry { req with expiration = Automatic; updatedDate = DateTime.Now } - let! _ = db.SaveChangesAsync () - addInfo ctx s.["Successfully {0} prayer request", s.["Restored"].Value.ToLower ()] - return! redirectTo false "/web/prayer-requests" next ctx - | Error e -> return! e next ctx - } + >=> fun next ctx -> task { + match! findRequest ctx reqId with + | Ok req -> + let s = Views.I18N.localizer.Force () + 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 "/web/prayer-requests" next ctx + | Error e -> return! e next ctx + } /// POST /prayer-request/save let save : HttpHandler = requireAccess [ User ] >=> validateCSRF - >=> fun next ctx -> - task { - match! ctx.TryBindFormAsync () with - | Ok m -> - let db = ctx.dbContext () - let! req = + >=> fun next ctx -> task { + match! ctx.TryBindFormAsync () with + | Ok m -> + let! req = + match m.isNew () with + | true -> Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () }) + | false -> ctx.db.TryRequestById m.requestId + match req with + | Some pr -> + let upd8 = + { pr with + requestType = PrayerRequestType.fromCode m.requestType + requestor = match m.requestor with Some x when x.Trim () = "" -> None | x -> x + text = ckEditorToText m.text + expiration = Expiration.fromCode m.expiration + } + let grp = currentGroup ctx + let now = grp.localDateNow (ctx.GetService ()) match m.isNew () with - | true -> Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () }) - | false -> db.TryRequestById m.requestId - match req with - | Some pr -> - let upd8 = - { pr with - requestType = PrayerRequestType.fromCode m.requestType - requestor = match m.requestor with Some x when x.Trim () = "" -> None | x -> x - text = ckEditorToText m.text - expiration = Expiration.fromCode m.expiration + | true -> + let dt = match m.enteredDate with Some x -> x | None -> now + { upd8 with + smallGroupId = grp.smallGroupId + userId = (currentUser ctx).userId + enteredDate = dt + updatedDate = dt } - let grp = currentGroup ctx - let now = grp.localDateNow (ctx.GetService ()) - match m.isNew () with - | true -> - let dt = match m.enteredDate with Some x -> x | None -> now - { upd8 with - smallGroupId = grp.smallGroupId - userId = (currentUser ctx).userId - enteredDate = dt - updatedDate = dt - } - | false when Option.isSome m.skipDateUpdate && Option.get m.skipDateUpdate -> upd8 - | false -> { upd8 with updatedDate = now } - |> (match m.isNew () with true -> db.AddEntry | false -> db.UpdateEntry) - let! _ = db.SaveChangesAsync () - let s = Views.I18N.localizer.Force () - let act = match m.isNew () with true -> "Added" | false -> "Updated" - addInfo ctx s.["Successfully {0} prayer request", s.[act].Value.ToLower ()] - return! redirectTo false "/web/prayer-requests" next ctx - | None -> return! fourOhFour next ctx - | Error e -> return! bindError e next ctx - } + | false when Option.isSome m.skipDateUpdate && Option.get m.skipDateUpdate -> upd8 + | false -> { upd8 with updatedDate = now } + |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry) + let! _ = ctx.db.SaveChangesAsync () + let s = Views.I18N.localizer.Force () + let act = match m.isNew () with true -> "Added" | false -> "Updated" + addInfo ctx s.["Successfully {0} prayer request", s.[act].Value.ToLower ()] + return! redirectTo false "/web/prayer-requests" next ctx + | None -> return! fourOhFour next ctx + | Error e -> return! bindError e next ctx + } /// GET /prayer-request/view/[date?] @@ -300,11 +278,7 @@ let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> let startTicks = DateTime.Now.Ticks - let listDate = parseListDate date - task { - let list = generateRequestList ctx listDate - return! - viewInfo ctx startTicks - |> Views.PrayerRequest.view { list with showHeader = false } - |> renderHtml next ctx - } + let list = parseListDate date |> generateRequestList ctx + viewInfo ctx startTicks + |> Views.PrayerRequest.view { list with showHeader = false } + |> renderHtml next ctx diff --git a/src/PrayerTracker/PrayerTracker.fsproj b/src/PrayerTracker/PrayerTracker.fsproj index 1cdc542..21f3089 100644 --- a/src/PrayerTracker/PrayerTracker.fsproj +++ b/src/PrayerTracker/PrayerTracker.fsproj @@ -1,7 +1,7 @@  - net5.0 + net6.0 @@ -23,10 +23,9 @@ - - + - + diff --git a/src/PrayerTracker/SmallGroup.fs b/src/PrayerTracker/SmallGroup.fs index 77685ac..442067d 100644 --- a/src/PrayerTracker/SmallGroup.fs +++ b/src/PrayerTracker/SmallGroup.fs @@ -1,8 +1,7 @@ module PrayerTracker.Handlers.SmallGroup -open FSharp.Control.Tasks.V2.ContextInsensitive open Giraffe -open Giraffe.GiraffeViewEngine +open Giraffe.ViewEngine open Microsoft.AspNetCore.Http open NodaTime open PrayerTracker @@ -33,66 +32,60 @@ let announcement : HttpHandler = let delete groupId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF - >=> fun next ctx -> - let db = ctx.dbContext () - let s = Views.I18N.localizer.Force () - task { - match! db.TryGroupById groupId with - | Some grp -> - let! reqs = db.CountRequestsBySmallGroup groupId - let! usrs = db.CountUsersBySmallGroup groupId - db.RemoveEntry grp - let! _ = 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, usrs] - return! redirectTo false "/web/small-groups" next ctx - | None -> return! fourOhFour next ctx - } + >=> fun next ctx -> task { + let s = Views.I18N.localizer.Force () + match! ctx.db.TryGroupById groupId with + | Some grp -> + let! reqs = ctx.db.CountRequestsBySmallGroup groupId + let! usrs = 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, usrs] + return! redirectTo false "/web/small-groups" next ctx + | None -> return! fourOhFour next ctx + } /// POST /small-group/member/[member-id]/delete let deleteMember memberId : HttpHandler = requireAccess [ User ] >=> validateCSRF - >=> fun next ctx -> - let db = ctx.dbContext () + >=> fun next ctx -> task { let s = Views.I18N.localizer.Force () - task { - match! db.TryMemberById memberId with - | Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId -> - db.RemoveEntry mbr - let! _ = db.SaveChangesAsync () - addHtmlInfo ctx s.["The group member “{0}” was deleted successfully", mbr.memberName] - return! redirectTo false "/web/small-group/members" next ctx - | Some _ - | None -> return! fourOhFour next ctx - } + match! ctx.db.TryMemberById memberId with + | Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId -> + ctx.db.RemoveEntry mbr + let! _ = ctx.db.SaveChangesAsync () + addHtmlInfo ctx s.["The group member “{0}” was deleted successfully", mbr.memberName] + return! redirectTo false "/web/small-group/members" next ctx + | Some _ + | None -> return! fourOhFour next ctx + } /// GET /small-group/[group-id]/edit let edit (groupId : SmallGroupId) : HttpHandler = requireAccess [ Admin ] - >=> fun next ctx -> - let startTicks = DateTime.Now.Ticks - let db = ctx.dbContext () - task { - let! churches = db.AllChurches () - match groupId = Guid.Empty with - | true -> - return! - viewInfo ctx startTicks - |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx - |> renderHtml next ctx - | false -> - match! 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 - } + >=> fun next ctx -> task { + let startTicks = DateTime.Now.Ticks + let! churches = ctx.db.AllChurches () + match groupId = Guid.Empty with + | true -> + return! + viewInfo ctx startTicks + |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx + |> renderHtml next ctx + | false -> + 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 + } /// GET /small-group/member/[member-id]/edit @@ -100,7 +93,6 @@ let editMember (memberId : MemberId) : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let startTicks = DateTime.Now.Ticks - let db = ctx.dbContext () let s = Views.I18N.localizer.Force () let grp = currentGroup ctx let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s @@ -112,7 +104,7 @@ let editMember (memberId : MemberId) : HttpHandler = |> Views.SmallGroup.editMember EditMember.empty typs ctx |> renderHtml next ctx | false -> - match! db.TryMemberById memberId with + match! ctx.db.TryMemberById memberId with | Some mbr when mbr.smallGroupId = grp.smallGroupId -> return! viewInfo ctx startTicks @@ -129,8 +121,8 @@ let logOn (groupId : SmallGroupId option) : HttpHandler = >=> fun next ctx -> let startTicks = DateTime.Now.Ticks task { - let! grps = ctx.dbContext().ProtectedGroups () - let grpId = match groupId with Some gid -> flatGuid gid | None -> "" + let! grps = ctx.db.ProtectedGroups () + let grpId = match groupId with Some gid -> flatGuid gid | None -> "" return! { viewInfo ctx startTicks with helpLink = Some Help.logOn } |> Views.SmallGroup.logOn grps grpId ctx @@ -147,9 +139,9 @@ let logOnSubmit : HttpHandler = match! ctx.TryBindFormAsync () with | Ok m -> let s = Views.I18N.localizer.Force () - match! ctx.dbContext().TryGroupLogOnByPassword m.smallGroupId m.password with + match! ctx.db.TryGroupLogOnByPassword m.smallGroupId m.password with | Some grp -> - (Some >> ctx.Session.SetSmallGroup) grp + ctx.Session.smallGroup <- Some grp match m.rememberMe with | Some x when x -> (setGroupCookie ctx << sha1Hash) m.password | _ -> () @@ -168,7 +160,7 @@ let maintain : HttpHandler = >=> fun next ctx -> let startTicks = DateTime.Now.Ticks task { - let! grps = ctx.dbContext().AllGroups () + let! grps = ctx.db.AllGroups () return! viewInfo ctx startTicks |> Views.SmallGroup.maintain grps ctx @@ -181,11 +173,10 @@ let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let startTicks = DateTime.Now.Ticks - let db = ctx.dbContext () let grp = currentGroup ctx let s = Views.I18N.localizer.Force () task { - let! mbrs = db.AllMembersForSmallGroup grp.smallGroupId + let! mbrs = ctx.db.AllMembersForSmallGroup grp.smallGroupId let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s |> Map.ofSeq return! { viewInfo ctx startTicks with helpLink = Some Help.maintainGroupMembers } @@ -199,12 +190,11 @@ let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let startTicks = DateTime.Now.Ticks - let db = ctx.dbContext () let clock = ctx.GetService () task { - let reqs = db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 |> List.ofSeq - let! reqCount = db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId - let! mbrCount = db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId + let reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 |> List.ofSeq + let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId + let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId let m = { totalActiveReqs = List.length reqs allReqs = reqCount @@ -230,7 +220,7 @@ let preferences : HttpHandler = >=> fun next ctx -> let startTicks = DateTime.Now.Ticks task { - let! tzs = ctx.dbContext().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 @@ -247,20 +237,19 @@ let save : HttpHandler = task { match! ctx.TryBindFormAsync () with | Ok m -> - let db = ctx.dbContext () let! group = match m.isNew () with | true -> Task.FromResult(Some { SmallGroup.empty with smallGroupId = Guid.NewGuid () }) - | false -> db.TryGroupById m.smallGroupId + | false -> ctx.db.TryGroupById m.smallGroupId match group with | Some grp -> m.populateGroup grp |> function | grp when m.isNew () -> - db.AddEntry grp - db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId } - | grp -> db.UpdateEntry grp - let! _ = db.SaveChangesAsync () + ctx.db.AddEntry grp + ctx.db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId } + | grp -> ctx.db.UpdateEntry grp + let! _ = ctx.db.SaveChangesAsync () let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower () addHtmlInfo ctx s.["Successfully {0} group “{1}”", act, m.name] return! redirectTo false "/web/small-groups" next ctx @@ -278,7 +267,6 @@ let saveMember : HttpHandler = match! ctx.TryBindFormAsync () with | Ok m -> let grp = currentGroup ctx - let db = ctx.dbContext () let! mMbr = match m.isNew () with | true -> @@ -288,7 +276,7 @@ let saveMember : HttpHandler = memberId = Guid.NewGuid () smallGroupId = grp.smallGroupId }) - | false -> db.TryMemberById m.memberId + | false -> ctx.db.TryMemberById m.memberId match mMbr with | Some mbr when mbr.smallGroupId = grp.smallGroupId -> { mbr with @@ -296,8 +284,8 @@ let saveMember : HttpHandler = email = m.emailAddress format = match m.emailType with "" | null -> None | _ -> Some m.emailType } - |> (match m.isNew () with true -> db.AddEntry | false -> db.UpdateEntry) - let! _ = db.SaveChangesAsync () + |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry) + let! _ = ctx.db.SaveChangesAsync () let s = Views.I18N.localizer.Force () let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower () addInfo ctx s.["Successfully {0} group member", act] @@ -316,17 +304,16 @@ let savePreferences : HttpHandler = task { match! ctx.TryBindFormAsync () with | Ok m -> - let db = ctx.dbContext () // 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! db.TryGroupById (currentGroup ctx).smallGroupId with + match! ctx.db.TryGroupById (currentGroup ctx).smallGroupId with | Some grp -> let prefs = m.populatePreferences grp.preferences - db.UpdateEntry prefs - let! _ = db.SaveChangesAsync () + ctx.db.UpdateEntry prefs + let! _ = ctx.db.SaveChangesAsync () // Refresh session instance - ctx.Session.SetSmallGroup <| Some { grp with preferences = prefs } + ctx.Session.smallGroup <- Some { grp with preferences = prefs } let s = Views.I18N.localizer.Force () addInfo ctx s.["Group preferences updated successfully"] return! redirectTo false "/web/small-group/preferences" next ctx @@ -346,7 +333,6 @@ let sendAnnouncement : HttpHandler = | Ok m -> let grp = currentGroup ctx let usr = currentUser ctx - let db = ctx.dbContext () let now = grp.localTimeNow (ctx.GetService ()) let s = Views.I18N.localizer.Force () // Reformat the text to use the class's font stylings @@ -359,8 +345,8 @@ let sendAnnouncement : HttpHandler = // Send the e-mails let! recipients = match m.sendToClass with - | "N" when usr.isAdmin -> db.AllUsersAsMembers () - | _ -> db.AllMembersForSmallGroup grp.smallGroupId + | "N" when usr.isAdmin -> ctx.db.AllUsersAsMembers () + | _ -> ctx.db.AllMembersForSmallGroup grp.smallGroupId use! client = Email.getConnection () do! Email.sendEmails client recipients grp s.["Announcement for {0} - {1:MMMM d, yyyy} {2}", @@ -381,8 +367,8 @@ let sendAnnouncement : HttpHandler = enteredDate = now updatedDate = now } - |> db.AddEntry - let! _ = db.SaveChangesAsync () + |> ctx.db.AddEntry + let! _ = ctx.db.SaveChangesAsync () () // Tell 'em what they've won, Johnny! let toWhom = diff --git a/src/PrayerTracker/User.fs b/src/PrayerTracker/User.fs index 066d7f0..39390d9 100644 --- a/src/PrayerTracker/User.fs +++ b/src/PrayerTracker/User.fs @@ -1,6 +1,5 @@ module PrayerTracker.Handlers.User -open FSharp.Control.Tasks.V2.ContextInsensitive open Giraffe open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Http @@ -23,193 +22,183 @@ let private setUserCookie (ctx : HttpContext) pwHash = /// 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 -let private findUserByPassword m (db : AppDbContext) = - task { - match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with - | Some u when Option.isSome u.salt -> - // Already upgraded; match = success - let pwHash = pbkdf2Hash (Option.get u.salt) m.password - match u.passwordHash = pwHash with - | true -> return Some { u with passwordHash = ""; salt = None; smallGroups = List() }, pwHash - | _ -> return None, "" - | Some u when u.passwordHash = sha1Hash m.password -> - // Not upgraded, but password is good; upgrade 'em! - // Upgrade 'em! - let salt = Guid.NewGuid () - let pwHash = pbkdf2Hash salt m.password - 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, "" - } +let private findUserByPassword m (db : AppDbContext) = task { + match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with + | Some u when Option.isSome u.salt -> + // Already upgraded; match = success + let pwHash = pbkdf2Hash (Option.get u.salt) m.password + match u.passwordHash = pwHash with + | true -> return Some { u with passwordHash = ""; salt = None; smallGroups = List() }, pwHash + | _ -> return None, "" + | Some u when u.passwordHash = sha1Hash m.password -> + // Not upgraded, but password is good; upgrade 'em! + // Upgrade 'em! + let salt = Guid.NewGuid () + let pwHash = pbkdf2Hash salt m.password + 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, "" + } /// POST /user/password/change let changePassword : HttpHandler = requireAccess [ User ] >=> validateCSRF - >=> fun next ctx -> - task { - match! ctx.TryBindFormAsync () with - | Ok m -> - let s = Views.I18N.localizer.Force () - let db = ctx.dbContext () - let curUsr = currentUser ctx - let! dbUsr = db.TryUserById curUsr.userId - let! user = + >=> fun next ctx -> task { + match! ctx.TryBindFormAsync () with + | Ok m -> + let s = Views.I18N.localizer.Force () + let curUsr = currentUser ctx + let! dbUsr = ctx.db.TryUserById curUsr.userId + 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 | _ -> sha1Hash) m.oldPassword + |> ctx.db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId + | _ -> Task.FromResult None + match user with + | Some _ when m.newPassword = m.newPasswordConfirm -> match dbUsr with | Some usr -> - // Check the old password against a possibly non-salted hash - (match usr.salt with | Some salt -> pbkdf2Hash salt | _ -> sha1Hash) m.oldPassword - |> db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId - | _ -> Task.FromResult None - match user with - | Some _ when m.newPassword = m.newPasswordConfirm -> - match dbUsr with - | Some usr -> - // Generate salt if it has not been already - let salt = match usr.salt with Some s -> s | _ -> Guid.NewGuid () - db.UpdateEntry { usr with passwordHash = pbkdf2Hash salt m.newPassword; salt = Some salt } - let! _ = db.SaveChangesAsync () - // If the user is remembered, update the cookie with the new hash - match ctx.Request.Cookies.Keys.Contains Key.Cookie.user with - | true -> setUserCookie ctx usr.passwordHash - | _ -> () - addInfo ctx s.["Your password was changed successfully"] - | None -> addError ctx s.["Unable to change password"] - return! redirectTo false "/web/" next ctx - | Some _ -> - addError ctx s.["The new passwords did not match - your password was NOT changed"] - return! redirectTo false "/web/user/password" next ctx - | None -> - addError ctx s.["The old password was incorrect - your password was NOT changed"] - return! redirectTo false "/web/user/password" next ctx - | Error e -> return! bindError e next ctx - } + // Generate salt if it has not been already + let salt = match usr.salt with Some s -> s | _ -> 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 + match ctx.Request.Cookies.Keys.Contains Key.Cookie.user with + | true -> setUserCookie ctx usr.passwordHash + | _ -> () + addInfo ctx s.["Your password was changed successfully"] + | None -> addError ctx s.["Unable to change password"] + return! redirectTo false "/web/" next ctx + | Some _ -> + addError ctx s.["The new passwords did not match - your password was NOT changed"] + return! redirectTo false "/web/user/password" next ctx + | None -> + addError ctx s.["The old password was incorrect - your password was NOT changed"] + return! redirectTo false "/web/user/password" next ctx + | Error e -> return! bindError e next ctx + } /// POST /user/[user-id]/delete let delete userId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF - >=> fun next ctx -> - task { - let db = ctx.dbContext () - match! db.TryUserById userId with - | Some user -> - db.RemoveEntry user - let! _ = db.SaveChangesAsync () - let s = Views.I18N.localizer.Force () - addInfo ctx s.["Successfully deleted user {0}", user.fullName] - return! redirectTo false "/web/users" next ctx - | _ -> return! fourOhFour next ctx - } + >=> fun next ctx -> task { + match! ctx.db.TryUserById userId with + | Some user -> + ctx.db.RemoveEntry user + let! _ = ctx.db.SaveChangesAsync () + let s = Views.I18N.localizer.Force () + addInfo ctx s.["Successfully deleted user {0}", user.fullName] + return! redirectTo false "/web/users" next ctx + | _ -> return! fourOhFour next ctx + } /// POST /user/log-on let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCSRF - >=> fun next ctx -> - task { - match! ctx.TryBindFormAsync () with - | Ok m -> - let db = ctx.dbContext () - let s = Views.I18N.localizer.Force () - let! usr, pwHash = findUserByPassword m db - let! grp = db.TryGroupById m.smallGroupId - let nextUrl = - match usr with - | Some _ -> - ctx.Session.SetUser usr - ctx.Session.SetSmallGroup grp - match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> () - addHtmlInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]] - match m.redirectUrl with - | None -> "/web/small-group" - | Some x when x = "" -> "/web/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 m.emailAddress].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 - "/web/user/log-on" - return! redirectTo false nextUrl next ctx - | Error e -> return! bindError e next ctx - } + >=> fun next ctx -> task { + match! ctx.TryBindFormAsync () with + | Ok m -> + let s = Views.I18N.localizer.Force () + let! usr, pwHash = findUserByPassword m ctx.db + let! grp = ctx.db.TryGroupById m.smallGroupId + let nextUrl = + match usr with + | Some _ -> + ctx.Session.user <- usr + ctx.Session.smallGroup <- grp + match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> () + addHtmlInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]] + match m.redirectUrl with + | None -> "/web/small-group" + | Some x when x = "" -> "/web/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 m.emailAddress].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 + "/web/user/log-on" + return! redirectTo false nextUrl next ctx + | Error e -> return! bindError e next ctx + } /// GET /user/[user-id]/edit let edit (userId : UserId) : HttpHandler = requireAccess [ Admin ] - >=> fun next ctx -> + >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - task { - match userId = Guid.Empty with - | true -> - return! - viewInfo ctx startTicks - |> Views.User.edit EditUser.empty ctx - |> renderHtml next ctx - | false -> - match! ctx.dbContext().TryUserById userId with - | Some user -> - return! - viewInfo ctx startTicks - |> Views.User.edit (EditUser.fromUser user) ctx - |> renderHtml next ctx - | _ -> return! fourOhFour next ctx - } + match userId = Guid.Empty with + | true -> + return! + viewInfo ctx startTicks + |> Views.User.edit EditUser.empty ctx + |> renderHtml next ctx + | false -> + 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 + } /// GET /user/log-on let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] - >=> fun next ctx -> + >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let s = Views.I18N.localizer.Force () - task { - let! groups = ctx.dbContext().GroupList () - let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl - match url with - | Some _ -> - ctx.Session.Remove Key.Session.redirectUrl - addWarning ctx s.["The page you requested requires authentication; please log on below."] - | None -> () - return! - { viewInfo ctx startTicks with helpLink = Some Help.logOn } - |> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx - |> renderHtml next ctx - } + let s = Views.I18N.localizer.Force () + let! groups = ctx.db.GroupList () + let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl + match url with + | Some _ -> + ctx.Session.Remove Key.Session.redirectUrl + addWarning ctx s.["The page you requested requires authentication; please log on below."] + | None -> () + return! + { viewInfo ctx startTicks with helpLink = Some Help.logOn } + |> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx + |> renderHtml next ctx + } /// GET /users let maintain : HttpHandler = requireAccess [ Admin ] - >=> fun next ctx -> - let startTicks = DateTime.Now.Ticks - task { - let! users = ctx.dbContext().AllUsers () - return! - viewInfo ctx startTicks - |> Views.User.maintain users ctx - |> renderHtml next ctx - } + >=> fun next ctx -> task { + let startTicks = DateTime.Now.Ticks + let! users = ctx.db.AllUsers () + return! + viewInfo ctx startTicks + |> Views.User.maintain users ctx + |> renderHtml next ctx + } /// GET /user/password @@ -225,104 +214,98 @@ let password : HttpHandler = let save : HttpHandler = requireAccess [ Admin ] >=> validateCSRF - >=> fun next ctx -> - task { - match! ctx.TryBindFormAsync () with - | Ok m -> - let db = ctx.dbContext () - let! user = - match m.isNew () with - | true -> Task.FromResult (Some { User.empty with userId = Guid.NewGuid () }) - | false -> db.TryUserById m.userId - let saltedUser = - match user with - | Some u -> - match u.salt with - | None when m.password <> "" -> - // Generate salt so that a new password hash can be generated - Some { u with salt = Some (Guid.NewGuid ()) } - | _ -> - // Leave the user with no salt, so prior hash can be validated/upgraded - user - | _ -> user - match saltedUser with + >=> fun next ctx -> task { + match! ctx.TryBindFormAsync () with + | Ok m -> + let! user = + match m.isNew () with + | true -> Task.FromResult (Some { User.empty with userId = Guid.NewGuid () }) + | false -> ctx.db.TryUserById m.userId + let saltedUser = + match user with | Some u -> - let updatedUser = m.populateUser u (pbkdf2Hash (Option.get u.salt)) - updatedUser |> (match m.isNew () with true -> db.AddEntry | false -> db.UpdateEntry) - let! _ = db.SaveChangesAsync () - let s = Views.I18N.localizer.Force () - match m.isNew () with - | true -> - let h = CommonFunctions.htmlString - { UserMessage.info with - text = h s.["Successfully {0} user", s.["Added"].Value.ToLower ()] - description = - h s.["Please select at least one group for which this user ({0}) is authorized", - updatedUser.fullName] - |> Some - } - |> addUserMessage ctx - return! redirectTo false $"/web/user/{flatGuid u.userId}/small-groups" next ctx - | false -> - addInfo ctx s.["Successfully {0} user", s.["Updated"].Value.ToLower ()] - return! redirectTo false "/web/users" next ctx - | None -> return! fourOhFour next ctx - | Error e -> return! bindError e next ctx - } + match u.salt with + | None when m.password <> "" -> + // Generate salt so that a new password hash can be generated + Some { u with salt = Some (Guid.NewGuid ()) } + | _ -> + // Leave the user with no salt, so prior hash can be validated/upgraded + user + | _ -> user + match saltedUser with + | Some u -> + let updatedUser = m.populateUser u (pbkdf2Hash (Option.get u.salt)) + updatedUser |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry) + let! _ = ctx.db.SaveChangesAsync () + let s = Views.I18N.localizer.Force () + match m.isNew () with + | true -> + let h = CommonFunctions.htmlString + { UserMessage.info with + text = h s.["Successfully {0} user", s.["Added"].Value.ToLower ()] + description = + h s.["Please select at least one group for which this user ({0}) is authorized", + updatedUser.fullName] + |> Some + } + |> addUserMessage ctx + return! redirectTo false $"/web/user/{flatGuid u.userId}/small-groups" next ctx + | false -> + addInfo ctx s.["Successfully {0} user", s.["Updated"].Value.ToLower ()] + return! redirectTo false "/web/users" next ctx + | None -> return! fourOhFour next ctx + | Error e -> return! bindError e next ctx + } /// POST /user/small-groups/save let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCSRF - >=> fun next ctx -> - task { - match! ctx.TryBindFormAsync () with - | Ok m -> - let s = Views.I18N.localizer.Force () - match Seq.length m.smallGroups with - | 0 -> - addError ctx s.["You must select at least one group to assign"] - return! redirectTo false $"/web/user/{flatGuid m.userId}/small-groups" next ctx - | _ -> - let db = ctx.dbContext () - match! db.TryUserByIdWithGroups m.userId with - | Some user -> - let grps = - m.smallGroups.Split ',' - |> Array.map Guid.Parse - |> List.ofArray - user.smallGroups - |> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId))) - |> db.UserGroupXref.RemoveRange - grps - |> 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.userId; smallGroupId = x }) - |> List.ofSeq - |> List.iter db.AddEntry - let! _ = db.SaveChangesAsync () - addInfo ctx s.["Successfully updated group permissions for {0}", m.userName] - return! redirectTo false "/web/users" next ctx - | _ -> return! fourOhFour next ctx - | Error e -> return! bindError e next ctx - } + >=> fun next ctx -> task { + match! ctx.TryBindFormAsync () with + | Ok m -> + let s = Views.I18N.localizer.Force () + match Seq.length m.smallGroups with + | 0 -> + addError ctx s.["You must select at least one group to assign"] + return! redirectTo false $"/web/user/{flatGuid m.userId}/small-groups" next ctx + | _ -> + match! ctx.db.TryUserByIdWithGroups m.userId with + | Some user -> + let grps = + m.smallGroups.Split ',' + |> Array.map Guid.Parse + |> List.ofArray + user.smallGroups + |> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId))) + |> ctx.db.UserGroupXref.RemoveRange + grps + |> 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.userId; smallGroupId = x }) + |> List.ofSeq + |> List.iter ctx.db.AddEntry + let! _ = ctx.db.SaveChangesAsync () + addInfo ctx s.["Successfully updated group permissions for {0}", m.userName] + return! redirectTo false "/web/users" next ctx + | _ -> return! fourOhFour next ctx + | Error e -> return! bindError e next ctx + } /// GET /user/[user-id]/small-groups let smallGroups userId : HttpHandler = requireAccess [ Admin ] - >=> fun next ctx -> + >=> fun next ctx -> task { let startTicks = DateTime.Now.Ticks - let db = ctx.dbContext () - task { - match! db.TryUserByIdWithGroups userId with - | Some user -> - let! grps = db.GroupList () - let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq - return! - viewInfo ctx startTicks - |> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx - |> renderHtml next ctx - | None -> return! fourOhFour next ctx - } + match! ctx.db.TryUserByIdWithGroups userId with + | Some user -> + let! grps = ctx.db.GroupList () + let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq + return! + viewInfo ctx startTicks + |> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx + |> renderHtml next ctx + | None -> return! fourOhFour next ctx + }