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" let crypto = config.GetSection "CookieCrypto"
CookieCrypto (crypto.["Key"], crypto.["IV"]) |> setCrypto CookieCrypto (crypto.["Key"], crypto.["IV"]) |> setCrypto
svc.AddDbContext<AppDbContext>( svc.AddDbContext<AppDbContext>(
fun options -> (fun options ->
options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore) options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
ServiceLifetime.Scoped, ServiceLifetime.Singleton)
|> ignore |> ignore
/// Routes for PrayerTracker /// Routes for PrayerTracker

137
src/PrayerTracker/Church.fs
View File

@ -9,99 +9,90 @@ open System
open System.Threading.Tasks open System.Threading.Tasks
/// Find statistics for the given church /// Find statistics for the given church
let private findStats (db : AppDbContext) churchId = let private findStats (db : AppDbContext) churchId = task {
task { let! grps = db.CountGroupsByChurch churchId
let! grps = db.CountGroupsByChurch churchId let! reqs = db.CountRequestsByChurch churchId
let! reqs = db.CountRequestsByChurch churchId let! usrs = db.CountUsersByChurch churchId
let! usrs = db.CountUsersByChurch churchId return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs }
return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs } }
}
/// POST /church/[church-id]/delete /// POST /church/[church-id]/delete
let delete churchId : HttpHandler = let delete churchId : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
let db = ctx.dbContext () match! ctx.db.TryChurchById churchId with
task { | Some church ->
match! db.TryChurchById churchId with let! _, stats = findStats ctx.db churchId
| Some church -> ctx.db.RemoveEntry church
let! _, stats = findStats db churchId let! _ = ctx.db.SaveChangesAsync ()
db.RemoveEntry church let s = Views.I18N.localizer.Force ()
let! _ = db.SaveChangesAsync () addInfo ctx
let s = Views.I18N.localizer.Force () s.["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)",
addInfo ctx church.name, stats.smallGroups, stats.prayerRequests, stats.users]
s.["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)", return! redirectTo false "/web/churches" next ctx
church.name, stats.smallGroups, stats.prayerRequests, stats.users] | None -> return! fourOhFour next ctx
return! redirectTo false "/web/churches" next ctx }
| None -> return! fourOhFour next ctx
}
/// GET /church/[church-id]/edit /// GET /church/[church-id]/edit
let edit churchId : HttpHandler = let edit churchId : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { match churchId with
match churchId with | x when x = Guid.Empty ->
| x when x = Guid.Empty -> return!
return! viewInfo ctx startTicks
viewInfo ctx startTicks |> Views.Church.edit EditChurch.empty ctx
|> Views.Church.edit EditChurch.empty ctx |> renderHtml next ctx
|> renderHtml next ctx | _ ->
| _ -> match! ctx.db.TryChurchById churchId with
let db = ctx.dbContext () | Some church ->
match! db.TryChurchById churchId with return!
| Some church -> viewInfo ctx startTicks
return! |> Views.Church.edit (EditChurch.fromChurch church) ctx
viewInfo ctx startTicks |> renderHtml next ctx
|> Views.Church.edit (EditChurch.fromChurch church) ctx | None -> return! fourOhFour next ctx
|> renderHtml next ctx }
| None -> return! fourOhFour next ctx
}
/// GET /churches /// GET /churches
let maintain : HttpHandler = let maintain : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let await = Async.AwaitTask >> Async.RunSynchronously let await = Async.AwaitTask >> Async.RunSynchronously
let db = ctx.dbContext () let! churches = ctx.db.AllChurches ()
task { let stats = churches |> List.map (fun c -> await (findStats ctx.db c.churchId))
let! churches = db.AllChurches () return!
let stats = churches |> List.map (fun c -> await (findStats db c.churchId)) viewInfo ctx startTicks
return! |> Views.Church.maintain churches (stats |> Map.ofList) ctx
viewInfo ctx startTicks |> renderHtml next ctx
|> Views.Church.maintain churches (stats |> Map.ofList) ctx }
|> renderHtml next ctx
}
/// POST /church/save /// POST /church/save
let save : HttpHandler = let save : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! ctx.TryBindFormAsync<EditChurch> () with
match! ctx.TryBindFormAsync<EditChurch> () with | Ok m ->
| Ok m -> let! church =
let db = ctx.dbContext () match m.isNew () with
let! church = | true -> Task.FromResult<Church option>(Some { Church.empty with churchId = Guid.NewGuid () })
match m.isNew () with | false -> ctx.db.TryChurchById m.churchId
| true -> Task.FromResult<Church option>(Some { Church.empty with churchId = Guid.NewGuid () }) match church with
| false -> db.TryChurchById m.churchId | Some ch ->
match church with m.populateChurch ch
| Some ch -> |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
m.populateChurch ch let! _ = ctx.db.SaveChangesAsync ()
|> (match m.isNew () with true -> db.AddEntry | false -> db.UpdateEntry) let s = Views.I18N.localizer.Force ()
let! _ = db.SaveChangesAsync () let act = s.[match m.isNew () with true -> "Added" | _ -> "Updated"].Value.ToLower ()
let s = Views.I18N.localizer.Force () addInfo ctx s.["Successfully {0} church “{1}”", act, m.name]
let act = s.[match m.isNew () with true -> "Added" | _ -> "Updated"].Value.ToLower () return! redirectTo false "/web/churches" next ctx
addInfo ctx s.["Successfully {0} church “{1}”", act, m.name] | None -> return! fourOhFour next ctx
return! redirectTo false "/web/churches" next ctx | Error e -> return! bindError e next ctx
| None -> return! fourOhFour next ctx }
| Error e -> return! bindError e next ctx
}

184
src/PrayerTracker/CommonFunctions.fs
View File

