diff --git a/src/PrayerTracker.UI/Utils.fs b/src/PrayerTracker.UI/Utils.fs index bd9abde..b68e28b 100644 --- a/src/PrayerTracker.UI/Utils.fs +++ b/src/PrayerTracker.UI/Utils.fs @@ -139,7 +139,10 @@ let makeUrl url qs = /// "Magic string" repository [] module Key = - + + /// The request start time (added via middleware, read when rendering the footer) + let startTime = "StartTime" + /// This contains constants for session-stored objects within PrayerTracker module Session = @@ -155,24 +158,6 @@ module Key = /// The URL to which the user should be redirected once they have logged in let redirectUrl = "RedirectUrl" - /// Names and value names for use with cookies - module Cookie = - - /// The name of the user cookie - let user = "LoggedInUser" - - /// The name of the class cookie - let group = "LoggedInClass" - - /// The name of the culture cookie - let culture = "CurrentCulture" - - /// The name of the idle timeout cookie - let timeout = "TimeoutCookie" - - /// The cookies that should be cleared when a user or group logs off - let logOffCookies = [ user; group; timeout ] - /// Enumerated values for small group request list visibility (derived from preferences, used in UI) module GroupVisibility = diff --git a/src/PrayerTracker/App.fs b/src/PrayerTracker/App.fs index 4b58bc8..16ca9ab 100644 --- a/src/PrayerTracker/App.fs +++ b/src/PrayerTracker/App.fs @@ -1,5 +1,17 @@ namespace PrayerTracker +open System +open Microsoft.AspNetCore.Http + +/// Middleware to add the starting ticks for the request +type RequestStartMiddleware (next : RequestDelegate) = + + member this.InvokeAsync (ctx : HttpContext) = task { + ctx.Items[Key.startTime] <- DateTime.Now.Ticks + return! next.Invoke ctx + } + + open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.Hosting @@ -23,7 +35,6 @@ module Configure = 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 @@ -54,19 +65,19 @@ module Configure = let _ = svc.AddSession() let _ = svc.AddAntiforgery() let _ = svc.AddRouting() - let _ = svc.AddSingleton(SystemClock.Instance) + let _ = svc.AddSingleton SystemClock.Instance - let config = svc.BuildServiceProvider().GetRequiredService() - let _ = svc.AddDbContext( - (fun options -> - options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore), - ServiceLifetime.Scoped, ServiceLifetime.Singleton) + let config = svc.BuildServiceProvider().GetRequiredService () + 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 + redirectTo true $"""/{string ctx.Request.RouteValues["path"]}""" next ctx open Giraffe.EndpointRouting @@ -186,6 +197,8 @@ module Configure = let _ = app.UseStatusCodePagesWithReExecute "/error/{0}" let _ = app.UseStaticFiles () + let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) + let _ = app.UseMiddleware () let _ = app.UseRouting () let _ = app.UseSession () let _ = app.UseRequestLocalization diff --git a/src/PrayerTracker/Church.fs b/src/PrayerTracker/Church.fs index 167222c..baf6302 100644 --- a/src/PrayerTracker/Church.fs +++ b/src/PrayerTracker/Church.fs @@ -33,17 +33,16 @@ open System /// GET /church/[church-id]/edit let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks if churchId = Guid.Empty then return! - viewInfo ctx startTicks + viewInfo ctx |> Views.Church.edit EditChurch.empty ctx |> renderHtml next ctx else match! ctx.Db.TryChurchById (ChurchId churchId) with | Some church -> return! - viewInfo ctx startTicks + viewInfo ctx |> Views.Church.edit (EditChurch.fromChurch church) ctx |> renderHtml next ctx | None -> return! fourOhFour ctx @@ -51,12 +50,11 @@ let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> ta /// 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 await = Async.AwaitTask >> Async.RunSynchronously + let! churches = ctx.Db.AllChurches () + let stats = churches |> List.map (fun c -> await (findStats ctx.Db c.Id)) return! - viewInfo ctx startTicks + viewInfo ctx |> Views.Church.maintain churches (stats |> Map.ofList) ctx |> renderHtml next ctx } diff --git a/src/PrayerTracker/CommonFunctions.fs b/src/PrayerTracker/CommonFunctions.fs index c401f23..d7fa6ac 100644 --- a/src/PrayerTracker/CommonFunctions.fs +++ b/src/PrayerTracker/CommonFunctions.fs @@ -48,7 +48,7 @@ open PrayerTracker open PrayerTracker.ViewModels /// Create the common view information heading -let viewInfo (ctx : HttpContext) startTicks = +let viewInfo (ctx : HttpContext) = let msg = match ctx.Session.Messages with | [] -> [] @@ -63,9 +63,9 @@ let viewInfo (ctx : HttpContext) startTicks = { AppViewInfo.fresh with Version = appVersion Messages = msg - RequestStart = startTicks - User = ctx.CurrentUser - Group = ctx.CurrentGroup + RequestStart = ctx.Items[Key.startTime] :?> int64 + User = ctx.Session.CurrentUser + Group = ctx.Session.CurrentGroup Layout = layout } @@ -141,7 +141,9 @@ open PrayerTracker.Entities /// Require one of the given access roles let requireAccess levels : HttpHandler = fun next ctx -> task { - match ctx.CurrentUser, ctx.CurrentGroup with + let! user = ctx.CurrentUser () + let! group = ctx.CurrentGroup () + match user, group 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 diff --git a/src/PrayerTracker/Extensions.fs b/src/PrayerTracker/Extensions.fs index 4f214c0..8c1b107 100644 --- a/src/PrayerTracker/Extensions.fs +++ b/src/PrayerTracker/Extensions.fs @@ -2,6 +2,7 @@ module PrayerTracker.Extensions open Microsoft.AspNetCore.Http +open Microsoft.FSharpLu open Newtonsoft.Json open PrayerTracker.Entities open PrayerTracker.ViewModels @@ -17,6 +18,22 @@ type ISession with member this.GetObject<'T> key = match this.GetString key with null -> Unchecked.defaultof<'T> | v -> JsonConvert.DeserializeObject<'T> v + /// The currently logged on small group + member this.CurrentGroup + 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 currently logged on user + member this.CurrentUser + 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 + /// Current messages for the session member this.Messages with get () = @@ -26,27 +43,63 @@ type ISession with and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v +open System.Security.Claims + +/// Extensions on the claims principal +type ClaimsPrincipal with + + /// The ID of the currently logged on small group + member this.SmallGroupId = + if this.HasClaim (fun c -> c.Type = ClaimTypes.GroupSid) then + Some (idFromShort SmallGroupId (this.FindFirst(fun c -> c.Type = ClaimTypes.GroupSid).Value)) + else None + + /// The ID of the currently signed in user + member this.UserId = + if this.HasClaim (fun c -> c.Type = ClaimTypes.NameIdentifier) then + Some (idFromShort UserId (this.FindFirst(fun c -> c.Type = ClaimTypes.NameIdentifier).Value)) + else None + + open Giraffe -open Microsoft.FSharpLu +open NodaTime +open PrayerTracker /// 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 = this.GetService () + + /// The system clock (via DI) + member this.Clock = this.GetService () + + /// The currently logged on small group (sets the value in the session if it is missing) + member this.CurrentGroup () = task { + match this.Session.CurrentGroup with + | Some group -> return Some group + | None -> + match this.User.SmallGroupId with + | Some groupId -> + match! this.Db.TryGroupById groupId with + | Some group -> + this.Session.CurrentGroup <- Some group + return Some group + | None -> return None + | None -> return None + } + + /// The currently logged on user (sets the value in the session if it is missing) + member this.CurrentUser () = task { + match this.Session.CurrentUser with + | Some user -> return Some user + | None -> + match this.User.UserId with + | Some userId -> + match! this.Db.TryUserById userId with + | Some user -> + this.Session.CurrentUser <- Some user + return Some user + | None -> return None + | None -> return None + } diff --git a/src/PrayerTracker/Home.fs b/src/PrayerTracker/Home.fs index b51e2ab..93957e7 100644 --- a/src/PrayerTracker/Home.fs +++ b/src/PrayerTracker/Home.fs @@ -9,13 +9,13 @@ open PrayerTracker /// GET /error/[error-code] let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> - viewInfo ctx DateTime.Now.Ticks + viewInfo ctx |> Views.Home.error code |> renderHtml next ctx /// GET / let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> - viewInfo ctx DateTime.Now.Ticks + viewInfo ctx |> Views.Home.index |> renderHtml next ctx @@ -44,13 +44,13 @@ let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fu /// GET /legal/privacy-policy let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> - viewInfo ctx DateTime.Now.Ticks + viewInfo ctx |> 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 + viewInfo ctx |> Views.Home.termsOfService |> renderHtml next ctx @@ -68,6 +68,6 @@ let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx /// GET /unauthorized let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> - viewInfo ctx DateTime.Now.Ticks + viewInfo ctx |> Views.Home.unauthorized |> renderHtml next ctx diff --git a/src/PrayerTracker/PrayerRequest.fs b/src/PrayerTracker/PrayerRequest.fs index c2ac94e..8802bb5 100644 --- a/src/PrayerTracker/PrayerRequest.fs +++ b/src/PrayerTracker/PrayerRequest.fs @@ -9,7 +9,7 @@ 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 = ctx.CurrentGroup.Value.Id -> return Ok req + | Some req when req.SmallGroupId = ctx.Session.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"] @@ -17,20 +17,17 @@ let private findRequest (ctx : HttpContext) reqId = task { | None -> return Result.Error (fourOhFour ctx) } -open NodaTime - /// Generate a list of requests for the given date 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 group = ctx.Session.CurrentGroup.Value + let listDate = match date with Some d -> d | None -> group.LocalDateNow ctx.Clock + let! reqs = ctx.Db.AllRequestsForSmallGroup group ctx.Clock (Some listDate) true 0 return { Requests = reqs Date = listDate - SmallGroup = grp + SmallGroup = group ShowHeader = true - CanEmail = Option.isSome ctx.CurrentUser + CanEmail = Option.isSome ctx.User.UserId Recipients = [] } } @@ -45,20 +42,19 @@ 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 = ctx.CurrentGroup.Value - let now = grp.LocalDateNow (ctx.GetService ()) - let requestId = PrayerRequestId reqId + let group = ctx.Session.CurrentGroup.Value + let now = group.LocalDateNow ctx.Clock + let requestId = PrayerRequestId reqId if requestId.Value = Guid.Empty then return! - { viewInfo ctx startTicks with HelpLink = Some Help.editRequest } + { viewInfo ctx with HelpLink = Some Help.editRequest } |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx |> renderHtml next ctx else match! findRequest ctx requestId with | Ok req -> let s = Views.I18N.localizer.Force () - if req.IsExpired now grp.Preferences.DaysToExpire then + if req.IsExpired now group.Preferences.DaysToExpire then { UserMessage.warning with Text = htmlLocString s["This request is expired."] Description = @@ -68,7 +64,7 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { } |> addUserMessage ctx return! - { viewInfo ctx startTicks with HelpLink = Some Help.editRequest } + { viewInfo ctx with HelpLink = Some Help.editRequest } |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx |> renderHtml next ctx | Result.Error e -> return! e @@ -76,18 +72,17 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { /// GET /prayer-requests/email/[date] 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 = ctx.CurrentGroup.Value - let! list = generateRequestList ctx listDate - let! recipients = ctx.Db.AllMembersForSmallGroup grp.Id - use! client = Email.getConnection () + let s = Views.I18N.localizer.Force () + let listDate = parseListDate (Some date) + let group = ctx.Session.CurrentGroup.Value + let! list = generateRequestList ctx listDate + let! recipients = ctx.Db.AllMembersForSmallGroup group.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 + group s["Prayer Requests for {0} - {1:MMMM d, yyyy}", group.Name, list.Date].Value (list.AsHtml s) (list.AsText s) s return! - viewInfo ctx startTicks + viewInfo ctx |> Views.PrayerRequest.email { list with Recipients = recipients } |> renderHtml next ctx } @@ -120,19 +115,17 @@ let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task /// 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 - | Some grp when grp.Preferences.IsPublic -> - let clock = ctx.GetService () - let! reqs = ctx.Db.AllRequestsForSmallGroup grp clock None true 0 + | Some group when group.Preferences.IsPublic -> + let! reqs = ctx.Db.AllRequestsForSmallGroup group ctx.Clock None true 0 return! - viewInfo ctx startTicks + viewInfo ctx |> Views.PrayerRequest.list { Requests = reqs - Date = grp.LocalDateNow clock - SmallGroup = grp + Date = group.LocalDateNow ctx.Clock + SmallGroup = group ShowHeader = true - CanEmail = Option.isSome ctx.CurrentUser + CanEmail = Option.isSome ctx.User.UserId Recipients = [] } |> renderHtml next ctx @@ -145,10 +138,9 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne /// 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 + viewInfo ctx |> Views.PrayerRequest.lists groups |> renderHtml next ctx } @@ -157,16 +149,15 @@ let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx /// - OR - /// GET /prayer-requests?search=[search-query] let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks - let grp = ctx.CurrentGroup.Value - let pageNbr = + let group = ctx.Session.CurrentGroup.Value + let pageNbr = match ctx.GetQueryStringValue "page" with | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1 | Result.Error _ -> 1 - let! m = backgroundTask { + let! model = backgroundTask { match ctx.GetQueryStringValue "search" with | Ok search -> - let! reqs = ctx.Db.SearchRequestsForSmallGroup grp search pageNbr + let! reqs = ctx.Db.SearchRequestsForSmallGroup group search pageNbr return { MaintainRequests.empty with Requests = reqs @@ -174,7 +165,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 group ctx.Clock None onlyActive pageNbr return { MaintainRequests.empty with Requests = reqs @@ -183,8 +174,8 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx } } return! - { viewInfo ctx startTicks with HelpLink = Some Help.maintainRequests } - |> Views.PrayerRequest.maintain { m with SmallGroup = grp } ctx + { viewInfo ctx with HelpLink = Some Help.maintainRequests } + |> Views.PrayerRequest.maintain { model with SmallGroup = group } ctx |> renderHtml next ctx } @@ -214,36 +205,37 @@ open System.Threading.Tasks /// POST /prayer-request/save let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with - | Ok m -> + | Ok model -> let! req = - if m.IsNew then Task.FromResult (Some { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () }) - else ctx.Db.TryRequestById (idFromShort PrayerRequestId m.RequestId) + if model.IsNew then + Task.FromResult (Some { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () }) + else ctx.Db.TryRequestById (idFromShort PrayerRequestId model.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 + RequestType = PrayerRequestType.fromCode model.RequestType + Requestor = match model.Requestor with Some x when x.Trim () = "" -> None | x -> x + Text = ckEditorToText model.Text + Expiration = Expiration.fromCode model.Expiration } - let grp = ctx.CurrentGroup.Value - let now = grp.LocalDateNow (ctx.GetService ()) - match m.IsNew with + let group = ctx.Session.CurrentGroup.Value + let now = group.LocalDateNow ctx.Clock + match model.IsNew with | true -> - let dt = defaultArg m.EnteredDate now + let dt = defaultArg model.EnteredDate now { upd8 with - SmallGroupId = grp.Id - UserId = ctx.CurrentUser.Value.Id + SmallGroupId = group.Id + UserId = ctx.User.UserId.Value EnteredDate = dt UpdatedDate = dt } - | false when defaultArg m.SkipDateUpdate false -> upd8 + | false when defaultArg model.SkipDateUpdate false -> upd8 | false -> { upd8 with UpdatedDate = now } - |> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry + |> if model.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" + let act = if model.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 ctx @@ -252,10 +244,9 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct /// GET /prayer-request/view/[date?] let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks - let! list = generateRequestList ctx (parseListDate date) + let! list = generateRequestList ctx (parseListDate date) return! - viewInfo ctx startTicks + viewInfo ctx |> Views.PrayerRequest.view { list with ShowHeader = false } |> renderHtml next ctx } diff --git a/src/PrayerTracker/SmallGroup.fs b/src/PrayerTracker/SmallGroup.fs index 415fe57..10d4e2f 100644 --- a/src/PrayerTracker/SmallGroup.fs +++ b/src/PrayerTracker/SmallGroup.fs @@ -8,8 +8,8 @@ open PrayerTracker.ViewModels /// 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 ctx.CurrentUser.Value.IsAdmin ctx + { viewInfo ctx with HelpLink = Some Help.sendAnnouncement } + |> Views.SmallGroup.announcement ctx.Session.CurrentUser.Value.IsAdmin ctx |> renderHtml next ctx /// POST /small-group/[group-id]/delete @@ -32,9 +32,10 @@ let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fu /// 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 group = ctx.Session.CurrentGroup.Value let memberId = MemberId mbrId match! ctx.Db.TryMemberById memberId with - | Some mbr when mbr.SmallGroupId = ctx.CurrentGroup.Value.Id -> + | Some mbr when mbr.SmallGroupId = group.Id -> ctx.Db.RemoveEntry mbr let! _ = ctx.Db.SaveChangesAsync () addHtmlInfo ctx s["The group member “{0}” was deleted successfully", mbr.Name] @@ -45,19 +46,18 @@ let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf > /// 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 groupId = SmallGroupId grpId + let! churches = ctx.Db.AllChurches () + let groupId = SmallGroupId grpId if groupId.Value = Guid.Empty then return! - viewInfo ctx startTicks + viewInfo ctx |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx |> renderHtml next ctx else match! ctx.Db.TryGroupById groupId with | Some grp -> return! - viewInfo ctx startTicks + viewInfo ctx |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx |> renderHtml next ctx | None -> return! fourOhFour ctx @@ -65,21 +65,20 @@ let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task /// 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 = ctx.CurrentGroup.Value - let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s - let memberId = MemberId mbrId + let s = Views.I18N.localizer.Force () + let group = ctx.Session.CurrentGroup.Value + let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType s + let memberId = MemberId mbrId if memberId.Value = Guid.Empty then return! - viewInfo ctx startTicks + viewInfo ctx |> Views.SmallGroup.editMember EditMember.empty types ctx |> renderHtml next ctx else match! ctx.Db.TryMemberById memberId with - | Some mbr when mbr.SmallGroupId = grp.Id -> + | Some mbr when mbr.SmallGroupId = group.Id -> return! - viewInfo ctx startTicks + viewInfo ctx |> Views.SmallGroup.editMember (EditMember.fromMember mbr) types ctx |> renderHtml next ctx | Some _ @@ -88,11 +87,10 @@ let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next 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 groupId = match grpId with Some gid -> shortGuid gid | None -> "" + let! groups = ctx.Db.ProtectedGroups () + let groupId = match grpId with Some gid -> shortGuid gid | None -> "" return! - { viewInfo ctx startTicks with HelpLink = Some Help.logOn } + { viewInfo ctx with HelpLink = Some Help.logOn } |> Views.SmallGroup.logOn groups groupId ctx |> renderHtml next ctx } @@ -108,7 +106,7 @@ let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validat let s = Views.I18N.localizer.Force () match! ctx.Db.TryGroupLogOnByPassword (idFromShort SmallGroupId model.SmallGroupId) model.Password with | Some group -> - ctx.CurrentGroup <- Some group + ctx.Session.CurrentGroup <- Some group let claims = Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) |> Seq.singleton let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) do! ctx.SignInAsync @@ -126,38 +124,32 @@ let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validat /// GET /small-groups let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks let! groups = ctx.Db.AllGroups () return! - viewInfo ctx startTicks + viewInfo ctx |> Views.SmallGroup.maintain groups ctx |> renderHtml next ctx } /// GET /small-group/members let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks - let grp = ctx.CurrentGroup.Value - let s = Views.I18N.localizer.Force () - let! members = ctx.Db.AllMembersForSmallGroup grp.Id - let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s |> Map.ofSeq + let group = ctx.Session.CurrentGroup.Value + let s = Views.I18N.localizer.Force () + let! members = ctx.Db.AllMembersForSmallGroup group.Id + let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType s |> Map.ofSeq return! - { viewInfo ctx startTicks with HelpLink = Some Help.maintainGroupMembers } + { viewInfo ctx with HelpLink = Some Help.maintainGroupMembers } |> Views.SmallGroup.members members types ctx |> renderHtml next ctx } -open NodaTime - /// GET /small-group let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks - let clock = ctx.GetService () - 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 = + let group = ctx.Session.CurrentGroup.Value + let! reqs = ctx.Db.AllRequestsForSmallGroup group ctx.Clock None true 0 + let! reqCount = ctx.Db.CountRequestsBySmallGroup group.Id + let! mbrCount = ctx.Db.CountMembersForSmallGroup group.Id + let model = { TotalActiveReqs = List.length reqs AllReqs = reqCount TotalMembers = mbrCount @@ -170,18 +162,18 @@ let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { |> Map.ofSeq) } return! - viewInfo ctx startTicks - |> Views.SmallGroup.overview m + viewInfo ctx + |> Views.SmallGroup.overview model |> renderHtml next ctx } /// GET /small-group/preferences let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks - let! tzs = ctx.Db.AllTimeZones () + let group = ctx.Session.CurrentGroup.Value + let! tzs = ctx.Db.AllTimeZones () return! - { viewInfo ctx startTicks with HelpLink = Some Help.groupPreferences } - |> Views.SmallGroup.preferences (EditPreferences.fromPreferences ctx.CurrentGroup.Value.Preferences) tzs ctx + { viewInfo ctx with HelpLink = Some Help.groupPreferences } + |> Views.SmallGroup.preferences (EditPreferences.fromPreferences group.Preferences) tzs ctx |> renderHtml next ctx } @@ -190,22 +182,22 @@ open System.Threading.Tasks /// POST /small-group/save let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with - | Ok m -> + | Ok model -> 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) + if model.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () }) + else ctx.Db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId) match group with | Some grp -> - m.populateGroup grp + model.populateGroup grp |> function - | grp when m.IsNew -> + | grp when model.IsNew -> 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] + let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower () + addHtmlInfo ctx s["Successfully {0} group “{1}”", act, model.Name] return! redirectTo false "/small-groups" next ctx | None -> return! fourOhFour ctx | Result.Error e -> return! bindError e next ctx @@ -215,13 +207,13 @@ 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 = ctx.CurrentGroup.Value - let! mMbr = + let group = ctx.Session.CurrentGroup.Value + let! mMbr = if model.IsNew then - Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = grp.Id }) + Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = group.Id }) else ctx.Db.TryMemberById (idFromShort MemberId model.MemberId) match mMbr with - | Some mbr when mbr.SmallGroupId = grp.Id -> + | Some mbr when mbr.SmallGroupId = group.Id -> { mbr with Name = model.Name Email = model.Email @@ -245,13 +237,14 @@ let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> // 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 ctx.CurrentGroup.Value.Id with + let group = ctx.Session.CurrentGroup.Value + match! ctx.Db.TryGroupById group.Id with | Some grp -> let prefs = model.PopulatePreferences grp.Preferences ctx.Db.UpdateEntry prefs let! _ = ctx.Db.SaveChangesAsync () // Refresh session instance - ctx.CurrentGroup <- Some { grp with Preferences = prefs } + ctx.Session.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 @@ -264,28 +257,27 @@ open PrayerTracker.Views.CommonFunctions /// POST /small-group/announcement/send let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks match! ctx.TryBindFormAsync () with | Ok model -> - let grp = ctx.CurrentGroup.Value - let usr = ctx.CurrentUser.Value - let now = grp.LocalTimeNow (ctx.GetService ()) - let s = Views.I18N.localizer.Force () + let group = ctx.Session.CurrentGroup.Value + let prefs = group.Preferences + let usr = ctx.Session.CurrentUser.Value + let now = group.LocalTimeNow ctx.Clock + let s = Views.I18N.localizer.Force () // Reformat the text to use the class's font stylings let requestText = ckEditorToText model.Text let htmlText = - p [ _style $"font-family:{grp.Preferences.Fonts};font-size:%d{grp.Preferences.TextFontSize}pt;" ] - [ rawText requestText ] + p [ _style $"font-family:{prefs.Fonts};font-size:%d{prefs.TextFontSize}pt;" ] [ rawText requestText ] |> renderHtmlNode let plainText = (htmlToPlainText >> wordWrap 74) htmlText // Send the e-mails let! recipients = match model.SendToClass with | "N" when usr.IsAdmin -> ctx.Db.AllUsersAsMembers () - | _ -> ctx.Db.AllMembersForSmallGroup grp.Id + | _ -> ctx.Db.AllMembersForSmallGroup group.Id use! client = Email.getConnection () - do! Email.sendEmails client recipients grp - s["Announcement for {0} - {1:MMMM d, yyyy} {2}", grp.Name, now.Date, + do! Email.sendEmails client recipients group + s["Announcement for {0} - {1:MMMM d, yyyy} {2}", group.Name, now.Date, (now.ToString "h:mm tt").ToLower ()].Value htmlText plainText s // Add to the request list if desired @@ -296,7 +288,7 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> | _, _ -> { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () - SmallGroupId = grp.Id + SmallGroupId = group.Id UserId = usr.Id RequestType = (Option.get >> PrayerRequestType.fromCode) model.RequestType Text = requestText @@ -314,7 +306,7 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> 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 + viewInfo ctx |> 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 995253b..fd7fa6f 100644 --- a/src/PrayerTracker/User.fs +++ b/src/PrayerTracker/User.fs @@ -37,14 +37,15 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f match! ctx.TryBindFormAsync () with | Ok model -> let s = Views.I18N.localizer.Force () - let curUsr = ctx.CurrentUser.Value + let curUsr = ctx.Session.CurrentUser.Value let! dbUsr = ctx.Db.TryUserById curUsr.Id + let group = ctx.Session.CurrentGroup.Value 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) model.OldPassword - |> ctx.Db.TryUserLogOnByCookie curUsr.Id ctx.CurrentGroup.Value.Id + |> ctx.Db.TryUserLogOnByCookie curUsr.Id group.Id | _ -> Task.FromResult None match user with | Some _ when model.NewPassword = model.NewPasswordConfirm -> @@ -96,8 +97,8 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr let! nextUrl = backgroundTask { match usr with | Some user -> - ctx.CurrentUser <- usr - ctx.CurrentGroup <- Some group + ctx.Session.CurrentUser <- usr + ctx.Session.CurrentGroup <- Some group let claims = seq { Claim (ClaimTypes.NameIdentifier, shortGuid user.Id.Value) Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) @@ -144,18 +145,17 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr /// GET /user/[user-id]/edit let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks let userId = UserId usrId if userId.Value = Guid.Empty then return! - viewInfo ctx startTicks + viewInfo ctx |> Views.User.edit EditUser.empty ctx |> renderHtml next ctx else match! ctx.Db.TryUserById userId with | Some user -> return! - viewInfo ctx startTicks + viewInfo ctx |> Views.User.edit (EditUser.fromUser user) ctx |> renderHtml next ctx | _ -> return! fourOhFour ctx @@ -164,17 +164,16 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task /// GET /user/log-on 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 url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl + 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 } + { viewInfo ctx with HelpLink = Some Help.logOn } |> Views.User.logOn { UserLogOn.empty with RedirectUrl = url } groups ctx |> renderHtml next ctx } @@ -182,10 +181,9 @@ 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 + viewInfo ctx |> Views.User.maintain users ctx |> renderHtml next ctx } @@ -193,7 +191,7 @@ let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { /// GET /user/password let password : HttpHandler = requireAccess [ User ] >=> fun next ctx -> - { viewInfo ctx DateTime.Now.Ticks with HelpLink = Some Help.changePassword } + { viewInfo ctx with HelpLink = Some Help.changePassword } |> Views.User.changePassword ctx |> renderHtml next ctx @@ -201,15 +199,15 @@ let password : HttpHandler = requireAccess [ User ] >=> fun next ctx -> /// POST /user/save let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { match! ctx.TryBindFormAsync () with - | Ok m -> + | Ok model -> let! user = - if m.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () }) - else ctx.Db.TryUserById (idFromShort UserId m.UserId) + if model.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () }) + else ctx.Db.TryUserById (idFromShort UserId model.UserId) let saltedUser = match user with | Some u -> match u.Salt with - | None when m.Password <> "" -> + | None when model.Password <> "" -> // Generate salt so that a new password hash can be generated Some { u with Salt = Some (Guid.NewGuid ()) } | _ -> @@ -218,11 +216,11 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c | _ -> user 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 updatedUser = model.PopulateUser u (pbkdf2Hash (Option.get u.Salt)) + updatedUser |> if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry let! _ = ctx.Db.SaveChangesAsync () let s = Views.I18N.localizer.Force () - if m.IsNew then + if model.IsNew then let h = CommonFunctions.htmlString { UserMessage.info with Text = h s["Successfully {0} user", s["Added"].Value.ToLower ()] @@ -275,14 +273,13 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun /// GET /user/[user-id]/small-groups let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { - let startTicks = DateTime.Now.Ticks - let userId = UserId usrId + let userId = UserId usrId match! ctx.Db.TryUserByIdWithGroups userId with | Some user -> let! groups = ctx.Db.GroupList () let curGroups = user.SmallGroups |> Seq.map (fun g -> shortGuid g.SmallGroupId.Value) |> List.ofSeq return! - viewInfo ctx startTicks + viewInfo ctx |> Views.User.assignGroups (AssignGroups.fromUser user) groups curGroups ctx |> renderHtml next ctx | None -> return! fourOhFour ctx