bit-badger/PrayerTracker
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 16 Wiki Activity

Tweak ctx/session extensions (#31)

Browse Source
This commit is contained in:
Daniel J. Summers 2021-09-18 22:39:19 -04:00
parent 49d9030f50
commit 84cca56f6f
8 changed files with 668 additions and 743 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/PrayerTracker/App.fs
View File

@ -56,8 +56,9 @@ module Configure =
let crypto = config.GetSection "CookieCrypto"
CookieCrypto (crypto.["Key"], crypto.["IV"]) |> setCrypto
svc.AddDbContext<AppDbContext>(
fun options ->
options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore)
(fun options ->
options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
ServiceLifetime.Scoped, ServiceLifetime.Singleton)
|> ignore
/// Routes for PrayerTracker

39
src/PrayerTracker/Church.fs
View File

@ -9,8 +9,7 @@ open System
open System.Threading.Tasks
/// Find statistics for the given church
let private findStats (db : AppDbContext) churchId =
task {
let private findStats (db : AppDbContext) churchId = task {
let! grps = db.CountGroupsByChurch churchId
let! reqs = db.CountRequestsByChurch churchId
let! usrs = db.CountUsersByChurch churchId
@ -22,14 +21,12 @@ let private findStats (db : AppDbContext) churchId =
let delete churchId : HttpHandler =
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx ->
let db = ctx.dbContext ()
task {
match! db.TryChurchById churchId with
>=> fun next ctx -> task {
match! ctx.db.TryChurchById churchId with
| Some church ->
let! _, stats = findStats db churchId
db.RemoveEntry church
let! _ = db.SaveChangesAsync ()
let! _, stats = findStats ctx.db churchId
ctx.db.RemoveEntry church
let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
addInfo ctx
s.["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)",
@ -42,9 +39,8 @@ let delete churchId : HttpHandler =
/// 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!
@ -52,8 +48,7 @@ let edit churchId : HttpHandler =
|> Views.Church.edit EditChurch.empty ctx
|> renderHtml next ctx
| _ ->
let db = ctx.dbContext ()
match! db.TryChurchById churchId with
match! ctx.db.TryChurchById churchId with
| Some church ->
return!
viewInfo ctx startTicks
@ -66,13 +61,11 @@ let edit churchId : HttpHandler =
/// GET /churches
let maintain : HttpHandler =
requireAccess [ Admin ]
>=> fun next ctx ->
>=> fun next ctx -> task {
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))
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
@ -84,20 +77,18 @@ let maintain : HttpHandler =
let save : HttpHandler =
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx ->
task {
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditChurch> () with
| Ok m ->
let db = ctx.dbContext ()
let! church =
match m.isNew () with
| true -> Task.FromResult<Church option>(Some { Church.empty with churchId = Guid.NewGuid () })
| false -> db.TryChurchById m.churchId
| false -> ctx.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 ()
|> (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]

70
src/PrayerTracker/CommonFunctions.fs
View File

@ -53,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.
@ -95,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
@ -117,11 +109,8 @@ let fourOhFour next (ctx : HttpContext) =
/// Handler to validate CSRF prevention token
let validateCSRF : HttpHandler =
fun next ctx ->
let antiForgery = ctx.GetService<IAntiforgery> ()
task {
let! isValid = antiForgery.IsRequestValidAsync ctx
match isValid with
fun next ctx -> task {
match! (ctx.GetService<IAntiforgery> ()).IsRequestValidAsync ctx with
| true -> return! next ctx
| false ->
return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx
@ -130,7 +119,7 @@ let validateCSRF : HttpHandler =
/// 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) =
@ -173,22 +162,20 @@ 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 {
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
let! user = ctx.db.TryUserById c.Id
match user with
| Some _ ->
ctx.Session.SetUser user
let! grp = db.TryGroupById c.GroupId
ctx.Session.SetSmallGroup grp
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
@ -196,17 +183,15 @@ let requireAccess level : HttpHandler =
}
/// Attempt to log the user on from their stored cookie
let logOnUserFromCookie (ctx : HttpContext) =
task {
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
let! user = ctx.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
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)
| _ -> ()
@ -215,25 +200,24 @@ let requireAccess level : HttpHandler =
/// 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 ->
FSharp.Control.Tasks.Affine.task {
fun next ctx -> FSharp.Control.Tasks.Affine.task {
// Auto-logon user or class, if required
match isUserLoggedOn ctx with
| true -> ()

6
src/PrayerTracker/Email.fs
View File

@ -13,8 +13,7 @@ let private fromAddress = "prayer@bitbadger.solutions"
/// Get an SMTP client connection
// FIXME: make host configurable
let getConnection () =
task {
let getConnection () = task {
let client = new SmtpClient ()
do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None)
return client
@ -59,8 +58,7 @@ 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 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

35
src/PrayerTracker/Extensions.fs
View File

@ -2,6 +2,7 @@
module PrayerTracker.Extensions
open Microsoft.AspNetCore.Http
open Microsoft.Extensions.DependencyInjection
open Microsoft.FSharpLu
open Newtonsoft.Json
open PrayerTracker.Entities
@ -20,28 +21,32 @@ type ISession with
| null -> Unchecked.defaultof<'T>
| v -> JsonConvert.DeserializeObject<'T> v
member this.GetSmallGroup () =
this.GetObject<SmallGroup> Key.Session.currentGroup |> Option.fromObject
member this.SetSmallGroup (group : SmallGroup option) =
match group with
| Some g -> this.SetObject Key.Session.currentGroup g
/// The current small group for the session
member this.smallGroup
with get () = this.GetObject<SmallGroup> 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<User> Key.Session.currentUser |> Option.fromObject
member this.SetUser (user: User option) =
match user with
| Some u -> this.SetObject Key.Session.currentUser u
/// The current user for the session
member this.user
with get () = this.GetObject<User> 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 () =
/// Current messages for the session
member this.messages
with get () =
match box (this.GetObject<UserMessage list> Key.Session.userMessages) with
| null -> List.empty<UserMessage>
| msgs -> unbox msgs
member this.SetMessages (messages : UserMessage list) =
this.SetObject Key.Session.userMessages messages
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<AppDbContext>
/// The EF Core database context (via DI)
member this.db
with get () = this.RequestServices.GetRequiredService<AppDbContext> ()

87
src/PrayerTracker/PrayerRequest.fs
View File

@ -10,9 +10,8 @@ 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
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 ()
@ -29,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 = []
}
@ -48,11 +47,10 @@ 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<IClock> ())
task {
match reqId = Guid.Empty with
| true ->
return!
@ -85,14 +83,13 @@ let edit (reqId : PrayerRequestId) : HttpHandler =
/// GET /prayer-requests/email/[date]
let email date : HttpHandler =
requireAccess [ User ]
>=> fun 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
task {
let list = generateRequestList ctx listDate
let! recipients = ctx.dbContext().AllMembersForSmallGroup grp.smallGroupId
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
@ -108,14 +105,12 @@ let email date : HttpHandler =
let delete reqId : HttpHandler =
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx ->
task {
>=> 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 ()
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
@ -125,14 +120,12 @@ let delete reqId : HttpHandler =
/// GET /prayer-request/[request-id]/expire
let expire reqId : HttpHandler =
requireAccess [ User ]
>=> fun next ctx ->
task {
>=> 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 ()
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
@ -142,14 +135,12 @@ let expire reqId : HttpHandler =
/// 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
match! ctx.db.TryGroupById groupId with
| Some grp when grp.preferences.isPublic ->
let clock = ctx.GetService<IClock> ()
let reqs = db.AllRequestsForSmallGroup grp clock None true 0
let reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0
return!
viewInfo ctx startTicks
|> Views.PrayerRequest.list
@ -157,7 +148,7 @@ let list groupId : HttpHandler =
date = grp.localDateNow clock
listGroup = grp
showHeader = true
canEmail = (tryCurrentUser >> Option.isSome) ctx
canEmail = ctx.Session.user |> Option.isSome
recipients = []
}
|> renderHtml next ctx
@ -172,10 +163,9 @@ let list groupId : HttpHandler =
/// GET /prayer-requests/lists
let lists : HttpHandler =
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
task {
let! grps = ctx.dbContext().PublicAndProtectedGroups ()
let! grps = ctx.db.PublicAndProtectedGroups ()
return!
viewInfo ctx startTicks
|> Views.PrayerRequest.lists grps
@ -190,9 +180,7 @@ 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
@ -201,47 +189,40 @@ let maintain onlyActive : HttpHandler =
match ctx.GetQueryStringValue "search" with
| Ok srch ->
{ MaintainRequests.empty with
requests = db.SearchRequestsForSmallGroup grp srch pageNbr
requests = ctx.db.SearchRequestsForSmallGroup grp srch pageNbr
searchTerm = Some srch
pageNbr = Some pageNbr
}
| Error _ ->
{ MaintainRequests.empty with
requests = db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr
requests = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) 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
}
/// 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!
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 {
>=> 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 ()
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
@ -252,15 +233,13 @@ let restore reqId : HttpHandler =
let save : HttpHandler =
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx ->
task {
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditRequest> () with
| Ok m ->
let db = ctx.dbContext ()
let! req =
match m.isNew () with
| true -> Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () })
| false -> db.TryRequestById m.requestId
| false -> ctx.db.TryRequestById m.requestId
match req with
| Some pr ->
let upd8 =
@ -283,8 +262,8 @@ let save : HttpHandler =
}
| 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 ()
|> (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 ()]
@ -299,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!
let list = parseListDate date |> generateRequestList ctx
viewInfo ctx startTicks
|> Views.PrayerRequest.view { list with showHeader = false }
|> renderHtml next ctx
}

91
src/PrayerTracker/SmallGroup.fs
View File

@ -32,16 +32,14 @@ let announcement : HttpHandler =
let delete groupId : HttpHandler =
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx ->
let db = ctx.dbContext ()
>=> fun next ctx -> task {
let s = Views.I18N.localizer.Force ()
task {
match! db.TryGroupById groupId with
match! ctx.db.TryGroupById groupId with
| Some grp ->
let! reqs = db.CountRequestsBySmallGroup groupId
let! usrs = db.CountUsersBySmallGroup groupId
db.RemoveEntry grp
let! _ = db.SaveChangesAsync ()
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]
@ -54,14 +52,12 @@ let delete groupId : HttpHandler =
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
match! ctx.db.TryMemberById memberId with
| Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId ->
db.RemoveEntry mbr
let! _ = db.SaveChangesAsync ()
ctx.db.RemoveEntry mbr
let! _ = ctx.db.SaveChangesAsync ()
addHtmlInfo ctx s.["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.memberName]
return! redirectTo false "/web/small-group/members" next ctx
| Some _
@ -72,11 +68,9 @@ let deleteMember memberId : HttpHandler =
/// GET /small-group/[group-id]/edit
let edit (groupId : SmallGroupId) : HttpHandler =
requireAccess [ Admin ]
>=> fun next ctx ->
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext ()
task {
let! churches = db.AllChurches ()
let! churches = ctx.db.AllChurches ()
match groupId = Guid.Empty with
| true ->
return!
@ -84,7 +78,7 @@ let edit (groupId : SmallGroupId) : HttpHandler =
|> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
|> renderHtml next ctx
| false ->
match! db.TryGroupById groupId with
match! ctx.db.TryGroupById groupId with
| Some grp ->
return!
viewInfo ctx startTicks
@ -99,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
@ -111,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
@ -128,7 +121,7 @@ let logOn (groupId : SmallGroupId option) : HttpHandler =
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks
task {
let! grps = ctx.dbContext().ProtectedGroups ()
let! grps = ctx.db.ProtectedGroups ()
let grpId = match groupId with Some gid -> flatGuid gid | None -> ""
return!
{ viewInfo ctx startTicks with helpLink = Some Help.logOn }
@ -146,9 +139,9 @@ let logOnSubmit : HttpHandler =
match! ctx.TryBindFormAsync<GroupLogOn> () 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
| _ -> ()
@ -167,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
@ -180,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 }
@ -198,12 +190,11 @@ let overview : HttpHandler =
requireAccess [ User ]
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext ()
let clock = ctx.GetService<IClock> ()
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
@ -229,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
@ -246,20 +237,19 @@ let save : HttpHandler =
task {
match! ctx.TryBindFormAsync<EditSmallGroup> () with
| Ok m ->
let db = ctx.dbContext ()
let! group =
match m.isNew () with
| true -> Task.FromResult<SmallGroup option>(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
@ -277,7 +267,6 @@ let saveMember : HttpHandler =
match! ctx.TryBindFormAsync<EditMember> () with
| Ok m ->
let grp = currentGroup ctx
let db = ctx.dbContext ()
let! mMbr =
match m.isNew () with
| true ->
@ -287,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
@ -295,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]
@ -315,17 +304,16 @@ let savePreferences : HttpHandler =
task {
match! ctx.TryBindFormAsync<EditPreferences> () 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
@ -345,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<IClock> ())
let s = Views.I18N.localizer.Force ()
// Reformat the text to use the class's font stylings
@ -358,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}",
@ -380,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 =

82
src/PrayerTracker/User.fs
View File

@ -22,8 +22,7 @@ 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 {
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
@ -48,20 +47,18 @@ let private findUserByPassword m (db : AppDbContext) =
let changePassword : HttpHandler =
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx ->
task {
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<ChangePassword> () with
| Ok m ->
let s = Views.I18N.localizer.Force ()
let db = ctx.dbContext ()
let curUsr = currentUser ctx
let! dbUsr = db.TryUserById curUsr.userId
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
|> db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId
|> ctx.db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId
| _ -> Task.FromResult None
match user with
| Some _ when m.newPassword = m.newPasswordConfirm ->
@ -69,8 +66,8 @@ let changePassword : HttpHandler =
| 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 ()
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
@ -92,13 +89,11 @@ let changePassword : HttpHandler =
let delete userId : HttpHandler =
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx ->
task {
let db = ctx.dbContext ()
match! db.TryUserById userId with
>=> fun next ctx -> task {
match! ctx.db.TryUserById userId with
| Some user ->
db.RemoveEntry user
let! _ = db.SaveChangesAsync ()
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
@ -110,19 +105,17 @@ let delete userId : HttpHandler =
let doLogOn : HttpHandler =
requireAccess [ AccessLevel.Public ]
>=> validateCSRF
>=> fun next ctx ->
task {
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<UserLogOn> () 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! usr, pwHash = findUserByPassword m ctx.db
let! grp = ctx.db.TryGroupById m.smallGroupId
let nextUrl =
match usr with
| Some _ ->
ctx.Session.SetUser usr
ctx.Session.SetSmallGroup grp
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
@ -156,9 +149,8 @@ let doLogOn : HttpHandler =
/// 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!
@ -166,7 +158,7 @@ let edit (userId : UserId) : HttpHandler =
|> Views.User.edit EditUser.empty ctx
|> renderHtml next ctx
| false ->
match! ctx.dbContext().TryUserById userId with
match! ctx.db.TryUserById userId with
| Some user ->
return!
viewInfo ctx startTicks
@ -179,11 +171,10 @@ let edit (userId : UserId) : HttpHandler =
/// 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! groups = ctx.db.GroupList ()
let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
match url with
| Some _ ->
@ -200,10 +191,9 @@ let logOn : HttpHandler =
/// GET /users
let maintain : HttpHandler =
requireAccess [ Admin ]
>=> fun next ctx ->
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
task {
let! users = ctx.dbContext().AllUsers ()
let! users = ctx.db.AllUsers ()
return!
viewInfo ctx startTicks
|> Views.User.maintain users ctx
@ -224,15 +214,13 @@ let password : HttpHandler =
let save : HttpHandler =
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx ->
task {
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditUser> () 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
| false -> ctx.db.TryUserById m.userId
let saltedUser =
match user with
| Some u ->
@ -247,8 +235,8 @@ let save : HttpHandler =
match saltedUser 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 ()
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 ->
@ -274,8 +262,7 @@ let save : HttpHandler =
let saveGroups : HttpHandler =
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx ->
task {
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<AssignGroups> () with
| Ok m ->
let s = Views.I18N.localizer.Force ()
@ -284,8 +271,7 @@ let saveGroups : HttpHandler =
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
match! ctx.db.TryUserByIdWithGroups m.userId with
| Some user ->
let grps =
m.smallGroups.Split ','
@ -293,14 +279,14 @@ let saveGroups : HttpHandler =
|> List.ofArray
user.smallGroups
|> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId)))
|> db.UserGroupXref.RemoveRange
|> 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 db.AddEntry
let! _ = db.SaveChangesAsync ()
|> 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
@ -311,13 +297,11 @@ let saveGroups : HttpHandler =
/// 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
match! ctx.db.TryUserByIdWithGroups userId with
| Some user ->
let! grps = db.GroupList ()
let! grps = ctx.db.GroupList ()
let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq
return!
viewInfo ctx startTicks