@ -53,31 +53,23 @@ let appVersion =
|> String.concat "" |> String.concat ""
#endif #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) /// The currently signed-in user (will raise if none exists)
let currentUser ctx = let currentUser (ctx : HttpContext) =
match tryCurrentUser ctx with Some u -> u | None -> nullArg "User" match ctx.Session.user with Some u -> u | None -> nullArg "User"
/// An option of the currently signed-in small group
let tryCurrentGroup (ctx : HttpContext) =
ctx.Session.GetSmallGroup ()
/// The currently signed-in small group (will raise if none exists) /// The currently signed-in small group (will raise if none exists)
let currentGroup ctx = let currentGroup (ctx : HttpContext) =
match tryCurrentGroup ctx with Some g -> g | None -> nullArg "SmallGroup" match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup"
/// Create the common view information heading /// Create the common view information heading
let viewInfo (ctx : HttpContext) startTicks = let viewInfo (ctx : HttpContext) startTicks =
let msg = let msg =
match ctx.Session.GetMessages () with match ctx.Session.messages with
| [] -> [] | [] -> []
| x -> | x ->
ctx.Session.SetMessages [] ctx.Session.messages <- []
x x
match tryCurrentUser ctx with match ctx.Session.user with
| Some u -> | Some u ->
// The idle timeout is 2 hours; if the app pool is recycled or the actual session goes away, we will log the // 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. // user back in transparently using this cookie. Every request resets the timer.
@ -95,8 +87,8 @@ let viewInfo (ctx : HttpContext) startTicks =
version = appVersion version = appVersion
messages = msg messages = msg
requestStart = startTicks requestStart = startTicks
user = ctx.Session.GetUser () user = ctx.Session.user
group = ctx.Session.GetSmallGroup () group = ctx.Session.smallGroup
} }
/// The view is the last parameter, so it can be composed /// The view is the last parameter, so it can be composed
@ -117,20 +109,17 @@ let fourOhFour next (ctx : HttpContext) =
/// Handler to validate CSRF prevention token /// Handler to validate CSRF prevention token
let validateCSRF : HttpHandler = let validateCSRF : HttpHandler =
fun next ctx -> fun next ctx -> task {
let antiForgery = ctx.GetService<IAntiforgery> () match! (ctx.GetService<IAntiforgery> ()).IsRequestValidAsync ctx with
task { | true -> return! next ctx
let! isValid = antiForgery.IsRequestValidAsync ctx | false ->
match isValid with return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx
| true -> return! next ctx }
| false ->
return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx
}
/// Add a message to the session /// Add a message to the session
let addUserMessage (ctx : HttpContext) msg = 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 /// Convert a localized string to an HTML string
let htmlLocString (x : LocalizedString) = let htmlLocString (x : LocalizedString) =
@ -173,99 +162,94 @@ let requireAccess level : HttpHandler =
/// Is there currently a user logged on? /// Is there currently a user logged on?
let isUserLoggedOn (ctx : HttpContext) = let isUserLoggedOn (ctx : HttpContext) =
ctx.Session.GetUser () |> Option.isSome ctx.Session.user |> Option.isSome
/// Log a user on from the timeout cookie /// Log a user on from the timeout cookie
let logOnUserFromTimeoutCookie (ctx : HttpContext) = let logOnUserFromTimeoutCookie (ctx : HttpContext) = task {
task { // Make sure the cookie hasn't been tampered with
// Make sure the cookie hasn't been tampered with try
try match TimeoutCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.timeout] with
match TimeoutCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.timeout] with | Some c when c.Password = saltedTimeoutHash c ->
| Some c when c.Password = saltedTimeoutHash c -> let! user = ctx.db.TryUserById c.Id
let db = ctx.dbContext () match user with
let! user = db.TryUserById c.Id | Some _ ->
match user with ctx.Session.user <- user
| Some _ -> let! grp = ctx.db.TryGroupById c.GroupId
ctx.Session.SetUser user ctx.Session.smallGroup <- grp
let! grp = db.TryGroupById c.GroupId | _ -> ()
ctx.Session.SetSmallGroup grp | _ -> ()
| _ -> () // If something above doesn't work, the user doesn't get logged in
| _ -> () with _ -> ()
// If something above doesn't work, the user doesn't get logged in
with _ -> ()
} }
/// Attempt to log the user on from their stored cookie /// Attempt to log the user on from their stored cookie
let logOnUserFromCookie (ctx : HttpContext) = let logOnUserFromCookie (ctx : HttpContext) = task {
task { match UserCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.user] with
match UserCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.user] with | Some c ->
| Some c -> let! user = ctx.db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash
let db = ctx.dbContext () match user with
let! user = db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash | Some _ ->
match user with ctx.Session.user <- user
| Some _ -> let! grp = ctx.db.TryGroupById c.GroupId
ctx.Session.SetUser user ctx.Session.smallGroup <- grp
let! grp = db.TryGroupById c.GroupId // Rewrite the cookie to extend the expiration
ctx.Session.SetSmallGroup grp ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh)
// 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? /// Is there currently a small group (or member thereof) logged on?
let isGroupLoggedOn (ctx : HttpContext) = 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 /// Attempt to log the small group on from their stored cookie
let logOnGroupFromCookie (ctx : HttpContext) = let logOnGroupFromCookie (ctx : HttpContext) =
task { task {
match GroupCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.group] with match GroupCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.group] with
| Some c -> | 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 match grp with
| Some _ -> | Some _ ->
ctx.Session.SetSmallGroup grp ctx.Session.smallGroup <- grp
// Rewrite the cookie to extend the expiration // Rewrite the cookie to extend the expiration
ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh) ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh)
| None -> () | None -> ()
| None -> () | None -> ()
} }
fun next ctx -> fun next ctx -> FSharp.Control.Tasks.Affine.task {
FSharp.Control.Tasks.Affine.task { // Auto-logon user or class, if required
// Auto-logon user or class, if required match isUserLoggedOn ctx with
match isUserLoggedOn ctx with | true -> ()
| true -> () | false ->
| false -> do! logOnUserFromTimeoutCookie ctx
do! logOnUserFromTimeoutCookie ctx match isUserLoggedOn ctx with
match isUserLoggedOn ctx with | true -> ()
| true -> () | false ->
| false -> do! logOnUserFromCookie ctx
do! logOnUserFromCookie ctx match isGroupLoggedOn ctx with true -> () | false -> do! logOnGroupFromCookie ctx
match isGroupLoggedOn ctx with true -> () | false -> do! logOnGroupFromCookie ctx
match true with match true with
| _ when level |> List.contains Public -> return! next ctx | _ when level |> List.contains Public -> return! next ctx
| _ when level |> List.contains User && isUserLoggedOn ctx -> 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 Group && isGroupLoggedOn ctx -> return! next ctx
| _ when level |> List.contains Admin && isUserLoggedOn ctx -> | _ when level |> List.contains Admin && isUserLoggedOn ctx ->
match (currentUser ctx).isAdmin with match (currentUser ctx).isAdmin with
| true -> return! next ctx | true -> return! next ctx
| false -> | false ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s.["You are not authorized to view the requested page."] addError ctx s.["You are not authorized to view the requested page."]
return! redirectTo false "/web/unauthorized" next ctx return! redirectTo false "/web/unauthorized" next ctx
| _ when level |> List.contains User -> | _ when level |> List.contains User ->
// Redirect to the user log on page // Redirect to the user log on page
ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ()) ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
return! redirectTo false "/web/user/log-on" next ctx return! redirectTo false "/web/user/log-on" next ctx
| _ when level |> List.contains Group -> | _ when level |> List.contains Group ->
// Redirect to the small group log on page // Redirect to the small group log on page
ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ()) ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
return! redirectTo false "/web/small-group/log-on" next ctx return! redirectTo false "/web/small-group/log-on" next ctx
| _ -> | _ ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s.["You are not authorized to view the requested page."] addError ctx s.["You are not authorized to view the requested page."]
return! redirectTo false "/web/unauthorized" next ctx return! redirectTo false "/web/unauthorized" next ctx
} }

44
src/PrayerTracker/Email.fs
View File

