Version 8 #43

Merged
danieljsummers merged 37 commits from version-8 into main 2022-08-19 19:08:31 +00:00
9 changed files with 251 additions and 220 deletions
Showing only changes of commit c3f7067899 - Show all commits

View File

@ -140,6 +140,9 @@ let makeUrl url qs =
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module Key = module Key =
/// The request start time (added via middleware, read when rendering the footer)
let startTime = "StartTime"
/// This contains constants for session-stored objects within PrayerTracker /// This contains constants for session-stored objects within PrayerTracker
module Session = module Session =
@ -155,24 +158,6 @@ module Key =
/// The URL to which the user should be redirected once they have logged in /// The URL to which the user should be redirected once they have logged in
let redirectUrl = "RedirectUrl" let redirectUrl = "RedirectUrl"
/// Names and value names for use with cookies
module Cookie =
/// The name of the user cookie
let user = "LoggedInUser"
/// The name of the class cookie
let group = "LoggedInClass"
/// The name of the culture cookie
let culture = "CurrentCulture"
/// The name of the idle timeout cookie
let timeout = "TimeoutCookie"
/// The cookies that should be cleared when a user or group logs off
let logOffCookies = [ user; group; timeout ]
/// Enumerated values for small group request list visibility (derived from preferences, used in UI) /// Enumerated values for small group request list visibility (derived from preferences, used in UI)
module GroupVisibility = module GroupVisibility =

View File

@ -1,5 +1,17 @@
namespace PrayerTracker namespace PrayerTracker
open System
open Microsoft.AspNetCore.Http
/// Middleware to add the starting ticks for the request
type RequestStartMiddleware (next : RequestDelegate) =
member this.InvokeAsync (ctx : HttpContext) = task {
ctx.Items[Key.startTime] <- DateTime.Now.Ticks
return! next.Invoke ctx
}
open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.Hosting open Microsoft.AspNetCore.Hosting
@ -23,7 +35,6 @@ module Configure =
let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) = let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
(ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel" (ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
open System
open System.Globalization open System.Globalization
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Localization open Microsoft.AspNetCore.Localization
@ -54,19 +65,19 @@ module Configure =
let _ = svc.AddSession() let _ = svc.AddSession()
let _ = svc.AddAntiforgery() let _ = svc.AddAntiforgery()
let _ = svc.AddRouting() let _ = svc.AddRouting()
let _ = svc.AddSingleton<IClock>(SystemClock.Instance) let _ = svc.AddSingleton<IClock> SystemClock.Instance
let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration>() let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration> ()
let _ = svc.AddDbContext<AppDbContext>( let _ =
(fun options -> svc.AddDbContext<AppDbContext>(
options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore), (fun options -> options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
ServiceLifetime.Scoped, ServiceLifetime.Singleton) ServiceLifetime.Scoped, ServiceLifetime.Singleton)
() ()
open Giraffe open Giraffe
let noWeb : HttpHandler = fun next ctx -> let noWeb : HttpHandler = fun next ctx ->
redirectTo true ($"""/{string ctx.Request.RouteValues["path"]}""") next ctx redirectTo true $"""/{string ctx.Request.RouteValues["path"]}""" next ctx
open Giraffe.EndpointRouting open Giraffe.EndpointRouting
@ -186,6 +197,8 @@ module Configure =
let _ = app.UseStatusCodePagesWithReExecute "/error/{0}" let _ = app.UseStatusCodePagesWithReExecute "/error/{0}"
let _ = app.UseStaticFiles () let _ = app.UseStaticFiles ()
let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<RequestStartMiddleware> ()
let _ = app.UseRouting () let _ = app.UseRouting ()
let _ = app.UseSession () let _ = app.UseSession ()
let _ = app.UseRequestLocalization let _ = app.UseRequestLocalization

View File

@ -33,17 +33,16 @@ open System
/// GET /church/[church-id]/edit /// GET /church/[church-id]/edit
let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
if churchId = Guid.Empty then if churchId = Guid.Empty then
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.Church.edit EditChurch.empty ctx |> Views.Church.edit EditChurch.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.Db.TryChurchById (ChurchId churchId) with match! ctx.Db.TryChurchById (ChurchId churchId) with
| Some church -> | Some church ->
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.Church.edit (EditChurch.fromChurch church) ctx |> Views.Church.edit (EditChurch.fromChurch church) ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
@ -51,12 +50,11 @@ let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> ta
/// GET /churches /// GET /churches
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let await = Async.AwaitTask >> Async.RunSynchronously
let await = Async.AwaitTask >> Async.RunSynchronously let! churches = ctx.Db.AllChurches ()
let! churches = ctx.Db.AllChurches () let stats = churches |> List.map (fun c -> await (findStats ctx.Db c.Id))
let stats = churches |> List.map (fun c -> await (findStats ctx.Db c.Id))
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.Church.maintain churches (stats |> Map.ofList) ctx |> Views.Church.maintain churches (stats |> Map.ofList) ctx
|> renderHtml next ctx |> renderHtml next ctx
} }

