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

.NET 6 (#32)

Browse Source 
- Convert back-end to .NET 6
- Upgrade Giraffe, convert routing to endpoint style
- Refactor code to take advantage of F# advances
This commit is contained in:
Daniel J. Summers 2021-09-18 22:42:40 -04:00 committed by GitHub
parent 665d80261d
commit 1a07c673c7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
26 changed files with 722 additions and 791 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Directory.Build.props
View File

@ -1,9 +1,9 @@
<Project> <Project>
<PropertyGroup> <PropertyGroup>
<AssemblyVersion>7.5.0.0</AssemblyVersion> <AssemblyVersion>7.6.0.0</AssemblyVersion>
<FileVersion>7.5.0.0</FileVersion> <FileVersion>7.6.0.0</FileVersion>
<Authors>danieljsummers</Authors> <Authors>danieljsummers</Authors>
<Company>Bit Badger Solutions</Company> <Company>Bit Badger Solutions</Company>
<Version>7.5.0</Version> <Version>7.6.0</Version>
</PropertyGroup> </PropertyGroup>
</Project> </Project>

1
src/PrayerTracker.Data/DataAccess.fs
View File

@ -1,7 +1,6 @@
[<AutoOpen>] [<AutoOpen>]
module PrayerTracker.DataAccess module PrayerTracker.DataAccess
open FSharp.Control.Tasks.ContextInsensitive
open Microsoft.EntityFrameworkCore open Microsoft.EntityFrameworkCore
open PrayerTracker.Entities open PrayerTracker.Entities
open System.Collections.Generic open System.Collections.Generic

2
src/PrayerTracker.Data/Entities.fs
View File

@ -6,6 +6,8 @@ open NodaTime
open System open System
open System.Collections.Generic open System.Collections.Generic
// fsharplint:disable RecordFieldNames MemberNames
(*-- SUPPORT TYPES --*) (*-- SUPPORT TYPES --*)
/// How as-of dates should (or should not) be displayed with requests /// How as-of dates should (or should not) be displayed with requests

1
src/PrayerTracker.Data/Migrations/20161217153124_InitialDatabase.fs
View File

@ -10,6 +10,7 @@ open PrayerTracker
open PrayerTracker.Entities open PrayerTracker.Entities
open System open System
// fsharplint:disable RecordFieldNames
type ChurchTable = type ChurchTable =
{ churchId : OperationBuilder<AddColumnOperation> { churchId : OperationBuilder<AddColumnOperation>

9
src/PrayerTracker.Data/PrayerTracker.Data.fsproj
View File

@ -1,7 +1,7 @@
<Project Sdk="Microsoft.NET.Sdk"> <Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup> <PropertyGroup>
<TargetFramework>net5.0</TargetFramework> <TargetFramework>net6.0</TargetFramework>
</PropertyGroup> </PropertyGroup>
<ItemGroup> <ItemGroup>
@ -14,10 +14,9 @@
<ItemGroup> <ItemGroup>
<PackageReference Include="FSharp.EFCore.OptionConverter" Version="1.0.0" /> <PackageReference Include="FSharp.EFCore.OptionConverter" Version="1.0.0" />
<PackageReference Include="Microsoft.FSharpLu" Version="0.11.6" /> <PackageReference Include="Microsoft.FSharpLu" Version="0.11.7" />
<PackageReference Include="NodaTime" Version="2.4.7" /> <PackageReference Include="NodaTime" Version="3.0.5" />
<PackageReference Include="Npgsql.EntityFrameworkCore.PostgreSQL" Version="3.1.2" /> <PackageReference Include="Npgsql.EntityFrameworkCore.PostgreSQL" Version="5.0.10" />
<PackageReference Include="TaskBuilder.fs" Version="2.1.0" />
</ItemGroup> </ItemGroup>
</Project> </Project>

6
src/PrayerTracker.Tests/PrayerTracker.Tests.fsproj
View File

@ -2,7 +2,7 @@
<PropertyGroup> <PropertyGroup>
<OutputType>Exe</OutputType> <OutputType>Exe</OutputType>
<TargetFramework>net5.0</TargetFramework> <TargetFramework>net6.0</TargetFramework>
</PropertyGroup> </PropertyGroup>
<ItemGroup> <ItemGroup>
@ -15,9 +15,9 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Expecto" Version="8.13.1" /> <PackageReference Include="Expecto" Version="9.0.4" />
<PackageReference Include="Expecto.VisualStudio.TestAdapter" Version="10.0.2" /> <PackageReference Include="Expecto.VisualStudio.TestAdapter" Version="10.0.2" />
<PackageReference Include="NodaTime.Testing" Version="2.4.7" /> <PackageReference Include="NodaTime.Testing" Version="3.0.5" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>

2
src/PrayerTracker.Tests/UI/CommonFunctionsTests.fs
View File

@ -1,7 +1,7 @@
module PrayerTracker.UI.CommonFunctionsTests module PrayerTracker.UI.CommonFunctionsTests
open Expecto open Expecto
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open Microsoft.AspNetCore.Mvc.Localization open Microsoft.AspNetCore.Mvc.Localization
open Microsoft.Extensions.Localization open Microsoft.Extensions.Localization
open PrayerTracker.Tests.TestLocalization open PrayerTracker.Tests.TestLocalization

2
src/PrayerTracker.UI/Church.fs
View File

@ -1,6 +1,6 @@
module PrayerTracker.Views.Church module PrayerTracker.Views.Church
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels

10
src/PrayerTracker.UI/CommonFunctions.fs
View File

@ -2,8 +2,9 @@
module PrayerTracker.Views.CommonFunctions module PrayerTracker.Views.CommonFunctions
open Giraffe open Giraffe
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Antiforgery
open Microsoft.AspNetCore.Html
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Mvc.Localization open Microsoft.AspNetCore.Mvc.Localization
open Microsoft.Extensions.Localization open Microsoft.Extensions.Localization
@ -125,6 +126,13 @@ let _onsubmit = attr "onsubmit"
let _scoped = flag "scoped" let _scoped = flag "scoped"
/// The name this function used to have when the view engine was part of Giraffe
let renderHtmlNode = RenderView.AsString.htmlNode
/// Render an HTML node, then return the value as an HTML string
let renderHtmlString = renderHtmlNode >> HtmlString
/// Utility methods to help with time zones (and localization of their names) /// Utility methods to help with time zones (and localization of their names)
module TimeZones = module TimeZones =

4
src/PrayerTracker.UI/Home.fs
View File

@ -1,7 +1,7 @@
/// Views associated with the home page, or those that don't fit anywhere else /// Views associated with the home page, or those that don't fit anywhere else
module PrayerTracker.Views.Home module PrayerTracker.Views.Home
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open System.IO open System.IO
@ -204,7 +204,7 @@ let termsOfService vi =
let raw = rawLocText sw let raw = rawLocText sw
let ppLink = let ppLink =
a [ _href "/web/legal/privacy-policy" ] [ str (s.["Privacy Policy"].Value.ToLower ()) ] a [ _href "/web/legal/privacy-policy" ] [ str (s.["Privacy Policy"].Value.ToLower ()) ]
|> (renderHtmlNode >> HtmlString) |> renderHtmlString
[ p [ _class "pt-right-text" ] [ small [] [ em [] [ raw l.["(as of May 24, 2018)"] ] ] ] [ p [ _class "pt-right-text" ] [ small [] [ em [] [ raw l.["(as of May 24, 2018)"] ] ] ]
h3 [] [ str "1. "; raw l.["Acceptance of Terms"] ] h3 [] [ str "1. "; raw l.["Acceptance of Terms"] ]

2
src/PrayerTracker.UI/Layout.fs
View File

@ -1,7 +1,7 @@
/// Layout items for PrayerTracker /// Layout items for PrayerTracker
module PrayerTracker.Views.Layout module PrayerTracker.Views.Layout
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open PrayerTracker open PrayerTracker
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open System open System

2
src/PrayerTracker.UI/PrayerRequest.fs
View File

@ -1,7 +1,7 @@
module PrayerTracker.Views.PrayerRequest module PrayerTracker.Views.PrayerRequest
open Giraffe open Giraffe
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open NodaTime open NodaTime
open PrayerTracker open PrayerTracker

9
src/PrayerTracker.UI/PrayerTracker.UI.fsproj
View File

@ -1,7 +1,7 @@
<Project Sdk="Microsoft.NET.Sdk"> <Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup> <PropertyGroup>
<TargetFramework>net5.0</TargetFramework> <TargetFramework>net6.0</TargetFramework>
</PropertyGroup> </PropertyGroup>
<ItemGroup> <ItemGroup>
@ -18,13 +18,14 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Giraffe" Version="4.0.1" /> <PackageReference Include="Giraffe" Version="5.0.0" />
<PackageReference Include="MailKit" Version="2.5.1" /> <PackageReference Include="Giraffe.ViewEngine" Version="1.4.0" />
<PackageReference Include="MailKit" Version="2.15.0" />
<PackageReference Include="Microsoft.AspNetCore.Html.Abstractions" Version="2.2.0" /> <PackageReference Include="Microsoft.AspNetCore.Html.Abstractions" Version="2.2.0" />
<PackageReference Include="Microsoft.AspNetCore.Http" Version="2.2.2" /> <PackageReference Include="Microsoft.AspNetCore.Http" Version="2.2.2" />
<PackageReference Include="Microsoft.AspNetCore.Http.Extensions" Version="2.2.0" /> <PackageReference Include="Microsoft.AspNetCore.Http.Extensions" Version="2.2.0" />
<PackageReference Include="Microsoft.AspNetCore.Mvc" Version="2.2.0" /> <PackageReference Include="Microsoft.AspNetCore.Mvc" Version="2.2.0" />
<PackageReference Include="Newtonsoft.Json" Version="12.0.3" /> <PackageReference Include="Newtonsoft.Json" Version="13.0.1" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>

2
src/PrayerTracker.UI/SmallGroup.fs
View File

@ -1,6 +1,6 @@
module PrayerTracker.Views.SmallGroup module PrayerTracker.Views.SmallGroup
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open Microsoft.Extensions.Localization open Microsoft.Extensions.Localization
open PrayerTracker open PrayerTracker
open PrayerTracker.Entities open PrayerTracker.Entities

2
src/PrayerTracker.UI/User.fs
View File

@ -1,6 +1,6 @@
module PrayerTracker.Views.User module PrayerTracker.Views.User
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels

4
src/PrayerTracker.UI/ViewModels.fs
View File

@ -557,7 +557,7 @@ module UserLogOn =
} }
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
/// This represents a list of requests /// This represents a list of requests
type RequestList = type RequestList =
@ -651,7 +651,7 @@ with
|> ul [] |> ul []
br [] br []
] ]
|> renderHtmlNodes |> RenderView.AsString.htmlNodes
/// Generate this list as plain text /// Generate this list as plain text
member this.asText (s : IStringLocalizer) = member this.asText (s : IStringLocalizer) =

22
src/PrayerTracker/App.fs
View File

@ -9,7 +9,7 @@ module Configure =
open Cookies open Cookies
open Giraffe open Giraffe
open Giraffe.TokenRouter open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Localization open Microsoft.AspNetCore.Localization
open Microsoft.AspNetCore.Server.Kestrel.Core open Microsoft.AspNetCore.Server.Kestrel.Core
open Microsoft.EntityFrameworkCore open Microsoft.EntityFrameworkCore
@ -49,22 +49,22 @@ module Configure =
.AddDistributedMemoryCache() .AddDistributedMemoryCache()
.AddSession() .AddSession()
.AddAntiforgery() .AddAntiforgery()
.AddRouting()
.AddSingleton<IClock>(SystemClock.Instance) .AddSingleton<IClock>(SystemClock.Instance)
|> ignore |> ignore
let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration>() let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration>()
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
let webApp = let routes =
router Handlers.CommonFunctions.fourOhFour [ [ subRoute "/web" [
// Traditional web app routes GET_HEAD [
subRoute"/web" [
GET [
subRoute "/church" [ subRoute "/church" [
route "es" Handlers.Church.maintain route "es" Handlers.Church.maintain
routef "/%O/edit" Handlers.Church.edit routef "/%O/edit" Handlers.Church.edit
@ -144,7 +144,8 @@ module Configure =
// Temp redirect to new URLs // Temp redirect to new URLs
route "/" (redirectTo false "/web/") route "/" (redirectTo false "/web/")
] ]
/// Giraffe error handler
let errorHandler (ex : exn) (logger : ILogger) = let errorHandler (ex : exn) (logger : ILogger) =
logger.LogError(EventId(), ex, "An unhandled exception has occurred while executing the request.") logger.LogError(EventId(), ex, "An unhandled exception has occurred while executing the request.")
clearResponse >=> setStatusCode 500 >=> text ex.Message clearResponse >=> setStatusCode 500 >=> text ex.Message
@ -171,9 +172,10 @@ module Configure =
app.UseGiraffeErrorHandler errorHandler) app.UseGiraffeErrorHandler errorHandler)
.UseStatusCodePagesWithReExecute("/error/{0}") .UseStatusCodePagesWithReExecute("/error/{0}")
.UseStaticFiles() .UseStaticFiles()
.UseRouting()
.UseSession() .UseSession()
.UseRequestLocalization(app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value) .UseRequestLocalization(app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value)
.UseGiraffe(webApp) .UseEndpoints (fun e -> e.MapGiraffeEndpoints routes)
|> ignore |> ignore
Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService<IStringLocalizerFactory> () Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService<IStringLocalizerFactory> ()

138
src/PrayerTracker/Church.fs
View File

@ -1,6 +1,5 @@
module PrayerTracker.Handlers.Church module PrayerTracker.Handlers.Church
open FSharp.Control.Tasks.V2.ContextInsensitive
open Giraffe open Giraffe
open PrayerTracker open PrayerTracker
open PrayerTracker.Entities open PrayerTracker.Entities
@ -10,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
}

185
src/PrayerTracker/CommonFunctions.fs
View File

@ -2,7 +2,6 @@
[<AutoOpen>] [<AutoOpen>]
module PrayerTracker.Handlers.CommonFunctions module PrayerTracker.Handlers.CommonFunctions
open FSharp.Control.Tasks.V2.ContextInsensitive
open Giraffe open Giraffe
open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Antiforgery
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
@ -54,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.
@ -96,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
@ -118,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) =
@ -174,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 {
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
} }

5
src/PrayerTracker/Cookies.fs
View File

@ -6,6 +6,7 @@ open System
open System.Security.Cryptography open System.Security.Cryptography
open System.IO open System.IO
// fsharplint:disable MemberNames
/// Cryptography settings to use for encrypting cookies /// Cryptography settings to use for encrypting cookies
type CookieCrypto (key : string, iv : string) = type CookieCrypto (key : string, iv : string) =
@ -24,7 +25,7 @@ module private Crypto =
/// Encrypt a cookie payload /// Encrypt a cookie payload
let encrypt (payload : string) = let encrypt (payload : string) =
use aes = new AesManaged () use aes = Aes.Create ()
use enc = aes.CreateEncryptor (crypto.Key, crypto.IV) use enc = aes.CreateEncryptor (crypto.Key, crypto.IV)
use ms = new MemoryStream () use ms = new MemoryStream ()
use cs = new CryptoStream (ms, enc, CryptoStreamMode.Write) use cs = new CryptoStream (ms, enc, CryptoStreamMode.Write)
@ -35,7 +36,7 @@ module private Crypto =
/// Decrypt a cookie payload /// Decrypt a cookie payload
let decrypt payload = let decrypt payload =
use aes = new AesManaged () use aes = Aes.Create ()
use dec = aes.CreateDecryptor (crypto.Key, crypto.IV) use dec = aes.CreateDecryptor (crypto.Key, crypto.IV)
use ms = new MemoryStream (Convert.FromBase64String payload) use ms = new MemoryStream (Convert.FromBase64String payload)
use cs = new CryptoStream (ms, dec, CryptoStreamMode.Read) use cs = new CryptoStream (ms, dec, CryptoStreamMode.Read)

45
src/PrayerTracker/Email.fs
View File

@ -1,7 +1,6 @@
/// Methods for sending e-mails /// Methods for sending e-mails
module PrayerTracker.Email module PrayerTracker.Email
open FSharp.Control.Tasks.ContextInsensitive
open MailKit.Net.Smtp open MailKit.Net.Smtp
open MailKit.Security open MailKit.Security
open Microsoft.Extensions.Localization open Microsoft.Extensions.Localization
@ -14,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 =
@ -60,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 ()
} }