@ -13,12 +13,11 @@ let private fromAddress = "prayer@bitbadger.solutions"
/// Get an SMTP client connection /// Get an SMTP client connection
// FIXME: make host configurable // FIXME: make host configurable
let getConnection () = let getConnection () = task {
task { let client = new SmtpClient ()
let client = new SmtpClient () do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None)
do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None) return client
return client }
}
/// Create a mail message object, filled with everything but the body content /// Create a mail message object, filled with everything but the body content
let createMessage (grp : SmallGroup) subj = let createMessage (grp : SmallGroup) subj =
@ -59,21 +58,20 @@ let createTextMessage grp subj body (s : IStringLocalizer) =
msg msg
/// Send e-mails to a class /// Send e-mails to a class
let sendEmails (client : SmtpClient) (recipients : Member list) grp subj html text s = let sendEmails (client : SmtpClient) (recipients : Member list) grp subj html text s = task {
task { let htmlMsg = createHtmlMessage grp subj html s
let htmlMsg = createHtmlMessage grp subj html s let plainTextMsg = createTextMessage grp subj text s
let plainTextMsg = createTextMessage grp subj text s
for mbr in recipients do for mbr in recipients do
let emailType = match mbr.format with Some f -> EmailFormat.fromCode f | None -> grp.preferences.defaultEmailType let emailType = match mbr.format with Some f -> EmailFormat.fromCode f | None -> grp.preferences.defaultEmailType
let emailTo = MailboxAddress (mbr.memberName, mbr.email) let emailTo = MailboxAddress (mbr.memberName, mbr.email)
match emailType with match emailType with
| HtmlFormat -> | HtmlFormat ->
htmlMsg.To.Add emailTo htmlMsg.To.Add emailTo
do! client.SendAsync htmlMsg do! client.SendAsync htmlMsg
htmlMsg.To.Clear () htmlMsg.To.Clear ()
| PlainTextFormat -> | PlainTextFormat ->
plainTextMsg.To.Add emailTo plainTextMsg.To.Add emailTo
do! client.SendAsync plainTextMsg do! client.SendAsync plainTextMsg
plainTextMsg.To.Clear () plainTextMsg.To.Clear ()
} }

45
src/PrayerTracker/Extensions.fs
View File

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

385
src/PrayerTracker/PrayerRequest.fs
View File