View File

@ -48,7 +48,7 @@ open PrayerTracker
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
/// Create the common view information heading /// Create the common view information heading
let viewInfo (ctx : HttpContext) startTicks = let viewInfo (ctx : HttpContext) =
let msg = let msg =
match ctx.Session.Messages with match ctx.Session.Messages with
| [] -> [] | [] -> []
@ -63,9 +63,9 @@ let viewInfo (ctx : HttpContext) startTicks =
{ AppViewInfo.fresh with { AppViewInfo.fresh with
Version = appVersion Version = appVersion
Messages = msg Messages = msg
RequestStart = startTicks RequestStart = ctx.Items[Key.startTime] :?> int64
User = ctx.CurrentUser User = ctx.Session.CurrentUser
Group = ctx.CurrentGroup Group = ctx.Session.CurrentGroup
Layout = layout Layout = layout
} }
@ -141,7 +141,9 @@ open PrayerTracker.Entities
/// Require one of the given access roles /// Require one of the given access roles
let requireAccess levels : HttpHandler = fun next ctx -> task { let requireAccess levels : HttpHandler = fun next ctx -> task {
match ctx.CurrentUser, ctx.CurrentGroup with let! user = ctx.CurrentUser ()
let! group = ctx.CurrentGroup ()
match user, group with
| _, _ when List.contains Public levels -> return! next ctx | _, _ when List.contains Public levels -> return! next ctx
| Some _, _ when List.contains User levels -> return! next ctx | Some _, _ when List.contains User levels -> return! next ctx
| _, Some _ when List.contains Group levels -> return! next ctx | _, Some _ when List.contains Group levels -> return! next ctx

View File

@ -2,6 +2,7 @@
module PrayerTracker.Extensions module PrayerTracker.Extensions
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open Microsoft.FSharpLu
open Newtonsoft.Json open Newtonsoft.Json
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
@ -17,6 +18,22 @@ type ISession with
member this.GetObject<'T> key = member this.GetObject<'T> key =
match this.GetString key with null -> Unchecked.defaultof<'T> | v -> JsonConvert.DeserializeObject<'T> v match this.GetString key with null -> Unchecked.defaultof<'T> | v -> JsonConvert.DeserializeObject<'T> v
/// The currently logged on small group
member this.CurrentGroup
with get () = this.GetObject<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
/// The currently logged on user
member this.CurrentUser
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
/// Current messages for the session /// Current messages for the session
member this.Messages member this.Messages
with get () = with get () =
@ -26,27 +43,63 @@ type ISession with
and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v
open System.Security.Claims
/// Extensions on the claims principal
type ClaimsPrincipal with
/// The ID of the currently logged on small group
member this.SmallGroupId =
if this.HasClaim (fun c -> c.Type = ClaimTypes.GroupSid) then
Some (idFromShort SmallGroupId (this.FindFirst(fun c -> c.Type = ClaimTypes.GroupSid).Value))
else None
/// The ID of the currently signed in user
member this.UserId =
if this.HasClaim (fun c -> c.Type = ClaimTypes.NameIdentifier) then
Some (idFromShort UserId (this.FindFirst(fun c -> c.Type = ClaimTypes.NameIdentifier).Value))
else None
open Giraffe open Giraffe
open Microsoft.FSharpLu open NodaTime
open PrayerTracker
/// Extensions on the ASP.NET Core HTTP context /// Extensions on the ASP.NET Core HTTP context
type HttpContext with type HttpContext with
/// The currently logged on small group
member this.CurrentGroup
with get () = this.Session.GetObject<SmallGroup> Key.Session.currentGroup |> Option.fromObject
and set (v : SmallGroup option) =
match v with
| Some group -> this.Session.SetObject Key.Session.currentGroup group
| None -> this.Session.Remove Key.Session.currentGroup
/// The currently logged on user
member this.CurrentUser
with get () = this.Session.GetObject<User> Key.Session.currentUser |> Option.fromObject
and set (v : User option) =
match v with
| Some user -> this.Session.SetObject Key.Session.currentUser user
| None -> this.Session.Remove Key.Session.currentUser
/// The EF Core database context (via DI) /// The EF Core database context (via DI)
member this.Db = this.GetService<AppDbContext> () member this.Db = this.GetService<AppDbContext> ()
/// The system clock (via DI)
member this.Clock = this.GetService<IClock> ()
/// The currently logged on small group (sets the value in the session if it is missing)
member this.CurrentGroup () = task {
match this.Session.CurrentGroup with
| Some group -> return Some group
| None ->
match this.User.SmallGroupId with
| Some groupId ->
match! this.Db.TryGroupById groupId with
| Some group ->
this.Session.CurrentGroup <- Some group
return Some group
| None -> return None
| None -> return None
}
/// The currently logged on user (sets the value in the session if it is missing)
member this.CurrentUser () = task {
match this.Session.CurrentUser with
| Some user -> return Some user
| None ->
match this.User.UserId with
| Some userId ->
match! this.Db.TryUserById userId with
| Some user ->
this.Session.CurrentUser <- Some user
return Some user
| None -> return None
| None -> return None
}

View File

@ -9,13 +9,13 @@ open PrayerTracker
/// GET /error/[error-code] /// GET /error/[error-code]
let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx
|> Views.Home.error code |> Views.Home.error code
|> renderHtml next ctx |> renderHtml next ctx
/// GET / /// GET /
let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx
|> Views.Home.index |> Views.Home.index
|> renderHtml next ctx |> renderHtml next ctx
@ -44,13 +44,13 @@ let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fu
/// GET /legal/privacy-policy /// GET /legal/privacy-policy
let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx
|> Views.Home.privacyPolicy |> Views.Home.privacyPolicy
|> renderHtml next ctx |> renderHtml next ctx
/// GET /legal/terms-of-service /// GET /legal/terms-of-service
let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx
|> Views.Home.termsOfService |> Views.Home.termsOfService
|> renderHtml next ctx |> renderHtml next ctx
@ -68,6 +68,6 @@ let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
/// GET /unauthorized /// GET /unauthorized
let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx
|> Views.Home.unauthorized |> Views.Home.unauthorized
|> renderHtml next ctx |> renderHtml next ctx

View File

@ -9,7 +9,7 @@ open PrayerTracker.ViewModels
/// 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 = task { let private findRequest (ctx : HttpContext) reqId = task {
match! ctx.Db.TryRequestById reqId with match! ctx.Db.TryRequestById reqId with
| Some req when req.SmallGroupId = ctx.CurrentGroup.Value.Id -> return Ok req | Some req when req.SmallGroupId = ctx.Session.CurrentGroup.Value.Id -> return Ok req
| Some _ -> | 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"]
@ -17,20 +17,17 @@ let private findRequest (ctx : HttpContext) reqId = task {
| None -> return Result.Error (fourOhFour ctx) | None -> return Result.Error (fourOhFour ctx)
} }
open NodaTime
/// Generate a list of requests for the given date /// Generate a list of requests for the given date
let private generateRequestList (ctx : HttpContext) date = task { let private generateRequestList (ctx : HttpContext) date = task {
let grp = ctx.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let clock = ctx.GetService<IClock> () let listDate = match date with Some d -> d | None -> group.LocalDateNow ctx.Clock
let listDate = match date with Some d -> d | None -> grp.LocalDateNow clock let! reqs = ctx.Db.AllRequestsForSmallGroup group ctx.Clock (Some listDate) true 0
let! reqs = ctx.Db.AllRequestsForSmallGroup grp clock (Some listDate) true 0
return return
{ Requests = reqs { Requests = reqs
Date = listDate Date = listDate
SmallGroup = grp SmallGroup = group
ShowHeader = true ShowHeader = true
CanEmail = Option.isSome ctx.CurrentUser CanEmail = Option.isSome ctx.User.UserId
Recipients = [] Recipients = []
} }
} }
@ -45,20 +42,19 @@ let private parseListDate (date : string option) =
/// GET /prayer-request/[request-id]/edit /// GET /prayer-request/[request-id]/edit
let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let group = ctx.Session.CurrentGroup.Value
let grp = ctx.CurrentGroup.Value let now = group.LocalDateNow ctx.Clock
let now = grp.LocalDateNow (ctx.GetService<IClock> ()) let requestId = PrayerRequestId reqId
let requestId = PrayerRequestId reqId
if requestId.Value = Guid.Empty then if requestId.Value = Guid.Empty then
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.editRequest } { viewInfo ctx with HelpLink = Some Help.editRequest }
|> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
if req.IsExpired now grp.Preferences.DaysToExpire then if req.IsExpired now group.Preferences.DaysToExpire then
{ UserMessage.warning with { UserMessage.warning with
Text = htmlLocString s["This request is expired."] Text = htmlLocString s["This request is expired."]
Description = Description =
@ -68,7 +64,7 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
} }
|> addUserMessage ctx |> addUserMessage ctx
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.editRequest } { viewInfo ctx with HelpLink = Some Help.editRequest }
|> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx
|> renderHtml next ctx |> renderHtml next ctx
| Result.Error e -> return! e | Result.Error e -> return! e
@ -76,18 +72,17 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
/// GET /prayer-requests/email/[date] /// GET /prayer-requests/email/[date]
let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
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 group = ctx.Session.CurrentGroup.Value
let grp = ctx.CurrentGroup.Value let! list = generateRequestList ctx listDate
let! list = generateRequestList ctx listDate let! recipients = ctx.Db.AllMembersForSmallGroup group.Id
let! recipients = ctx.Db.AllMembersForSmallGroup grp.Id 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 group s["Prayer Requests for {0} - {1:MMMM d, yyyy}", group.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
|> Views.PrayerRequest.email { list with Recipients = recipients } |> Views.PrayerRequest.email { list with Recipients = recipients }
|> renderHtml next ctx |> renderHtml next ctx
} }
@ -120,19 +115,17 @@ let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task
/// GET /prayer-requests/[group-id]/list /// GET /prayer-requests/[group-id]/list
let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
match! ctx.Db.TryGroupById groupId with match! ctx.Db.TryGroupById groupId with
| Some grp when grp.Preferences.IsPublic -> | Some group when group.Preferences.IsPublic ->
let clock = ctx.GetService<IClock> () let! reqs = ctx.Db.AllRequestsForSmallGroup group ctx.Clock None true 0
let! reqs = ctx.Db.AllRequestsForSmallGroup grp clock None true 0
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.PrayerRequest.list |> Views.PrayerRequest.list
{ Requests = reqs { Requests = reqs
Date = grp.LocalDateNow clock Date = group.LocalDateNow ctx.Clock
SmallGroup = grp SmallGroup = group
ShowHeader = true ShowHeader = true
CanEmail = Option.isSome ctx.CurrentUser CanEmail = Option.isSome ctx.User.UserId
Recipients = [] Recipients = []
} }
|> renderHtml next ctx |> renderHtml next ctx
@ -145,10 +138,9 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
/// GET /prayer-requests/lists /// GET /prayer-requests/lists
let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let! groups = ctx.Db.PublicAndProtectedGroups ()
let! groups = ctx.Db.PublicAndProtectedGroups ()
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.PrayerRequest.lists groups |> Views.PrayerRequest.lists groups
|> renderHtml next ctx |> renderHtml next ctx
} }
@ -157,16 +149,15 @@ let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
/// - OR - /// - OR -
/// GET /prayer-requests?search=[search-query] /// GET /prayer-requests?search=[search-query]
let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let group = ctx.Session.CurrentGroup.Value
let grp = ctx.CurrentGroup.Value 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
| Result.Error _ -> 1 | Result.Error _ -> 1
let! m = backgroundTask { let! model = backgroundTask {
match ctx.GetQueryStringValue "search" with match ctx.GetQueryStringValue "search" with
| Ok search -> | Ok search ->
let! reqs = ctx.Db.SearchRequestsForSmallGroup grp search pageNbr let! reqs = ctx.Db.SearchRequestsForSmallGroup group search pageNbr
return return
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
@ -174,7 +165,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
PageNbr = Some pageNbr PageNbr = Some pageNbr
} }
| Result.Error _ -> | Result.Error _ ->
let! reqs = ctx.Db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr let! reqs = ctx.Db.AllRequestsForSmallGroup group ctx.Clock None onlyActive pageNbr
return return
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
@ -183,8 +174,8 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
} }
} }
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.maintainRequests } { viewInfo ctx with HelpLink = Some Help.maintainRequests }
|> Views.PrayerRequest.maintain { m with SmallGroup = grp } ctx |> Views.PrayerRequest.maintain { model with SmallGroup = group } ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
@ -214,36 +205,37 @@ open System.Threading.Tasks
/// POST /prayer-request/save /// POST /prayer-request/save
let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditRequest> () with match! ctx.TryBindFormAsync<EditRequest> () with
| Ok m -> | Ok model ->
let! req = let! req =
if m.IsNew then Task.FromResult (Some { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () }) if model.IsNew then
else ctx.Db.TryRequestById (idFromShort PrayerRequestId m.RequestId) Task.FromResult (Some { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () })
else ctx.Db.TryRequestById (idFromShort PrayerRequestId model.RequestId)
match req with match req with
| Some pr -> | Some pr ->
let upd8 = let upd8 =
{ pr with { pr with
RequestType = PrayerRequestType.fromCode m.RequestType RequestType = PrayerRequestType.fromCode model.RequestType
Requestor = match m.Requestor with Some x when x.Trim () = "" -> None | x -> x Requestor = match model.Requestor with Some x when x.Trim () = "" -> None | x -> x
Text = ckEditorToText m.Text Text = ckEditorToText model.Text
Expiration = Expiration.fromCode m.Expiration Expiration = Expiration.fromCode model.Expiration
} }
let grp = ctx.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let now = grp.LocalDateNow (ctx.GetService<IClock> ()) let now = group.LocalDateNow ctx.Clock
match m.IsNew with match model.IsNew with
| true -> | true ->
let dt = defaultArg m.EnteredDate now let dt = defaultArg model.EnteredDate now
{ upd8 with { upd8 with
SmallGroupId = grp.Id SmallGroupId = group.Id
UserId = ctx.CurrentUser.Value.Id UserId = ctx.User.UserId.Value
EnteredDate = dt EnteredDate = dt
UpdatedDate = dt UpdatedDate = dt
} }
| false when defaultArg m.SkipDateUpdate false -> upd8 | false when defaultArg model.SkipDateUpdate false -> upd8
| false -> { upd8 with UpdatedDate = now } | false -> { upd8 with UpdatedDate = now }
|> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry |> if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry
let! _ = ctx.Db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let act = if m.IsNew then "Added" else "Updated" let act = if model.IsNew then "Added" else "Updated"
addInfo ctx s["Successfully {0} prayer request", s[act].Value.ToLower ()] addInfo ctx s["Successfully {0} prayer request", s[act].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
@ -252,10 +244,9 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
/// GET /prayer-request/view/[date?] /// GET /prayer-request/view/[date?]
let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task { let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let! list = generateRequestList ctx (parseListDate date)
let! list = generateRequestList ctx (parseListDate date)
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.PrayerRequest.view { list with ShowHeader = false } |> Views.PrayerRequest.view { list with ShowHeader = false }
|> renderHtml next ctx |> renderHtml next ctx
} }