46
src/PrayerTracker/Extensions.fs
View File

@ -2,11 +2,13 @@
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
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
// fsharplint:disable MemberNames
type ISession with type ISession with
/// Set an object in the session /// Set an object in the session
@ -19,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> ()

386
src/PrayerTracker/PrayerRequest.fs
View File

@ -1,6 +1,5 @@
module PrayerTracker.Handlers.PrayerRequest module PrayerTracker.Handlers.PrayerRequest
open FSharp.Control.Tasks.V2.ContextInsensitive
open Giraffe open Giraffe
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open NodaTime open NodaTime
@ -11,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 =
@ -30,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 = []
} }
@ -49,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?]
@ -191,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?]
@ -300,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
}

7
src/PrayerTracker/PrayerTracker.fsproj
View File

@ -1,7 +1,7 @@
<Project Sdk="Microsoft.NET.Sdk.Web"> <Project Sdk="Microsoft.NET.Sdk.Web">
<PropertyGroup> <PropertyGroup>
<TargetFramework>net5.0</TargetFramework> <TargetFramework>net6.0</TargetFramework>
</PropertyGroup> </PropertyGroup>
<ItemGroup> <ItemGroup>
@ -23,10 +23,9 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Giraffe" Version="4.0.1" /> <PackageReference Include="Giraffe" Version="5.0.0" />
<PackageReference Include="Giraffe.TokenRouter" Version="1.0.0" />
<PackageReference Include="Microsoft.VisualStudio.Web.CodeGeneration.Design" Version="3.1.1" /> <PackageReference Include="Microsoft.VisualStudio.Web.CodeGeneration.Design" Version="3.1.1" />
<PackageReference Include="Npgsql.EntityFrameworkCore.PostgreSQL" Version="3.1.2" /> <PackageReference Include="Npgsql.EntityFrameworkCore.PostgreSQL" Version="5.0.10" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>

154
src/PrayerTracker/SmallGroup.fs
View File

@ -1,8 +1,7 @@
module PrayerTracker.Handlers.SmallGroup module PrayerTracker.Handlers.SmallGroup
open FSharp.Control.Tasks.V2.ContextInsensitive
open Giraffe open Giraffe
open Giraffe.GiraffeViewEngine open Giraffe.ViewEngine
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open NodaTime open NodaTime
open PrayerTracker open PrayerTracker
@ -33,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
@ -100,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
@ -112,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
@ -129,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
@ -147,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
| _ -> () | _ -> ()
@ -168,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
@ -181,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 }
@ -199,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
@ -230,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
@ -247,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
@ -278,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 ->
@ -288,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
@ -296,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]
@ -316,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
@ -346,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
@ -359,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}",
@ -381,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 =

461
src/PrayerTracker/User.fs
View File

@ -1,6 +1,5 @@
module PrayerTracker.Handlers.User module PrayerTracker.Handlers.User
open FSharp.Control.Tasks.V2.ContextInsensitive
open Giraffe open Giraffe
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
@ -23,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
@ -225,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
}