@ -10,16 +10,15 @@ open System
open System.Threading.Tasks open System.Threading.Tasks
/// Retrieve a prayer request, and ensure that it belongs to the current class /// Retrieve a prayer request, and ensure that it belongs to the current class
let private findRequest (ctx : HttpContext) reqId = let private findRequest (ctx : HttpContext) reqId = task {
task { match! ctx.db.TryRequestById reqId with
match! ctx.dbContext().TryRequestById reqId with | Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> return Ok req
| Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> return Ok req | Some _ ->
| Some _ -> let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () addError ctx s.["The prayer request you tried to access is not assigned to your group"]
addError ctx s.["The prayer request you tried to access is not assigned to your group"] return Error (redirectTo false "/web/unauthorized")
return Error (redirectTo false "/web/unauthorized") | None -> return Error fourOhFour
| None -> return Error fourOhFour }
}
/// Generate a list of requests for the given date /// Generate a list of requests for the given date
let private generateRequestList ctx date = let private generateRequestList ctx date =
@ -29,12 +28,12 @@ let private generateRequestList ctx date =
match date with match date with
| Some d -> d | Some d -> d
| None -> grp.localDateNow clock | 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 { requests = reqs |> List.ofSeq
date = listDate date = listDate
listGroup = grp listGroup = grp
showHeader = true showHeader = true
canEmail = tryCurrentUser ctx |> Option.isSome canEmail = ctx.Session.user |> Option.isSome
recipients = [] recipients = []
} }
@ -48,139 +47,130 @@ let private parseListDate (date : string option) =
/// GET /prayer-request/[request-id]/edit /// GET /prayer-request/[request-id]/edit
let edit (reqId : PrayerRequestId) : HttpHandler = let edit (reqId : PrayerRequestId) : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx let grp = currentGroup ctx
let now = grp.localDateNow (ctx.GetService<IClock> ()) let now = grp.localDateNow (ctx.GetService<IClock> ())
task { match reqId = Guid.Empty with
match reqId = Guid.Empty with | true ->
| true -> return!
return! { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
{ viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx
|> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx |> renderHtml next ctx
|> renderHtml next ctx | false ->
| false -> match! findRequest ctx reqId with
match! findRequest ctx reqId with | Ok req ->
| Ok req -> let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () match req.isExpired now grp.preferences.daysToExpire with
match req.isExpired now grp.preferences.daysToExpire with | true ->
| true -> { UserMessage.warning with
{ UserMessage.warning with text = htmlLocString s.["This request is expired."]
text = htmlLocString s.["This request is expired."] description =
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.["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"]]
s.["Expire Immediately"], s.["Check to not update the date"]] |> (htmlLocString >> Some)
|> (htmlLocString >> Some) }
} |> addUserMessage ctx
|> addUserMessage ctx | false -> ()
| false -> () return!
return! { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
{ viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx
|> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx |> renderHtml next ctx
|> renderHtml next ctx | Error e -> return! e next ctx
| Error e -> return! e next ctx }
}
/// GET /prayer-requests/email/[date] /// GET /prayer-requests/email/[date]
let email date : HttpHandler = let email date : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let listDate = parseListDate (Some date) let listDate = parseListDate (Some date)
let grp = currentGroup ctx let grp = currentGroup ctx
task { let list = generateRequestList ctx listDate
let list = generateRequestList ctx listDate let! recipients = ctx.db.AllMembersForSmallGroup grp.smallGroupId
let! recipients = ctx.dbContext().AllMembersForSmallGroup grp.smallGroupId use! client = Email.getConnection ()
use! client = Email.getConnection () do! Email.sendEmails client recipients
do! Email.sendEmails client recipients grp s.["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value
grp s.["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value (list.asHtml s) (list.asText s) s
(list.asHtml s) (list.asText s) s return!
return! viewInfo ctx startTicks
viewInfo ctx startTicks |> Views.PrayerRequest.email { list with recipients = recipients }
|> Views.PrayerRequest.email { list with recipients = recipients } |> renderHtml next ctx
|> renderHtml next ctx }
}
/// POST /prayer-request/[request-id]/delete /// POST /prayer-request/[request-id]/delete
let delete reqId : HttpHandler = let delete reqId : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! findRequest ctx reqId with
match! findRequest ctx reqId with | Ok req ->
| Ok req -> let s = Views.I18N.localizer.Force ()
let db = ctx.dbContext () ctx.db.PrayerRequests.Remove req |> ignore
let s = Views.I18N.localizer.Force () let! _ = ctx.db.SaveChangesAsync ()
db.PrayerRequests.Remove req |> ignore addInfo ctx s.["The prayer request was deleted successfully"]
let! _ = db.SaveChangesAsync () return! redirectTo false "/web/prayer-requests" next ctx
addInfo ctx s.["The prayer request was deleted successfully"] | Error e -> return! e next ctx
return! redirectTo false "/web/prayer-requests" next ctx }
| Error e -> return! e next ctx
}
/// GET /prayer-request/[request-id]/expire /// GET /prayer-request/[request-id]/expire
let expire reqId : HttpHandler = let expire reqId : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! findRequest ctx reqId with
match! findRequest ctx reqId with | Ok req ->
| Ok req -> let s = Views.I18N.localizer.Force ()
let db = ctx.dbContext () ctx.db.UpdateEntry { req with expiration = Forced }
let s = Views.I18N.localizer.Force () let! _ = ctx.db.SaveChangesAsync ()
db.UpdateEntry { req with expiration = Forced } addInfo ctx s.["Successfully {0} prayer request", s.["Expired"].Value.ToLower ()]
let! _ = db.SaveChangesAsync () return! redirectTo false "/web/prayer-requests" next ctx
addInfo ctx s.["Successfully {0} prayer request", s.["Expired"].Value.ToLower ()] | Error e -> return! e next ctx
return! redirectTo false "/web/prayer-requests" next ctx }
| Error e -> return! e next ctx
}
/// GET /prayer-requests/[group-id]/list /// GET /prayer-requests/[group-id]/list
let list groupId : HttpHandler = let list groupId : HttpHandler =
requireAccess [ AccessLevel.Public ] requireAccess [ AccessLevel.Public ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext () match! ctx.db.TryGroupById groupId with
task { | Some grp when grp.preferences.isPublic ->
match! db.TryGroupById groupId with let clock = ctx.GetService<IClock> ()
| Some grp when grp.preferences.isPublic -> let reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0
let clock = ctx.GetService<IClock> () return!
let reqs = db.AllRequestsForSmallGroup grp clock None true 0 viewInfo ctx startTicks
return! |> Views.PrayerRequest.list
viewInfo ctx startTicks { requests = List.ofSeq reqs
|> Views.PrayerRequest.list date = grp.localDateNow clock
{ requests = List.ofSeq reqs listGroup = grp
date = grp.localDateNow clock showHeader = true
listGroup = grp canEmail = ctx.Session.user |> Option.isSome
showHeader = true recipients = []
canEmail = (tryCurrentUser >> Option.isSome) ctx }
recipients = [] |> renderHtml next ctx
} | Some _ ->
|> renderHtml next ctx let s = Views.I18N.localizer.Force ()
| Some _ -> addError ctx s.["The request list for the group you tried to view is not public."]
let s = Views.I18N.localizer.Force () return! redirectTo false "/web/unauthorized" next ctx
addError ctx s.["The request list for the group you tried to view is not public."] | None -> return! fourOhFour next ctx
return! redirectTo false "/web/unauthorized" next ctx }
| None -> return! fourOhFour next ctx
}
/// GET /prayer-requests/lists /// GET /prayer-requests/lists
let lists : HttpHandler = let lists : HttpHandler =
requireAccess [ AccessLevel.Public ] requireAccess [ AccessLevel.Public ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { let! grps = ctx.db.PublicAndProtectedGroups ()
let! grps = ctx.dbContext().PublicAndProtectedGroups () return!
return! viewInfo ctx startTicks
viewInfo ctx startTicks |> Views.PrayerRequest.lists grps
|> Views.PrayerRequest.lists grps |> renderHtml next ctx
|> renderHtml next ctx }
}
/// GET /prayer-requests[/inactive?] /// GET /prayer-requests[/inactive?]
@ -190,108 +180,97 @@ let maintain onlyActive : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext ()
let grp = currentGroup ctx let grp = currentGroup ctx
task { let pageNbr =
let pageNbr = match ctx.GetQueryStringValue "page" with
match ctx.GetQueryStringValue "page" with | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1
| Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1 | Error _ -> 1
| Error _ -> 1 let m =
let m = match ctx.GetQueryStringValue "search" with
match ctx.GetQueryStringValue "search" with | Ok srch ->
| Ok srch -> { MaintainRequests.empty with
{ MaintainRequests.empty with requests = ctx.db.SearchRequestsForSmallGroup grp srch pageNbr
requests = db.SearchRequestsForSmallGroup grp srch pageNbr searchTerm = Some srch
searchTerm = Some srch pageNbr = Some pageNbr
pageNbr = Some pageNbr }
} | Error _ ->
| Error _ -> { MaintainRequests.empty with
{ MaintainRequests.empty with requests = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr
requests = db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr onlyActive = Some onlyActive
onlyActive = Some onlyActive pageNbr = match onlyActive with true -> None | false -> Some pageNbr
pageNbr = match onlyActive with true -> None | false -> Some pageNbr }
} { viewInfo ctx startTicks with helpLink = Some Help.maintainRequests }
return! |> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx
{ viewInfo ctx startTicks with helpLink = Some Help.maintainRequests } |> renderHtml next ctx
|> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx
|> renderHtml next ctx
}
/// GET /prayer-request/print/[date] /// GET /prayer-request/print/[date]
let print date : HttpHandler = let print date : HttpHandler =
requireAccess [ User; Group ] requireAccess [ User; Group ]
>=> fun next ctx -> >=> fun next ctx ->
let listDate = parseListDate (Some date) let list = parseListDate (Some date) |> generateRequestList ctx
task { Views.PrayerRequest.print list appVersion
let list = generateRequestList ctx listDate |> renderHtml next ctx
return!
Views.PrayerRequest.print list appVersion
|> renderHtml next ctx
}
/// GET /prayer-request/[request-id]/restore /// GET /prayer-request/[request-id]/restore
let restore reqId : HttpHandler = let restore reqId : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! findRequest ctx reqId with
match! findRequest ctx reqId with | Ok req ->
| Ok req -> let s = Views.I18N.localizer.Force ()
let db = ctx.dbContext () ctx.db.UpdateEntry { req with expiration = Automatic; updatedDate = DateTime.Now }
let s = Views.I18N.localizer.Force () let! _ = ctx.db.SaveChangesAsync ()
db.UpdateEntry { req with expiration = Automatic; updatedDate = DateTime.Now } addInfo ctx s.["Successfully {0} prayer request", s.["Restored"].Value.ToLower ()]
let! _ = db.SaveChangesAsync () return! redirectTo false "/web/prayer-requests" next ctx
addInfo ctx s.["Successfully {0} prayer request", s.["Restored"].Value.ToLower ()] | Error e -> return! e next ctx
return! redirectTo false "/web/prayer-requests" next ctx }
| Error e -> return! e next ctx
}
/// POST /prayer-request/save /// POST /prayer-request/save
let save : HttpHandler = let save : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! ctx.TryBindFormAsync<EditRequest> () with
match! ctx.TryBindFormAsync<EditRequest> () with | Ok m ->
| Ok m -> let! req =
let db = ctx.dbContext () match m.isNew () with
let! req = | 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<IClock> ())
match m.isNew () with match m.isNew () with
| true -> Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () }) | true ->
| false -> db.TryRequestById m.requestId let dt = match m.enteredDate with Some x -> x | None -> now
match req with { upd8 with
| Some pr -> smallGroupId = grp.smallGroupId
let upd8 = userId = (currentUser ctx).userId
{ pr with enteredDate = dt
requestType = PrayerRequestType.fromCode m.requestType updatedDate = dt
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 | false when Option.isSome m.skipDateUpdate && Option.get m.skipDateUpdate -> upd8
let now = grp.localDateNow (ctx.GetService<IClock> ()) | false -> { upd8 with updatedDate = now }
match m.isNew () with |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
| true -> let! _ = ctx.db.SaveChangesAsync ()
let dt = match m.enteredDate with Some x -> x | None -> now let s = Views.I18N.localizer.Force ()
{ upd8 with let act = match m.isNew () with true -> "Added" | false -> "Updated"
smallGroupId = grp.smallGroupId addInfo ctx s.["Successfully {0} prayer request", s.[act].Value.ToLower ()]
userId = (currentUser ctx).userId return! redirectTo false "/web/prayer-requests" next ctx
enteredDate = dt | None -> return! fourOhFour next ctx
updatedDate = dt | 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 -> 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
}
/// GET /prayer-request/view/[date?] /// GET /prayer-request/view/[date?]
@ -299,11 +278,7 @@ let view date : HttpHandler =
requireAccess [ User; Group ] requireAccess [ User; Group ]
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let listDate = parseListDate date let list = parseListDate date |> generateRequestList ctx
task { viewInfo ctx startTicks
let list = generateRequestList ctx listDate |> Views.PrayerRequest.view { list with showHeader = false }
return! |> renderHtml next ctx
viewInfo ctx startTicks
|> Views.PrayerRequest.view { list with showHeader = false }
|> renderHtml next ctx
}

151
src/PrayerTracker/SmallGroup.fs
View File

@ -32,66 +32,60 @@ let announcement : HttpHandler =
let delete groupId : HttpHandler = let delete groupId : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
let db = ctx.dbContext () let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () match! ctx.db.TryGroupById groupId with
task { | Some grp ->
match! db.TryGroupById groupId with let! reqs = ctx.db.CountRequestsBySmallGroup groupId
| Some grp -> let! usrs = ctx.db.CountUsersBySmallGroup groupId
let! reqs = db.CountRequestsBySmallGroup groupId ctx.db.RemoveEntry grp
let! usrs = db.CountUsersBySmallGroup groupId let! _ = ctx.db.SaveChangesAsync ()
db.RemoveEntry grp addInfo ctx
let! _ = db.SaveChangesAsync () s.["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)",
addInfo ctx grp.name, reqs, usrs]
s.["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)", return! redirectTo false "/web/small-groups" next ctx
grp.name, reqs, usrs] | None -> return! fourOhFour next ctx
return! redirectTo false "/web/small-groups" next ctx }
| None -> return! fourOhFour next ctx
}
/// POST /small-group/member/[member-id]/delete /// POST /small-group/member/[member-id]/delete
let deleteMember memberId : HttpHandler = let deleteMember memberId : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
let db = ctx.dbContext ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
task { match! ctx.db.TryMemberById memberId with
match! db.TryMemberById memberId with | Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId ->
| Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId -> ctx.db.RemoveEntry mbr
db.RemoveEntry mbr let! _ = ctx.db.SaveChangesAsync ()
let! _ = db.SaveChangesAsync () addHtmlInfo ctx s.["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.memberName]
addHtmlInfo ctx s.["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.memberName] return! redirectTo false "/web/small-group/members" next ctx
return! redirectTo false "/web/small-group/members" next ctx | Some _
| Some _ | None -> return! fourOhFour next ctx
| None -> return! fourOhFour next ctx }
}
/// GET /small-group/[group-id]/edit /// GET /small-group/[group-id]/edit
let edit (groupId : SmallGroupId) : HttpHandler = let edit (groupId : SmallGroupId) : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext () let! churches = ctx.db.AllChurches ()
task { match groupId = Guid.Empty with
let! churches = db.AllChurches () | true ->
match groupId = Guid.Empty with return!
| true -> viewInfo ctx startTicks
return! |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
viewInfo ctx startTicks |> renderHtml next ctx
|> Views.SmallGroup.edit EditSmallGroup.empty churches ctx | false ->
|> renderHtml next ctx match! ctx.db.TryGroupById groupId with
| false -> | Some grp ->
match! db.TryGroupById groupId with return!
| Some grp -> viewInfo ctx startTicks
return! |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx
viewInfo ctx startTicks |> renderHtml next ctx
|> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx | None -> return! fourOhFour next ctx
|> renderHtml next ctx }
| None -> return! fourOhFour next ctx
}
/// GET /small-group/member/[member-id]/edit /// GET /small-group/member/[member-id]/edit
@ -99,7 +93,6 @@ let editMember (memberId : MemberId) : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let grp = currentGroup ctx let grp = currentGroup ctx
let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s
@ -111,7 +104,7 @@ let editMember (memberId : MemberId) : HttpHandler =
|> Views.SmallGroup.editMember EditMember.empty typs ctx |> Views.SmallGroup.editMember EditMember.empty typs ctx
|> renderHtml next ctx |> renderHtml next ctx
| false -> | false ->
match! db.TryMemberById memberId with match! ctx.db.TryMemberById memberId with
| Some mbr when mbr.smallGroupId = grp.smallGroupId -> | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
@ -128,8 +121,8 @@ let logOn (groupId : SmallGroupId option) : HttpHandler =
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { task {
let! grps = ctx.dbContext().ProtectedGroups () let! grps = ctx.db.ProtectedGroups ()
let grpId = match groupId with Some gid -> flatGuid gid | None -> "" let grpId = match groupId with Some gid -> flatGuid gid | None -> ""
return! return!
{ viewInfo ctx startTicks with helpLink = Some Help.logOn } { viewInfo ctx startTicks with helpLink = Some Help.logOn }
|> Views.SmallGroup.logOn grps grpId ctx |> Views.SmallGroup.logOn grps grpId ctx
@ -146,9 +139,9 @@ let logOnSubmit : HttpHandler =
match! ctx.TryBindFormAsync<GroupLogOn> () with match! ctx.TryBindFormAsync<GroupLogOn> () with
| Ok m -> | Ok m ->
let s = Views.I18N.localizer.Force () 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 grp ->
(Some >> ctx.Session.SetSmallGroup) grp ctx.Session.smallGroup <- Some grp
match m.rememberMe with match m.rememberMe with
| Some x when x -> (setGroupCookie ctx << sha1Hash) m.password | Some x when x -> (setGroupCookie ctx << sha1Hash) m.password
| _ -> () | _ -> ()
@ -167,7 +160,7 @@ let maintain : HttpHandler =
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { task {
let! grps = ctx.dbContext().AllGroups () let! grps = ctx.db.AllGroups ()
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.maintain grps ctx |> Views.SmallGroup.maintain grps ctx
@ -180,11 +173,10 @@ let members : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext ()
let grp = currentGroup ctx let grp = currentGroup ctx
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
task { task {
let! mbrs = db.AllMembersForSmallGroup grp.smallGroupId let! mbrs = ctx.db.AllMembersForSmallGroup grp.smallGroupId
let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s |> Map.ofSeq let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s |> Map.ofSeq
return! return!
{ viewInfo ctx startTicks with helpLink = Some Help.maintainGroupMembers } { viewInfo ctx startTicks with helpLink = Some Help.maintainGroupMembers }
@ -198,12 +190,11 @@ let overview : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext ()
let clock = ctx.GetService<IClock> () let clock = ctx.GetService<IClock> ()
task { task {
let reqs = db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 |> List.ofSeq let reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 |> List.ofSeq
let! reqCount = db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId
let! mbrCount = db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId
let m = let m =
{ totalActiveReqs = List.length reqs { totalActiveReqs = List.length reqs
allReqs = reqCount allReqs = reqCount
@ -229,7 +220,7 @@ let preferences : HttpHandler =
>=> fun next ctx -> >=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { task {
let! tzs = ctx.dbContext().AllTimeZones () let! tzs = ctx.db.AllTimeZones ()
return! return!
{ viewInfo ctx startTicks with helpLink = Some Help.groupPreferences } { viewInfo ctx startTicks with helpLink = Some Help.groupPreferences }
|> Views.SmallGroup.preferences (EditPreferences.fromPreferences (currentGroup ctx).preferences) tzs ctx |> Views.SmallGroup.preferences (EditPreferences.fromPreferences (currentGroup ctx).preferences) tzs ctx
@ -246,20 +237,19 @@ let save : HttpHandler =
task { task {
match! ctx.TryBindFormAsync<EditSmallGroup> () with match! ctx.TryBindFormAsync<EditSmallGroup> () with
| Ok m -> | Ok m ->
let db = ctx.dbContext ()
let! group = let! group =
match m.isNew () with match m.isNew () with
| true -> Task.FromResult<SmallGroup option>(Some { SmallGroup.empty with smallGroupId = Guid.NewGuid () }) | 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 match group with
| Some grp -> | Some grp ->
m.populateGroup grp m.populateGroup grp
|> function |> function
| grp when m.isNew () -> | grp when m.isNew () ->
db.AddEntry grp ctx.db.AddEntry grp
db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId } ctx.db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId }
| grp -> db.UpdateEntry grp | grp -> ctx.db.UpdateEntry grp
let! _ = db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower () let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower ()
addHtmlInfo ctx s.["Successfully {0} group “{1}”", act, m.name] addHtmlInfo ctx s.["Successfully {0} group “{1}”", act, m.name]
return! redirectTo false "/web/small-groups" next ctx return! redirectTo false "/web/small-groups" next ctx
@ -277,7 +267,6 @@ let saveMember : HttpHandler =
match! ctx.TryBindFormAsync<EditMember> () with match! ctx.TryBindFormAsync<EditMember> () with
| Ok m -> | Ok m ->
let grp = currentGroup ctx let grp = currentGroup ctx
let db = ctx.dbContext ()
let! mMbr = let! mMbr =
match m.isNew () with match m.isNew () with
| true -> | true ->
@ -287,7 +276,7 @@ let saveMember : HttpHandler =
memberId = Guid.NewGuid () memberId = Guid.NewGuid ()
smallGroupId = grp.smallGroupId smallGroupId = grp.smallGroupId
}) })
| false -> db.TryMemberById m.memberId | false -> ctx.db.TryMemberById m.memberId
match mMbr with match mMbr with
| Some mbr when mbr.smallGroupId = grp.smallGroupId -> | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
{ mbr with { mbr with
@ -295,8 +284,8 @@ let saveMember : HttpHandler =
email = m.emailAddress email = m.emailAddress
format = match m.emailType with "" | null -> None | _ -> Some m.emailType format = match m.emailType with "" | null -> None | _ -> Some m.emailType
} }
|> (match m.isNew () with true -> db.AddEntry | false -> db.UpdateEntry) |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
let! _ = db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower () let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower ()
addInfo ctx s.["Successfully {0} group member", act] addInfo ctx s.["Successfully {0} group member", act]
@ -315,17 +304,16 @@ let savePreferences : HttpHandler =
task { task {
match! ctx.TryBindFormAsync<EditPreferences> () with match! ctx.TryBindFormAsync<EditPreferences> () with
| Ok m -> | 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 // 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 // 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. // 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 -> | Some grp ->
let prefs = m.populatePreferences grp.preferences let prefs = m.populatePreferences grp.preferences
db.UpdateEntry prefs ctx.db.UpdateEntry prefs
let! _ = db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
// Refresh session instance // 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 () let s = Views.I18N.localizer.Force ()
addInfo ctx s.["Group preferences updated successfully"] addInfo ctx s.["Group preferences updated successfully"]
return! redirectTo false "/web/small-group/preferences" next ctx return! redirectTo false "/web/small-group/preferences" next ctx
@ -345,7 +333,6 @@ let sendAnnouncement : HttpHandler =
| Ok m -> | Ok m ->
let grp = currentGroup ctx let grp = currentGroup ctx
let usr = currentUser ctx let usr = currentUser ctx
let db = ctx.dbContext ()
let now = grp.localTimeNow (ctx.GetService<IClock> ()) let now = grp.localTimeNow (ctx.GetService<IClock> ())
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
// Reformat the text to use the class's font stylings // Reformat the text to use the class's font stylings
@ -358,8 +345,8 @@ let sendAnnouncement : HttpHandler =
// Send the e-mails // Send the e-mails
let! recipients = let! recipients =
match m.sendToClass with match m.sendToClass with
| "N" when usr.isAdmin -> db.AllUsersAsMembers () | "N" when usr.isAdmin -> ctx.db.AllUsersAsMembers ()
| _ -> db.AllMembersForSmallGroup grp.smallGroupId | _ -> ctx.db.AllMembersForSmallGroup grp.smallGroupId
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails client recipients grp do! Email.sendEmails client recipients grp
s.["Announcement for {0} - {1:MMMM d, yyyy} {2}", s.["Announcement for {0} - {1:MMMM d, yyyy} {2}",
@ -380,8 +367,8 @@ let sendAnnouncement : HttpHandler =
enteredDate = now enteredDate = now
updatedDate = now updatedDate = now
} }
|> db.AddEntry |> ctx.db.AddEntry
let! _ = db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
() ()
// Tell 'em what they've won, Johnny! // Tell 'em what they've won, Johnny!
let toWhom = let toWhom =

460
src/PrayerTracker/User.fs
View File

@ -22,193 +22,183 @@ let private setUserCookie (ctx : HttpContext) pwHash =
/// Retrieve a user from the database by password /// 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 // 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) = let private findUserByPassword m (db : AppDbContext) = task {
task { match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with
match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with | Some u when Option.isSome u.salt ->
| Some u when Option.isSome u.salt -> // Already upgraded; match = success
// Already upgraded; match = success let pwHash = pbkdf2Hash (Option.get u.salt) m.password
let pwHash = pbkdf2Hash (Option.get u.salt) m.password match u.passwordHash = pwHash with
match u.passwordHash = pwHash with | true -> return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash
| true -> return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash | _ -> return None, ""
| _ -> return None, "" | Some u when u.passwordHash = sha1Hash m.password ->
| Some u when u.passwordHash = sha1Hash m.password -> // Not upgraded, but password is good; upgrade 'em!
// Not upgraded, but password is good; upgrade 'em! // Upgrade 'em!
// Upgrade 'em! let salt = Guid.NewGuid ()
let salt = Guid.NewGuid () let pwHash = pbkdf2Hash salt m.password
let pwHash = pbkdf2Hash salt m.password let upgraded = { u with salt = Some salt; passwordHash = pwHash }
let upgraded = { u with salt = Some salt; passwordHash = pwHash } db.UpdateEntry upgraded
db.UpdateEntry upgraded let! _ = db.SaveChangesAsync ()
let! _ = db.SaveChangesAsync () return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash
return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash | _ -> return None, ""
| _ -> return None, "" }
}
/// POST /user/password/change /// POST /user/password/change
let changePassword : HttpHandler = let changePassword : HttpHandler =
requireAccess [ User ] requireAccess [ User ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! ctx.TryBindFormAsync<ChangePassword> () with
match! ctx.TryBindFormAsync<ChangePassword> () with | Ok m ->
| Ok m -> let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () let curUsr = currentUser ctx
let db = ctx.dbContext () let! dbUsr = ctx.db.TryUserById curUsr.userId
let curUsr = currentUser ctx let! user =
let! dbUsr = db.TryUserById curUsr.userId match dbUsr with
let! user = | 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 match dbUsr with
| Some usr -> | Some usr ->
// Check the old password against a possibly non-salted hash // Generate salt if it has not been already
(match usr.salt with | Some salt -> pbkdf2Hash salt | _ -> sha1Hash) m.oldPassword let salt = match usr.salt with Some s -> s | _ -> Guid.NewGuid ()
|> db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId ctx.db.UpdateEntry { usr with passwordHash = pbkdf2Hash salt m.newPassword; salt = Some salt }
| _ -> Task.FromResult None let! _ = ctx.db.SaveChangesAsync ()
match user with // If the user is remembered, update the cookie with the new hash
| Some _ when m.newPassword = m.newPasswordConfirm -> match ctx.Request.Cookies.Keys.Contains Key.Cookie.user with
match dbUsr with | true -> setUserCookie ctx usr.passwordHash
| Some usr -> | _ -> ()
// Generate salt if it has not been already addInfo ctx s.["Your password was changed successfully"]
let salt = match usr.salt with Some s -> s | _ -> Guid.NewGuid () | None -> addError ctx s.["Unable to change password"]
db.UpdateEntry { usr with passwordHash = pbkdf2Hash salt m.newPassword; salt = Some salt } return! redirectTo false "/web/" next ctx
let! _ = db.SaveChangesAsync () | Some _ ->
// If the user is remembered, update the cookie with the new hash addError ctx s.["The new passwords did not match - your password was NOT changed"]
match ctx.Request.Cookies.Keys.Contains Key.Cookie.user with return! redirectTo false "/web/user/password" next ctx
| true -> setUserCookie ctx usr.passwordHash | None ->
| _ -> () addError ctx s.["The old password was incorrect - your password was NOT changed"]
addInfo ctx s.["Your password was changed successfully"] return! redirectTo false "/web/user/password" next ctx
| None -> addError ctx s.["Unable to change password"] | Error e -> return! bindError e next ctx
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 /// POST /user/[user-id]/delete
let delete userId : HttpHandler = let delete userId : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! ctx.db.TryUserById userId with
let db = ctx.dbContext () | Some user ->
match! db.TryUserById userId with ctx.db.RemoveEntry user
| Some user -> let! _ = ctx.db.SaveChangesAsync ()
db.RemoveEntry user let s = Views.I18N.localizer.Force ()
let! _ = db.SaveChangesAsync () addInfo ctx s.["Successfully deleted user {0}", user.fullName]
let s = Views.I18N.localizer.Force () return! redirectTo false "/web/users" next ctx
addInfo ctx s.["Successfully deleted user {0}", user.fullName] | _ -> return! fourOhFour next ctx
return! redirectTo false "/web/users" next ctx }
| _ -> return! fourOhFour next ctx
}
/// POST /user/log-on /// POST /user/log-on
let doLogOn : HttpHandler = let doLogOn : HttpHandler =
requireAccess [ AccessLevel.Public ] requireAccess [ AccessLevel.Public ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! ctx.TryBindFormAsync<UserLogOn> () with
match! ctx.TryBindFormAsync<UserLogOn> () with | Ok m ->
| Ok m -> let s = Views.I18N.localizer.Force ()
let db = ctx.dbContext () let! usr, pwHash = findUserByPassword m ctx.db
let s = Views.I18N.localizer.Force () let! grp = ctx.db.TryGroupById m.smallGroupId
let! usr, pwHash = findUserByPassword m db let nextUrl =
let! grp = db.TryGroupById m.smallGroupId match usr with
let nextUrl = | Some _ ->
match usr with ctx.Session.user <- usr
| Some _ -> ctx.Session.smallGroup <- grp
ctx.Session.SetUser usr match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> ()
ctx.Session.SetSmallGroup grp addHtmlInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]]
match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> () match m.redirectUrl with
addHtmlInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]] | None -> "/web/small-group"
match m.redirectUrl with | Some x when x = "" -> "/web/small-group"
| None -> "/web/small-group" | Some x -> x
| Some x when x = "" -> "/web/small-group" | _ ->
| Some x -> x let grpName = match grp with Some g -> g.name | _ -> "N/A"
| _ -> { UserMessage.error with
let grpName = match grp with Some g -> g.name | _ -> "N/A" text = htmlLocString s.["Invalid credentials - log on unsuccessful"]
{ UserMessage.error with description =
text = htmlLocString s.["Invalid credentials - log on unsuccessful"] [ s.["This is likely due to one of the following reasons"].Value
description = ":<ul><li>"
[ 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
":<ul><li>" "</li><li>"
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
"</li><li>" "</li><li>"
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
"</li><li>" "</li></ul>"
s.["You are not authorized to administer the group “{0}”.", WebUtility.HtmlEncode grpName].Value ]
"</li></ul>" |> String.concat ""
] |> (HtmlString >> Some)
|> String.concat "" }
|> (HtmlString >> Some) |> addUserMessage ctx
} "/web/user/log-on"
|> addUserMessage ctx return! redirectTo false nextUrl next ctx
"/web/user/log-on" | Error e -> return! bindError e next ctx
return! redirectTo false nextUrl next ctx }
| Error e -> return! bindError e next ctx
}
/// GET /user/[user-id]/edit /// GET /user/[user-id]/edit
let edit (userId : UserId) : HttpHandler = let edit (userId : UserId) : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { match userId = Guid.Empty with
match userId = Guid.Empty with | true ->
| true -> return!
return! viewInfo ctx startTicks
viewInfo ctx startTicks |> Views.User.edit EditUser.empty ctx
|> Views.User.edit EditUser.empty ctx |> renderHtml next ctx
|> renderHtml next ctx | false ->
| false -> match! ctx.db.TryUserById userId with
match! ctx.dbContext().TryUserById userId with | Some user ->
| Some user -> return!
return! viewInfo ctx startTicks
viewInfo ctx startTicks |> Views.User.edit (EditUser.fromUser user) ctx
|> Views.User.edit (EditUser.fromUser user) ctx |> renderHtml next ctx
|> renderHtml next ctx | _ -> return! fourOhFour next ctx
| _ -> return! fourOhFour next ctx }
}
/// GET /user/log-on /// GET /user/log-on
let logOn : HttpHandler = let logOn : HttpHandler =
requireAccess [ AccessLevel.Public ] requireAccess [ AccessLevel.Public ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
task { let! groups = ctx.db.GroupList ()
let! groups = ctx.dbContext().GroupList () let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl match url with
match url with | Some _ ->
| Some _ -> ctx.Session.Remove Key.Session.redirectUrl
ctx.Session.Remove Key.Session.redirectUrl addWarning ctx s.["The page you requested requires authentication; please log on below."]
addWarning ctx s.["The page you requested requires authentication; please log on below."] | None -> ()
| None -> () return!
return! { viewInfo ctx startTicks with helpLink = Some Help.logOn }
{ viewInfo ctx startTicks with helpLink = Some Help.logOn } |> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx
|> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx |> renderHtml next ctx
|> renderHtml next ctx }
}
/// GET /users /// GET /users
let maintain : HttpHandler = let maintain : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { let! users = ctx.db.AllUsers ()
let! users = ctx.dbContext().AllUsers () return!
return! viewInfo ctx startTicks
viewInfo ctx startTicks |> Views.User.maintain users ctx
|> Views.User.maintain users ctx |> renderHtml next ctx
|> renderHtml next ctx }
}
/// GET /user/password /// GET /user/password
@ -224,104 +214,98 @@ let password : HttpHandler =
let save : HttpHandler = let save : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! ctx.TryBindFormAsync<EditUser> () with
match! ctx.TryBindFormAsync<EditUser> () with | Ok m ->
| Ok m -> let! user =
let db = ctx.dbContext () match m.isNew () with
let! user = | true -> Task.FromResult (Some { User.empty with userId = Guid.NewGuid () })
match m.isNew () with | false -> ctx.db.TryUserById m.userId
| true -> Task.FromResult (Some { User.empty with userId = Guid.NewGuid () }) let saltedUser =
| false -> db.TryUserById m.userId match user with
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
| Some u -> | Some u ->
let updatedUser = m.populateUser u (pbkdf2Hash (Option.get u.salt)) match u.salt with
updatedUser |> (match m.isNew () with true -> db.AddEntry | false -> db.UpdateEntry) | None when m.password <> "" ->
let! _ = db.SaveChangesAsync () // Generate salt so that a new password hash can be generated
let s = Views.I18N.localizer.Force () Some { u with salt = Some (Guid.NewGuid ()) }
match m.isNew () with | _ ->
| true -> // Leave the user with no salt, so prior hash can be validated/upgraded
let h = CommonFunctions.htmlString user
{ UserMessage.info with | _ -> user
text = h s.["Successfully {0} user", s.["Added"].Value.ToLower ()] match saltedUser with
description = | Some u ->
h s.["Please select at least one group for which this user ({0}) is authorized", let updatedUser = m.populateUser u (pbkdf2Hash (Option.get u.salt))
updatedUser.fullName] updatedUser |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
|> Some let! _ = ctx.db.SaveChangesAsync ()
} let s = Views.I18N.localizer.Force ()
|> addUserMessage ctx match m.isNew () with
return! redirectTo false $"/web/user/{flatGuid u.userId}/small-groups" next ctx | true ->
| false -> let h = CommonFunctions.htmlString
addInfo ctx s.["Successfully {0} user", s.["Updated"].Value.ToLower ()] { UserMessage.info with
return! redirectTo false "/web/users" next ctx text = h s.["Successfully {0} user", s.["Added"].Value.ToLower ()]
| None -> return! fourOhFour next ctx description =
| Error e -> return! bindError e next ctx 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 /// POST /user/small-groups/save
let saveGroups : HttpHandler = let saveGroups : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> validateCSRF >=> validateCSRF
>=> fun next ctx -> >=> fun next ctx -> task {
task { match! ctx.TryBindFormAsync<AssignGroups> () with
match! ctx.TryBindFormAsync<AssignGroups> () with | Ok m ->
| Ok m -> let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () match Seq.length m.smallGroups with
match Seq.length m.smallGroups with | 0 ->
| 0 -> addError ctx s.["You must select at least one group to assign"]
addError ctx s.["You must select at least one group to assign"] return! redirectTo false $"/web/user/{flatGuid m.userId}/small-groups" next ctx
return! redirectTo false $"/web/user/{flatGuid m.userId}/small-groups" next ctx | _ ->
| _ -> match! ctx.db.TryUserByIdWithGroups m.userId with
let db = ctx.dbContext () | Some user ->
match! db.TryUserByIdWithGroups m.userId with let grps =
| Some user -> m.smallGroups.Split ','
let grps = |> Array.map Guid.Parse
m.smallGroups.Split ',' |> List.ofArray
|> Array.map Guid.Parse user.smallGroups
|> List.ofArray |> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId)))
user.smallGroups |> ctx.db.UserGroupXref.RemoveRange
|> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId))) grps
|> db.UserGroupXref.RemoveRange |> Seq.ofList
grps |> Seq.filter (fun x -> not (user.smallGroups |> Seq.exists (fun y -> y.smallGroupId = x)))
|> Seq.ofList |> Seq.map (fun x -> { UserSmallGroup.empty with userId = user.userId; smallGroupId = x })
|> Seq.filter (fun x -> not (user.smallGroups |> Seq.exists (fun y -> y.smallGroupId = x))) |> List.ofSeq
|> Seq.map (fun x -> { UserSmallGroup.empty with userId = user.userId; smallGroupId = x }) |> List.iter ctx.db.AddEntry
|> List.ofSeq let! _ = ctx.db.SaveChangesAsync ()
|> List.iter db.AddEntry addInfo ctx s.["Successfully updated group permissions for {0}", m.userName]
let! _ = db.SaveChangesAsync () return! redirectTo false "/web/users" next ctx
addInfo ctx s.["Successfully updated group permissions for {0}", m.userName] | _ -> return! fourOhFour next ctx
return! redirectTo false "/web/users" next ctx | Error e -> return! bindError e next ctx
| _ -> return! fourOhFour next ctx }
| Error e -> return! bindError e next ctx
}
/// GET /user/[user-id]/small-groups /// GET /user/[user-id]/small-groups
let smallGroups userId : HttpHandler = let smallGroups userId : HttpHandler =
requireAccess [ Admin ] requireAccess [ Admin ]
>=> fun next ctx -> >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let db = ctx.dbContext () match! ctx.db.TryUserByIdWithGroups userId with
task { | Some user ->
match! db.TryUserByIdWithGroups userId with let! grps = ctx.db.GroupList ()
| Some user -> let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq
let! grps = db.GroupList () return!
let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq viewInfo ctx startTicks
return! |> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx
viewInfo ctx startTicks |> renderHtml next ctx
|> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx | None -> return! fourOhFour next ctx
|> renderHtml next ctx }
| None -> return! fourOhFour next ctx
}