View File

@ -8,8 +8,8 @@ open PrayerTracker.ViewModels
/// GET /small-group/announcement /// GET /small-group/announcement
let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
{ viewInfo ctx DateTime.Now.Ticks with HelpLink = Some Help.sendAnnouncement } { viewInfo ctx with HelpLink = Some Help.sendAnnouncement }
|> Views.SmallGroup.announcement ctx.CurrentUser.Value.IsAdmin ctx |> Views.SmallGroup.announcement ctx.Session.CurrentUser.Value.IsAdmin ctx
|> renderHtml next ctx |> renderHtml next ctx
/// POST /small-group/[group-id]/delete /// POST /small-group/[group-id]/delete
@ -32,9 +32,10 @@ let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fu
/// POST /small-group/member/[member-id]/delete /// POST /small-group/member/[member-id]/delete
let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let group = ctx.Session.CurrentGroup.Value
let memberId = MemberId mbrId let memberId = MemberId mbrId
match! ctx.Db.TryMemberById memberId with match! ctx.Db.TryMemberById memberId with
| Some mbr when mbr.SmallGroupId = ctx.CurrentGroup.Value.Id -> | Some mbr when mbr.SmallGroupId = group.Id ->
ctx.Db.RemoveEntry mbr ctx.Db.RemoveEntry mbr
let! _ = ctx.Db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
addHtmlInfo ctx s["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.Name] addHtmlInfo ctx s["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.Name]
@ -45,19 +46,18 @@ let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >
/// GET /small-group/[group-id]/edit /// GET /small-group/[group-id]/edit
let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let! churches = ctx.Db.AllChurches ()
let! churches = ctx.Db.AllChurches () let groupId = SmallGroupId grpId
let groupId = SmallGroupId grpId
if groupId.Value = Guid.Empty then if groupId.Value = Guid.Empty then
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.SmallGroup.edit EditSmallGroup.empty churches ctx |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.Db.TryGroupById groupId with match! ctx.Db.TryGroupById groupId with
| Some grp -> | Some grp ->
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
@ -65,21 +65,20 @@ let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
/// GET /small-group/member/[member-id]/edit /// GET /small-group/member/[member-id]/edit
let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () let group = ctx.Session.CurrentGroup.Value
let grp = ctx.CurrentGroup.Value let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType s
let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s let memberId = MemberId mbrId
let memberId = MemberId mbrId
if memberId.Value = Guid.Empty then if memberId.Value = Guid.Empty then
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.SmallGroup.editMember EditMember.empty types ctx |> Views.SmallGroup.editMember EditMember.empty types ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.Db.TryMemberById memberId with match! ctx.Db.TryMemberById memberId with
| Some mbr when mbr.SmallGroupId = grp.Id -> | Some mbr when mbr.SmallGroupId = group.Id ->
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.SmallGroup.editMember (EditMember.fromMember mbr) types ctx |> Views.SmallGroup.editMember (EditMember.fromMember mbr) types ctx
|> renderHtml next ctx |> renderHtml next ctx
| Some _ | Some _
@ -88,11 +87,10 @@ let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
/// GET /small-group/log-on/[group-id?] /// GET /small-group/log-on/[group-id?]
let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let! groups = ctx.Db.ProtectedGroups ()
let! groups = ctx.Db.ProtectedGroups () let groupId = match grpId with Some gid -> shortGuid gid | None -> ""
let groupId = match grpId with Some gid -> shortGuid gid | None -> ""
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.logOn } { viewInfo ctx with HelpLink = Some Help.logOn }
|> Views.SmallGroup.logOn groups groupId ctx |> Views.SmallGroup.logOn groups groupId ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
@ -108,7 +106,7 @@ let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validat
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match! ctx.Db.TryGroupLogOnByPassword (idFromShort SmallGroupId model.SmallGroupId) model.Password with match! ctx.Db.TryGroupLogOnByPassword (idFromShort SmallGroupId model.SmallGroupId) model.Password with
| Some group -> | Some group ->
ctx.CurrentGroup <- Some group ctx.Session.CurrentGroup <- Some group
let claims = Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) |> Seq.singleton let claims = Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) |> Seq.singleton
let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync do! ctx.SignInAsync
@ -126,38 +124,32 @@ let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validat
/// GET /small-groups /// GET /small-groups
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let! groups = ctx.Db.AllGroups () let! groups = ctx.Db.AllGroups ()
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.SmallGroup.maintain groups ctx |> Views.SmallGroup.maintain groups ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group/members /// GET /small-group/members
let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let group = ctx.Session.CurrentGroup.Value
let grp = ctx.CurrentGroup.Value let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () let! members = ctx.Db.AllMembersForSmallGroup group.Id
let! members = ctx.Db.AllMembersForSmallGroup grp.Id let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType s |> Map.ofSeq
let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s |> Map.ofSeq
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.maintainGroupMembers } { viewInfo ctx with HelpLink = Some Help.maintainGroupMembers }
|> Views.SmallGroup.members members types ctx |> Views.SmallGroup.members members types ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
open NodaTime
/// GET /small-group /// GET /small-group
let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let group = ctx.Session.CurrentGroup.Value
let clock = ctx.GetService<IClock> () let! reqs = ctx.Db.AllRequestsForSmallGroup group ctx.Clock None true 0
let group = ctx.CurrentGroup.Value let! reqCount = ctx.Db.CountRequestsBySmallGroup group.Id
let! reqs = ctx.Db.AllRequestsForSmallGroup group clock None true 0 let! mbrCount = ctx.Db.CountMembersForSmallGroup group.Id
let! reqCount = ctx.Db.CountRequestsBySmallGroup group.Id let model =
let! mbrCount = ctx.Db.CountMembersForSmallGroup group.Id
let m =
{ TotalActiveReqs = List.length reqs { TotalActiveReqs = List.length reqs
AllReqs = reqCount AllReqs = reqCount
TotalMembers = mbrCount TotalMembers = mbrCount
@ -170,18 +162,18 @@ let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
|> Map.ofSeq) |> Map.ofSeq)
} }
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.SmallGroup.overview m |> Views.SmallGroup.overview model
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group/preferences /// GET /small-group/preferences
let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let group = ctx.Session.CurrentGroup.Value
let! tzs = ctx.Db.AllTimeZones () let! tzs = ctx.Db.AllTimeZones ()
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.groupPreferences } { viewInfo ctx with HelpLink = Some Help.groupPreferences }
|> Views.SmallGroup.preferences (EditPreferences.fromPreferences ctx.CurrentGroup.Value.Preferences) tzs ctx |> Views.SmallGroup.preferences (EditPreferences.fromPreferences group.Preferences) tzs ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
@ -190,22 +182,22 @@ open System.Threading.Tasks
/// POST /small-group/save /// POST /small-group/save
let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditSmallGroup> () with match! ctx.TryBindFormAsync<EditSmallGroup> () with
| Ok m -> | Ok model ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let! group = let! group =
if m.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () }) if model.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () })
else ctx.Db.TryGroupById (idFromShort SmallGroupId m.SmallGroupId) else ctx.Db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId)
match group with match group with
| Some grp -> | Some grp ->
m.populateGroup grp model.populateGroup grp
|> function |> function
| grp when m.IsNew -> | grp when model.IsNew ->
ctx.Db.AddEntry grp ctx.Db.AddEntry grp
ctx.Db.AddEntry { grp.Preferences with SmallGroupId = grp.Id } ctx.Db.AddEntry { grp.Preferences with SmallGroupId = grp.Id }
| grp -> ctx.Db.UpdateEntry grp | grp -> ctx.Db.UpdateEntry grp
let! _ = ctx.Db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let act = s[if m.IsNew then "Added" else "Updated"].Value.ToLower () let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addHtmlInfo ctx s["Successfully {0} group “{1}”", act, m.Name] addHtmlInfo ctx s["Successfully {0} group “{1}”", act, model.Name]
return! redirectTo false "/small-groups" next ctx return! redirectTo false "/small-groups" next ctx
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
@ -215,13 +207,13 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditMember> () with match! ctx.TryBindFormAsync<EditMember> () with
| Ok model -> | Ok model ->
let grp = ctx.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let! mMbr = let! mMbr =
if model.IsNew then if model.IsNew then
Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = grp.Id }) Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = group.Id })
else ctx.Db.TryMemberById (idFromShort MemberId model.MemberId) else ctx.Db.TryMemberById (idFromShort MemberId model.MemberId)
match mMbr with match mMbr with
| Some mbr when mbr.SmallGroupId = grp.Id -> | Some mbr when mbr.SmallGroupId = group.Id ->
{ mbr with { mbr with
Name = model.Name Name = model.Name
Email = model.Email Email = model.Email
@ -245,13 +237,14 @@ let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
// Since the class is stored in the session, we'll use an intermediate instance to persist it; once that works, // 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 // 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. // database values, not the then out-of-sync session ones.
match! ctx.Db.TryGroupById ctx.CurrentGroup.Value.Id with let group = ctx.Session.CurrentGroup.Value
match! ctx.Db.TryGroupById group.Id with
| Some grp -> | Some grp ->
let prefs = model.PopulatePreferences grp.Preferences let prefs = model.PopulatePreferences grp.Preferences
ctx.Db.UpdateEntry prefs ctx.Db.UpdateEntry prefs
let! _ = ctx.Db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
// Refresh session instance // Refresh session instance
ctx.CurrentGroup <- Some { grp with Preferences = prefs } ctx.Session.CurrentGroup <- 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 "/small-group/preferences" next ctx return! redirectTo false "/small-group/preferences" next ctx
@ -264,28 +257,27 @@ open PrayerTracker.Views.CommonFunctions
/// POST /small-group/announcement/send /// POST /small-group/announcement/send
let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
match! ctx.TryBindFormAsync<Announcement> () with match! ctx.TryBindFormAsync<Announcement> () with
| Ok model -> | Ok model ->
let grp = ctx.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let usr = ctx.CurrentUser.Value let prefs = group.Preferences
let now = grp.LocalTimeNow (ctx.GetService<IClock> ()) let usr = ctx.Session.CurrentUser.Value
let s = Views.I18N.localizer.Force () let now = group.LocalTimeNow ctx.Clock
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
let requestText = ckEditorToText model.Text let requestText = ckEditorToText model.Text
let htmlText = let htmlText =
p [ _style $"font-family:{grp.Preferences.Fonts};font-size:%d{grp.Preferences.TextFontSize}pt;" ] p [ _style $"font-family:{prefs.Fonts};font-size:%d{prefs.TextFontSize}pt;" ] [ rawText requestText ]
[ rawText requestText ]
|> renderHtmlNode |> renderHtmlNode
let plainText = (htmlToPlainText >> wordWrap 74) htmlText let plainText = (htmlToPlainText >> wordWrap 74) htmlText
// Send the e-mails // Send the e-mails
let! recipients = let! recipients =
match model.SendToClass with match model.SendToClass with
| "N" when usr.IsAdmin -> ctx.Db.AllUsersAsMembers () | "N" when usr.IsAdmin -> ctx.Db.AllUsersAsMembers ()
| _ -> ctx.Db.AllMembersForSmallGroup grp.Id | _ -> ctx.Db.AllMembersForSmallGroup group.Id
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails client recipients grp do! Email.sendEmails client recipients group
s["Announcement for {0} - {1:MMMM d, yyyy} {2}", grp.Name, now.Date, s["Announcement for {0} - {1:MMMM d, yyyy} {2}", group.Name, now.Date,
(now.ToString "h:mm tt").ToLower ()].Value (now.ToString "h:mm tt").ToLower ()].Value
htmlText plainText s htmlText plainText s
// Add to the request list if desired // Add to the request list if desired
@ -296,7 +288,7 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
| _, _ -> | _, _ ->
{ PrayerRequest.empty with { PrayerRequest.empty with
Id = (Guid.NewGuid >> PrayerRequestId) () Id = (Guid.NewGuid >> PrayerRequestId) ()
SmallGroupId = grp.Id SmallGroupId = group.Id
UserId = usr.Id UserId = usr.Id
RequestType = (Option.get >> PrayerRequestType.fromCode) model.RequestType RequestType = (Option.get >> PrayerRequestType.fromCode) model.RequestType
Text = requestText Text = requestText
@ -314,7 +306,7 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
let andAdded = match model.AddToRequestList with Some x when x -> "and added it to the request list" | _ -> "" let andAdded = match model.AddToRequestList with Some x when x -> "and added it to the request list" | _ -> ""
addInfo ctx s["Successfully sent announcement to all {0} {1}", toWhom, s[andAdded]] addInfo ctx s["Successfully sent announcement to all {0} {1}", toWhom, s[andAdded]]
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.SmallGroup.announcementSent { model with Text = htmlText } |> Views.SmallGroup.announcementSent { model with Text = htmlText }
|> renderHtml next ctx |> renderHtml next ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx

View File

@ -37,14 +37,15 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f
match! ctx.TryBindFormAsync<ChangePassword> () with match! ctx.TryBindFormAsync<ChangePassword> () with
| Ok model -> | Ok model ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let curUsr = ctx.CurrentUser.Value let curUsr = ctx.Session.CurrentUser.Value
let! dbUsr = ctx.Db.TryUserById curUsr.Id let! dbUsr = ctx.Db.TryUserById curUsr.Id
let group = ctx.Session.CurrentGroup.Value
let! user = let! user =
match dbUsr with match dbUsr with
| Some usr -> | Some usr ->
// Check the old password against a possibly non-salted hash // Check the old password against a possibly non-salted hash
(match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) model.OldPassword (match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) model.OldPassword
|> ctx.Db.TryUserLogOnByCookie curUsr.Id ctx.CurrentGroup.Value.Id |> ctx.Db.TryUserLogOnByCookie curUsr.Id group.Id
| _ -> Task.FromResult None | _ -> Task.FromResult None
match user with match user with
| Some _ when model.NewPassword = model.NewPasswordConfirm -> | Some _ when model.NewPassword = model.NewPasswordConfirm ->
@ -96,8 +97,8 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
let! nextUrl = backgroundTask { let! nextUrl = backgroundTask {
match usr with match usr with
| Some user -> | Some user ->
ctx.CurrentUser <- usr ctx.Session.CurrentUser <- usr
ctx.CurrentGroup <- Some group ctx.Session.CurrentGroup <- Some group
let claims = seq { let claims = seq {
Claim (ClaimTypes.NameIdentifier, shortGuid user.Id.Value) Claim (ClaimTypes.NameIdentifier, shortGuid user.Id.Value)
Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value)
@ -144,18 +145,17 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
/// GET /user/[user-id]/edit /// GET /user/[user-id]/edit
let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let userId = UserId usrId let userId = UserId usrId
if userId.Value = Guid.Empty then if userId.Value = Guid.Empty then
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.User.edit EditUser.empty ctx |> Views.User.edit EditUser.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.Db.TryUserById userId with match! ctx.Db.TryUserById userId with
| Some user -> | Some user ->
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.User.edit (EditUser.fromUser user) ctx |> Views.User.edit (EditUser.fromUser user) ctx
|> renderHtml next ctx |> renderHtml next ctx
| _ -> return! fourOhFour ctx | _ -> return! fourOhFour ctx
@ -164,17 +164,16 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
/// GET /user/log-on /// GET /user/log-on
let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () let! groups = ctx.Db.GroupList ()
let! groups = ctx.Db.GroupList () let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
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 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
} }
@ -182,10 +181,9 @@ let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
/// GET /users /// GET /users
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let! users = ctx.Db.AllUsers ()
let! users = ctx.Db.AllUsers ()
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.User.maintain users ctx |> Views.User.maintain users ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
@ -193,7 +191,7 @@ let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
/// GET /user/password /// GET /user/password
let password : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let password : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
{ viewInfo ctx DateTime.Now.Ticks with HelpLink = Some Help.changePassword } { viewInfo ctx with HelpLink = Some Help.changePassword }
|> Views.User.changePassword ctx |> Views.User.changePassword ctx
|> renderHtml next ctx |> renderHtml next ctx
@ -201,15 +199,15 @@ let password : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
/// POST /user/save /// POST /user/save
let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditUser> () with match! ctx.TryBindFormAsync<EditUser> () with
| Ok m -> | Ok model ->
let! user = let! user =
if m.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () }) if model.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () })
else ctx.Db.TryUserById (idFromShort UserId m.UserId) else ctx.Db.TryUserById (idFromShort UserId model.UserId)
let saltedUser = let saltedUser =
match user with match user with
| Some u -> | Some u ->
match u.Salt with match u.Salt with
| None when m.Password <> "" -> | None when model.Password <> "" ->
// Generate salt so that a new password hash can be generated // Generate salt so that a new password hash can be generated
Some { u with Salt = Some (Guid.NewGuid ()) } Some { u with Salt = Some (Guid.NewGuid ()) }
| _ -> | _ ->
@ -218,11 +216,11 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
| _ -> user | _ -> user
match saltedUser with match saltedUser with
| Some u -> | Some u ->
let updatedUser = m.PopulateUser u (pbkdf2Hash (Option.get u.Salt)) let updatedUser = model.PopulateUser u (pbkdf2Hash (Option.get u.Salt))
updatedUser |> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry updatedUser |> if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry
let! _ = ctx.Db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
if m.IsNew then if model.IsNew then
let h = CommonFunctions.htmlString let h = CommonFunctions.htmlString
{ UserMessage.info with { UserMessage.info with
Text = h s["Successfully {0} user", s["Added"].Value.ToLower ()] Text = h s["Successfully {0} user", s["Added"].Value.ToLower ()]
@ -275,14 +273,13 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun
/// GET /user/[user-id]/small-groups /// GET /user/[user-id]/small-groups
let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let userId = UserId usrId
let userId = UserId usrId
match! ctx.Db.TryUserByIdWithGroups userId with match! ctx.Db.TryUserByIdWithGroups userId with
| Some user -> | Some user ->
let! groups = ctx.Db.GroupList () let! groups = ctx.Db.GroupList ()
let curGroups = user.SmallGroups |> Seq.map (fun g -> shortGuid g.SmallGroupId.Value) |> List.ofSeq let curGroups = user.SmallGroups |> Seq.map (fun g -> shortGuid g.SmallGroupId.Value) |> List.ofSeq
return! return!
viewInfo ctx startTicks viewInfo ctx
|> Views.User.assignGroups (AssignGroups.fromUser user) groups curGroups ctx |> Views.User.assignGroups (AssignGroups.fromUser user) groups curGroups ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx