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

v8.4 #53

Merged
danieljsummers merged 4 commits from 8point4 into main 2024-06-29 00:22:44 +00:00
Conversation 0 Commits 4 Files Changed 56 +250 -272
14 changed files with 250 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit adbbf9cf4e - Show all commits

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

@ -14,7 +14,7 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Expecto" Version="9.0.4" /> <PackageReference Include="Expecto" Version="10.2.1" />
<PackageReference Include="NodaTime.Testing" Version="3.1.11" /> <PackageReference Include="NodaTime.Testing" Version="3.1.11" />
<PackageReference Update="FSharp.Core" Version="8.0.300" /> <PackageReference Update="FSharp.Core" Version="8.0.300" />
</ItemGroup> </ItemGroup>

2
src/PrayerTracker.Tests/Program.fs
View File

@ -2,4 +2,4 @@
[<EntryPoint>] [<EntryPoint>]
let main argv = let main argv =
runTestsInAssembly defaultConfig argv runTestsInAssemblyWithCLIArgs [] argv

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

@ -15,7 +15,7 @@
<ItemGroup> <ItemGroup>
<PackageReference Include="Giraffe.ViewEngine" Version="1.4.0" /> <PackageReference Include="Giraffe.ViewEngine" Version="1.4.0" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="1.9.12" /> <PackageReference Include="Giraffe.ViewEngine.Htmx" Version="2.0.0" />
<PackageReference Include="MailKit" Version="4.6.0" /> <PackageReference Include="MailKit" Version="4.6.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" />

14
src/PrayerTracker.UI/Utils.fs
View File

@ -5,7 +5,7 @@ open System
open Giraffe open Giraffe
/// Parse a short-GUID-based ID from a string /// Parse a short-GUID-based ID from a string
let idFromShort<'T> (f : Guid -> 'T) strValue = let idFromShort<'T> (f: Guid -> 'T) strValue =
(ShortGuid.toGuid >> f) strValue (ShortGuid.toGuid >> f) strValue
/// Format a GUID as a short GUID /// Format a GUID as a short GUID
@ -19,19 +19,19 @@ let emptyGuid = shortGuid Guid.Empty
module String = module String =
/// string.Trim() /// string.Trim()
let trim (str: string) = str.Trim () let trim (str: string) = str.Trim()
/// string.Replace() /// string.Replace()
let replace (find : string) repl (str : string) = str.Replace (find, repl) let replace (find: string) repl (str: string) = str.Replace(find, repl)
/// Replace the first occurrence of a string with a second string within a given string /// Replace the first occurrence of a string with a second string within a given string
let replaceFirst (needle : string) replacement (haystack : string) = let replaceFirst (needle: string) replacement (haystack: string) =
match haystack.IndexOf needle with match haystack.IndexOf needle with
| -1 -> haystack | -1 -> haystack
| idx -> String.concat "" [ haystack[0..idx - 1]; replacement; haystack[idx + needle.Length..] ] | idx -> String.concat "" [ haystack[0..idx - 1]; replacement; haystack[idx + needle.Length..] ]
/// Convert a string to an option, with null, blank, and whitespace becoming None /// Convert a string to an option, with null, blank, and whitespace becoming None
let noneIfBlank (str : string) = let noneIfBlank (str: string) =
match str with match str with
| null -> None | null -> None
| it when it.Trim () = "" -> None | it when it.Trim () = "" -> None
@ -46,7 +46,7 @@ let stripTags allowedTags input =
let stripHtmlExp = Regex @"(<\/?[^>]+>)" let stripHtmlExp = Regex @"(<\/?[^>]+>)"
let mutable output = input let mutable output = input
for tag in stripHtmlExp.Matches input do for tag in stripHtmlExp.Matches input do
let htmlTag = tag.Value.ToLower () let htmlTag = tag.Value.ToLower()
let shouldReplace = let shouldReplace =
allowedTags allowedTags
|> List.fold (fun acc t -> |> List.fold (fun acc t ->
@ -100,7 +100,7 @@ let ckEditorToText (text : string) =
"</p>", "" "</p>", ""
"<p>", "" "<p>", ""
] ]
|> List.fold (fun (txt : string) (x, y) -> String.replace x y txt) text |> List.fold (fun (txt: string) (x, y) -> String.replace x y txt) text
|> String.trim |> String.trim

82
src/PrayerTracker/App.fs
View File

@ -3,9 +3,9 @@ namespace PrayerTracker
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
/// Middleware to add the starting ticks for the request /// Middleware to add the starting ticks for the request
type RequestStartMiddleware (next : RequestDelegate) = type RequestStartMiddleware (next: RequestDelegate) =
member this.InvokeAsync (ctx : HttpContext) = task { member this.InvokeAsync (ctx: HttpContext) = task {
ctx.Items[Key.startTime] <- ctx.Now ctx.Items[Key.startTime] <- ctx.Now
return! next.Invoke ctx return! next.Invoke ctx
} }
@ -21,7 +21,7 @@ open Microsoft.Extensions.Configuration
module Configure = module Configure =
/// Set up the configuration for the app /// Set up the configuration for the app
let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) = let configuration (ctx: WebHostBuilderContext) (cfg: IConfigurationBuilder) =
cfg.SetBasePath(ctx.HostingEnvironment.ContentRootPath) cfg.SetBasePath(ctx.HostingEnvironment.ContentRootPath)
.AddJsonFile("appsettings.json", optional = true, reloadOnChange = true) .AddJsonFile("appsettings.json", optional = true, reloadOnChange = true)
.AddJsonFile($"appsettings.{ctx.HostingEnvironment.EnvironmentName}.json", optional = true) .AddJsonFile($"appsettings.{ctx.HostingEnvironment.EnvironmentName}.json", optional = true)
@ -31,7 +31,7 @@ module Configure =
open Microsoft.AspNetCore.Server.Kestrel.Core open Microsoft.AspNetCore.Server.Kestrel.Core
/// Configure Kestrel from appsettings.json /// Configure Kestrel from appsettings.json
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.Globalization open System.Globalization
@ -46,37 +46,37 @@ module Configure =
/// Configure ASP.NET Core's service collection (dependency injection container) /// Configure ASP.NET Core's service collection (dependency injection container)
let services (svc : IServiceCollection) = let services (svc : IServiceCollection) =
let _ = svc.AddOptions () let _ = svc.AddOptions()
let _ = svc.AddLocalization (fun options -> options.ResourcesPath <- "Resources") let _ = svc.AddLocalization(fun options -> options.ResourcesPath <- "Resources")
let _ = let _ =
svc.Configure<RequestLocalizationOptions> (fun (opts : RequestLocalizationOptions) -> svc.Configure<RequestLocalizationOptions>(fun (opts: RequestLocalizationOptions) ->
let supportedCultures =[| let supportedCultures =[|
CultureInfo "en-US"; CultureInfo "en-GB"; CultureInfo "en-AU"; CultureInfo "en" CultureInfo "en-US"; CultureInfo "en-GB"; CultureInfo "en-AU"; CultureInfo "en"
CultureInfo "es-MX"; CultureInfo "es-ES"; CultureInfo "es" CultureInfo "es-MX"; CultureInfo "es-ES"; CultureInfo "es"
|] |]
opts.DefaultRequestCulture <- RequestCulture ("en-US", "en-US") opts.DefaultRequestCulture <- RequestCulture("en-US", "en-US")
opts.SupportedCultures <- supportedCultures opts.SupportedCultures <- supportedCultures
opts.SupportedUICultures <- supportedCultures) opts.SupportedUICultures <- supportedCultures)
let _ = let _ =
svc.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme) svc.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie (fun opts -> .AddCookie(fun opts ->
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 120. opts.ExpireTimeSpan <- TimeSpan.FromMinutes 120.
opts.SlidingExpiration <- true opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/error/403") opts.AccessDeniedPath <- "/error/403")
let _ = svc.AddAuthorization () let _ = svc.AddAuthorization()
let cfg = svc.BuildServiceProvider().GetService<IConfiguration> () let cfg = svc.BuildServiceProvider().GetService<IConfiguration>()
let dsb = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PrayerTracker") let dsb = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PrayerTracker")
let _ = dsb.UseNodaTime() let _ = dsb.UseNodaTime()
Configuration.useDataSource (dsb.Build ()) dsb.Build() |> Configuration.useDataSource
let emailCfg = cfg.GetSection "Email" let emailCfg = cfg.GetSection "Email"
if (emailCfg.GetChildren >> Seq.isEmpty >> not) () then ConfigurationBinder.Bind(emailCfg, Email.smtpOptions) if (emailCfg.GetChildren >> Seq.isEmpty >> not) () then ConfigurationBinder.Bind(emailCfg, Email.smtpOptions)
let _ = svc.AddSingleton<IDistributedCache, DistributedCache> () let _ = svc.AddSingleton<IDistributedCache, DistributedCache>()
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
() ()
@ -172,16 +172,16 @@ module Configure =
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
/// Giraffe error handler /// 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
open Microsoft.Extensions.Hosting open Microsoft.Extensions.Hosting
/// Configure logging /// Configure logging
let logging (log : ILoggingBuilder) = let logging (log: ILoggingBuilder) =
let env = log.Services.BuildServiceProvider().GetService<IWebHostEnvironment> () let env = log.Services.BuildServiceProvider().GetService<IWebHostEnvironment>()
if env.IsDevelopment () then log else log.AddFilter (fun l -> l > LogLevel.Information) if env.IsDevelopment() then log else log.AddFilter(fun l -> l > LogLevel.Information)
|> function l -> l.AddConsole().AddDebug() |> function l -> l.AddConsole().AddDebug()
|> ignore |> ignore
@ -191,27 +191,27 @@ module Configure =
/// Configure the application /// Configure the application
let app (app : IApplicationBuilder) = let app (app : IApplicationBuilder) =
let env = app.ApplicationServices.GetRequiredService<IWebHostEnvironment> () let env = app.ApplicationServices.GetRequiredService<IWebHostEnvironment>()
if env.IsDevelopment () then if env.IsDevelopment() then
app.UseDeveloperExceptionPage () app.UseDeveloperExceptionPage()
else else
app.UseGiraffeErrorHandler errorHandler app.UseGiraffeErrorHandler errorHandler
|> ignore |> ignore
let _ = app.UseForwardedHeaders () let _ = app.UseForwardedHeaders()
let _ = app.UseCanonicalDomains () let _ = app.UseCanonicalDomains()
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.UseCookiePolicy(CookiePolicyOptions(MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<RequestStartMiddleware> () let _ = app.UseMiddleware<RequestStartMiddleware>()
let _ = app.UseRouting () let _ = app.UseRouting()
let _ = app.UseSession () let _ = app.UseSession()
let _ = app.UseRequestLocalization let _ = app.UseRequestLocalization(
(app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value) app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value)
let _ = app.UseAuthentication () let _ = app.UseAuthentication()
let _ = app.UseAuthorization () let _ = app.UseAuthorization()
let _ = app.UseEndpoints (fun e -> e.MapGiraffeEndpoints routes) let _ = app.UseEndpoints(fun e -> e.MapGiraffeEndpoints routes)
Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService<IStringLocalizerFactory> () app.ApplicationServices.GetRequiredService<IStringLocalizerFactory>() |> Views.I18N.setUpFactories
/// The web application /// The web application
@ -221,16 +221,16 @@ module App =
[<EntryPoint>] [<EntryPoint>]
let main args = let main args =
let contentRoot = Directory.GetCurrentDirectory () let contentRoot = Directory.GetCurrentDirectory()
let app = let app =
WebHostBuilder() WebHostBuilder()
.UseContentRoot(contentRoot) .UseContentRoot(contentRoot)
.ConfigureAppConfiguration(Configure.configuration) .ConfigureAppConfiguration(Configure.configuration)
.UseKestrel(Configure.kestrel) .UseKestrel(Configure.kestrel)
.UseWebRoot(Path.Combine (contentRoot, "wwwroot")) .UseWebRoot(Path.Combine(contentRoot, "wwwroot"))
.ConfigureServices(Configure.services) .ConfigureServices(Configure.services)
.ConfigureLogging(Configure.logging) .ConfigureLogging(Configure.logging)
.Configure(System.Action<IApplicationBuilder> Configure.app) .Configure(System.Action<IApplicationBuilder> Configure.app)
.Build() .Build()
if args.Length > 0 then printfn $"Unrecognized option {args[0]}" else app.Run () if args.Length > 0 then printfn $"Unrecognized option {args[0]}" else app.Run()
0 0

4
src/PrayerTracker/Church.fs
View File

@ -63,12 +63,12 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
match! ctx.TryBindFormAsync<EditChurch> () with match! ctx.TryBindFormAsync<EditChurch> () with
| Ok model -> | Ok model ->
let! church = let! church =
if model.IsNew then Task.FromResult (Some { Church.empty with Id = (Guid.NewGuid >> ChurchId) () }) if model.IsNew then Task.FromResult(Some { Church.empty with Id = (Guid.NewGuid >> ChurchId) () })
else Churches.tryById (idFromShort ChurchId model.ChurchId) else Churches.tryById (idFromShort ChurchId model.ChurchId)
match church with match church with
| Some ch -> | Some ch ->
do! Churches.save (model.PopulateChurch ch) do! Churches.save (model.PopulateChurch ch)
let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower () let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower()
addInfo ctx ctx.Strings["Successfully {0} church “{1}”", act, model.Name] addInfo ctx ctx.Strings["Successfully {0} church “{1}”", act, model.Name]
return! redirectTo false "/churches" next ctx return! redirectTo false "/churches" next ctx
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx

42
src/PrayerTracker/CommonFunctions.fs
View File

@ -5,22 +5,21 @@ module PrayerTracker.Handlers.CommonFunctions
open Microsoft.AspNetCore.Mvc.Rendering open Microsoft.AspNetCore.Mvc.Rendering
/// Create a select list from an enumeration /// Create a select list from an enumeration
let toSelectList<'T> valFunc textFunc withDefault emptyText (items : 'T seq) = let toSelectList<'T> valFunc textFunc withDefault emptyText (items: 'T seq) =
if isNull items then nullArg (nameof items) if isNull items then nullArg (nameof items)
[ match withDefault with [ match withDefault with
| true -> | true ->
let s = PrayerTracker.Views.I18N.localizer.Force () let s = PrayerTracker.Views.I18N.localizer.Force()
SelectListItem ($"""&mdash; %A{s[emptyText]} &mdash;""", "") SelectListItem($"""&mdash; %A{s[emptyText]} &mdash;""", "")
| _ -> () | _ -> ()
yield! items |> Seq.map (fun x -> SelectListItem (textFunc x, valFunc x)) yield! items |> Seq.map (fun x -> SelectListItem(textFunc x, valFunc x)) ]
]
/// Create a select list from an enumeration /// Create a select list from an enumeration
let toSelectListWithEmpty<'T> valFunc textFunc emptyText (items : 'T seq) = let toSelectListWithEmpty<'T> valFunc textFunc emptyText (items: 'T seq) =
toSelectList valFunc textFunc true emptyText items toSelectList valFunc textFunc true emptyText items
/// Create a select list from an enumeration /// Create a select list from an enumeration
let toSelectListWithDefault<'T> valFunc textFunc (items : 'T seq) = let toSelectListWithDefault<'T> valFunc textFunc (items: 'T seq) =
toSelectList valFunc textFunc true "Select" items toSelectList valFunc textFunc true "Select" items
/// The version of PrayerTracker /// The version of PrayerTracker
@ -49,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) = let viewInfo (ctx: HttpContext) =
let msg = let msg =
match ctx.Session.Messages with match ctx.Session.Messages with
| [] -> [] | [] -> []
@ -67,8 +66,7 @@ let viewInfo (ctx : HttpContext) =
RequestStart = ctx.Items[Key.startTime] :?> Instant RequestStart = ctx.Items[Key.startTime] :?> Instant
User = ctx.Session.CurrentUser User = ctx.Session.CurrentUser
Group = ctx.Session.CurrentGroup Group = ctx.Session.CurrentGroup
Layout = layout Layout = layout }
}
/// The view is the last parameter, so it can be composed /// The view is the last parameter, so it can be composed
let renderHtml next ctx view = let renderHtml next ctx view =
@ -77,24 +75,24 @@ let renderHtml next ctx view =
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
/// Display an error regarding form submission /// Display an error regarding form submission
let bindError (msg : string) = let bindError (msg: string) =
handleContext (fun ctx -> handleContext (fun ctx ->
ctx.GetService<ILoggerFactory>().CreateLogger("PrayerTracker.Handlers").LogError msg ctx.GetService<ILoggerFactory>().CreateLogger("PrayerTracker.Handlers").LogError msg
(setStatusCode 400 >=> text msg) earlyReturn ctx) (setStatusCode 400 >=> text msg) earlyReturn ctx)
/// Handler that will return a status code 404 and the text "Not Found" /// Handler that will return a status code 404 and the text "Not Found"
let fourOhFour (ctx : HttpContext) = let fourOhFour (ctx: HttpContext) =
(setStatusCode 404 >=> text "Not Found") earlyReturn ctx (setStatusCode 404 >=> text "Not Found") earlyReturn ctx
/// Handler to validate CSRF prevention token /// Handler to validate CSRF prevention token
let validateCsrf : HttpHandler = fun next ctx -> task { let validateCsrf : HttpHandler = fun next ctx -> task {
match! (ctx.GetService<Microsoft.AspNetCore.Antiforgery.IAntiforgery> ()).IsRequestValidAsync ctx with match! ctx.GetService<Microsoft.AspNetCore.Antiforgery.IAntiforgery>().IsRequestValidAsync ctx with
| true -> return! next ctx | true -> return! next ctx
| false -> return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") earlyReturn ctx | false -> return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") earlyReturn ctx
} }
/// Add a message to the session /// Add a message to the session
let addUserMessage (ctx : HttpContext) msg = let addUserMessage (ctx: HttpContext) msg =
ctx.Session.Messages <- msg :: ctx.Session.Messages ctx.Session.Messages <- msg :: ctx.Session.Messages
@ -102,10 +100,10 @@ open Microsoft.AspNetCore.Html
open Microsoft.Extensions.Localization open Microsoft.Extensions.Localization
/// Convert a localized string to an HTML string /// Convert a localized string to an HTML string
let htmlLocString (x : LocalizedString) = let htmlLocString (x: LocalizedString) =
(System.Net.WebUtility.HtmlEncode >> HtmlString) x.Value (System.Net.WebUtility.HtmlEncode >> HtmlString) x.Value
let htmlString (x : LocalizedString) = let htmlString (x: LocalizedString) =
HtmlString x.Value HtmlString x.Value
/// Add an error message to the session /// Add an error message to the session
@ -143,8 +141,8 @@ 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 {
// These calls fill the user and group in the session, making .Value safe to use for the rest of the request // These calls fill the user and group in the session, making .Value safe to use for the rest of the request
let! user = ctx.CurrentUser () let! user = ctx.CurrentUser()
let! group = ctx.CurrentGroup () let! group = ctx.CurrentGroup()
match user, group with 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
@ -155,7 +153,7 @@ let requireAccess levels : HttpHandler = fun next ctx -> task {
return! redirectTo false "/unauthorized" next ctx return! redirectTo false "/unauthorized" next ctx
| _, _ when List.contains User levels -> | _, _ when List.contains User levels ->
// Redirect to the user log on page // Redirect to the user log on page
ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedPathAndQuery ()) ctx.Session.SetString(Key.Session.redirectUrl, ctx.Request.GetEncodedPathAndQuery())
return! redirectTo false "/user/log-on" next ctx return! redirectTo false "/user/log-on" next ctx
| _, _ when List.contains Group levels -> | _, _ when List.contains Group levels ->
// Redirect to the small group log on page // Redirect to the small group log on page

89
src/PrayerTracker/Email.fs
View File

@ -8,63 +8,62 @@ open PrayerTracker.Entities
/// Parameters required to send an e-mail /// Parameters required to send an e-mail
type EmailOptions = type EmailOptions =
{ /// The SMTP client { /// The SMTP client
Client : SmtpClient Client: SmtpClient
/// The people who should receive the e-mail /// The people who should receive the e-mail
Recipients : Member list Recipients: Member list
/// The small group for which this e-mail is being sent /// The small group for which this e-mail is being sent
Group : SmallGroup Group: SmallGroup
/// The subject of the e-mail /// The subject of the e-mail
Subject : string Subject: string
/// The body of the e-mail in HTML /// The body of the e-mail in HTML
HtmlBody : string HtmlBody: string
/// The body of the e-mail in plain text /// The body of the e-mail in plain text
PlainTextBody : string PlainTextBody: string
/// Use the current user's preferred language /// Use the current user's preferred language
Strings : IStringLocalizer Strings: IStringLocalizer }
}
/// Options to use when sending e-mail /// Options to use when sending e-mail
type SmtpServerOptions() = type SmtpServerOptions() =
/// The hostname of the SMTP server /// The hostname of the SMTP server
member val SmtpHost : string = "localhost" with get, set member val SmtpHost: string = "localhost" with get, set
/// The port over which SMTP communication should occur /// The port over which SMTP communication should occur
member val Port : int = 25 with get, set member val Port: int = 25 with get, set
/// Whether to use SSL when communicating with the SMTP server /// Whether to use SSL when communicating with the SMTP server
member val UseSsl : bool = false with get, set member val UseSsl: bool = false with get, set
/// The authentication to use with the SMTP server /// The authentication to use with the SMTP server
member val Authentication : string = "" with get, set member val Authentication: string = "" with get, set
/// The e-mail address from which messages should be sent /// The e-mail address from which messages should be sent
member val FromAddress : string = "prayer@bitbadger.solutions" with get, set member val FromAddress: string = "prayer@bitbadger.solutions" with get, set
/// The options for the SMTP server /// The options for the SMTP server
let smtpOptions = SmtpServerOptions () let smtpOptions = SmtpServerOptions()
/// Get an SMTP client connection /// Get an SMTP client connection
let getConnection () = task { let getConnection () = task {
let client = new SmtpClient () let client = new SmtpClient()
do! client.ConnectAsync (smtpOptions.SmtpHost, smtpOptions.Port, smtpOptions.UseSsl) do! client.ConnectAsync(smtpOptions.SmtpHost, smtpOptions.Port, smtpOptions.UseSsl)
do! client.AuthenticateAsync (smtpOptions.FromAddress, smtpOptions.Authentication) do! client.AuthenticateAsync(smtpOptions.FromAddress, smtpOptions.Authentication)
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 opts = let createMessage opts =
let msg = new MimeMessage () let msg = new MimeMessage()
msg.From.Add (MailboxAddress (opts.Group.Preferences.EmailFromName, smtpOptions.FromAddress)) msg.From.Add(MailboxAddress(opts.Group.Preferences.EmailFromName, smtpOptions.FromAddress))
msg.Subject <- opts.Subject msg.Subject <- opts.Subject
msg.ReplyTo.Add (MailboxAddress (opts.Group.Preferences.EmailFromName, opts.Group.Preferences.EmailFromAddress)) msg.ReplyTo.Add(MailboxAddress(opts.Group.Preferences.EmailFromName, opts.Group.Preferences.EmailFromAddress))
msg msg
open MimeKit.Text open MimeKit.Text
@ -72,31 +71,29 @@ open MimeKit.Text
/// Create an HTML-format e-mail message /// Create an HTML-format e-mail message
let createHtmlMessage opts = let createHtmlMessage opts =
let bodyText = let bodyText =
[ """<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml"><head><title></title></head><body>""" [ """<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml"><head><title></title></head><body>"""
opts.HtmlBody opts.HtmlBody
"""<hr><div style="text-align:right;font-family:Arial,Helvetica,sans-serif;font-size:8pt;padding-right:10px;">""" """<hr><div style="text-align:right;font-family:Arial,Helvetica,sans-serif;font-size:8pt;padding-right:10px;">"""
opts.Strings["Generated by P R A Y E R T R A C K E R"].Value opts.Strings["Generated by P R A Y E R T R A C K E R"].Value
"<br><small>" "<br><small>"
opts.Strings["from Bit Badger Solutions"].Value opts.Strings["from Bit Badger Solutions"].Value
"</small></div></body></html>" "</small></div></body></html>" ]
]
|> String.concat "" |> String.concat ""
let msg = createMessage opts let msg = createMessage opts
msg.Body <- new TextPart (TextFormat.Html, Text = bodyText) msg.Body <- new TextPart(TextFormat.Html, Text = bodyText)
msg msg
/// Create a plain-text-format e-mail message /// Create a plain-text-format e-mail message
let createTextMessage opts = let createTextMessage opts =
let bodyText = let bodyText =
[ opts.PlainTextBody [ opts.PlainTextBody
"\n\n--\n" "\n\n--\n"
opts.Strings["Generated by P R A Y E R T R A C K E R"].Value opts.Strings["Generated by P R A Y E R T R A C K E R"].Value
"\n" "\n"
opts.Strings["from Bit Badger Solutions"].Value opts.Strings["from Bit Badger Solutions"].Value ]
]
|> String.concat "" |> String.concat ""
let msg = createMessage opts let msg = createMessage opts
msg.Body <- new TextPart (TextFormat.Plain, Text = bodyText) msg.Body <- new TextPart(TextFormat.Plain, Text = bodyText)
msg msg
/// Send e-mails to a class /// Send e-mails to a class
@ -105,14 +102,14 @@ let sendEmails opts = task {
use plainTextMsg = createTextMessage opts use plainTextMsg = createTextMessage opts
for mbr in opts.Recipients do for mbr in opts.Recipients do
let emailTo = MailboxAddress (mbr.Name, mbr.Email) let emailTo = MailboxAddress(mbr.Name, mbr.Email)
match defaultArg mbr.Format opts.Group.Preferences.DefaultEmailType with match defaultArg mbr.Format opts.Group.Preferences.DefaultEmailType with
| HtmlFormat -> | HtmlFormat ->
htmlMsg.To.Add emailTo htmlMsg.To.Add emailTo
let! _ = opts.Client.SendAsync htmlMsg let! _ = opts.Client.SendAsync htmlMsg
htmlMsg.To.Clear () htmlMsg.To.Clear()
| PlainTextFormat -> | PlainTextFormat ->
plainTextMsg.To.Add emailTo plainTextMsg.To.Add emailTo
let! _ = opts.Client.SendAsync plainTextMsg let! _ = opts.Client.SendAsync plainTextMsg
plainTextMsg.To.Clear () plainTextMsg.To.Clear()
} }

18
src/PrayerTracker/Extensions.fs
View File

@ -16,19 +16,19 @@ let private jsonSettings = JsonSerializerSettings().ConfigureForNodaTime DateTim
type ISession with type ISession with
/// Set an object in the session /// Set an object in the session
member this.SetObject<'T> key (value : 'T) = member this.SetObject<'T> key (value: 'T) =
this.SetString (key, JsonConvert.SerializeObject (value, jsonSettings)) this.SetString(key, JsonConvert.SerializeObject(value, jsonSettings))
/// Get an object from the session /// Get an object from the session
member this.TryGetObject<'T> key = member this.TryGetObject<'T> key =
match this.GetString key with match this.GetString key with
| null -> None | null -> None
| v -> Some (JsonConvert.DeserializeObject<'T> (v, jsonSettings)) | v -> Some (JsonConvert.DeserializeObject<'T>(v, jsonSettings))
/// The currently logged on small group /// The currently logged on small group
member this.CurrentGroup member this.CurrentGroup
with get () = this.TryGetObject<SmallGroup> Key.Session.currentGroup with get () = this.TryGetObject<SmallGroup> Key.Session.currentGroup
and set (v : SmallGroup option) = and set (v: SmallGroup option) =
match v with match v with
| Some group -> this.SetObject Key.Session.currentGroup group | Some group -> this.SetObject Key.Session.currentGroup group
| None -> this.Remove Key.Session.currentGroup | None -> this.Remove Key.Session.currentGroup
@ -36,7 +36,7 @@ type ISession with
/// The currently logged on user /// The currently logged on user
member this.CurrentUser member this.CurrentUser
with get () = this.TryGetObject<User> Key.Session.currentUser with get () = this.TryGetObject<User> Key.Session.currentUser
and set (v : User option) = and set (v: User option) =
match v with match v with
| Some user -> this.SetObject Key.Session.currentUser { user with PasswordHash = "" } | Some user -> this.SetObject Key.Session.currentUser { user with PasswordHash = "" }
| None -> this.Remove Key.Session.currentUser | None -> this.Remove Key.Session.currentUser
@ -46,7 +46,7 @@ type ISession with
with get () = with get () =
this.TryGetObject<UserMessage list> Key.Session.userMessages this.TryGetObject<UserMessage list> Key.Session.userMessages
|> Option.defaultValue List.empty<UserMessage> |> Option.defaultValue List.empty<UserMessage>
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 open System.Security.Claims
@ -74,13 +74,13 @@ open Npgsql
type HttpContext with type HttpContext with
/// The system clock (via DI) /// The system clock (via DI)
member this.Clock = this.GetService<IClock> () member this.Clock = this.GetService<IClock>()
/// The current instant /// The current instant
member this.Now = this.Clock.GetCurrentInstant () member this.Now = this.Clock.GetCurrentInstant()
/// The common string localizer /// The common string localizer
member _.Strings = Views.I18N.localizer.Force () member _.Strings = Views.I18N.localizer.Force()
/// The currently logged on small group (sets the value in the session if it is missing) /// The currently logged on small group (sets the value in the session if it is missing)
member this.CurrentGroup () = task { member this.CurrentGroup () = task {

10
src/PrayerTracker/Home.fs
View File

@ -27,17 +27,17 @@ let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fu
| "" | ""
| "en" -> "en-US" | "en" -> "en-US"
| "es" -> "es-MX" | "es" -> "es-MX"
| _ -> $"{culture}-{culture.ToUpper ()}" | _ -> $"{culture}-{culture.ToUpper()}"
|> (CultureInfo >> Option.ofObj) |> (CultureInfo >> Option.ofObj)
with with
| :? CultureNotFoundException | :? CultureNotFoundException
| :? ArgumentException -> None | :? ArgumentException -> None
|> function |> function
| Some c -> | Some c ->
ctx.Response.Cookies.Append ( ctx.Response.Cookies.Append(
CookieRequestCultureProvider.DefaultCookieName, CookieRequestCultureProvider.DefaultCookieName,
CookieRequestCultureProvider.MakeCookieValue (RequestCulture c), CookieRequestCultureProvider.MakeCookieValue(RequestCulture c),
CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime.Now.AddYears 1)))) CookieOptions(Expires = Nullable<DateTimeOffset>(DateTimeOffset(DateTime.Now.AddYears 1))))
| _ -> () | _ -> ()
let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/" | r -> r let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/" | r -> r
redirectTo false url next ctx redirectTo false url next ctx
@ -59,7 +59,7 @@ open Microsoft.AspNetCore.Authentication.Cookies
// GET /log-off // GET /log-off
let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
ctx.Session.Clear () ctx.Session.Clear()
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
addHtmlInfo ctx ctx.Strings["Log Off Successful • Have a nice day!"] addHtmlInfo ctx ctx.Strings["Log Off Successful • Have a nice day!"]
return! redirectTo false "/" next ctx return! redirectTo false "/" next ctx

96
src/PrayerTracker/PrayerRequest.fs
View File

@ -8,7 +8,7 @@ open PrayerTracker.Entities
open PrayerTracker.ViewModels 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! PrayerRequests.tryById reqId with match! PrayerRequests.tryById reqId with
| Some req when req.SmallGroupId = ctx.Session.CurrentGroup.Value.Id -> return Ok req | Some req when req.SmallGroupId = ctx.Session.CurrentGroup.Value.Id -> return Ok req
| Some _ -> | Some _ ->
@ -18,31 +18,29 @@ let private findRequest (ctx : HttpContext) reqId = task {
} }
/// 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 group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let listDate = match date with Some d -> d | None -> SmallGroup.localDateNow ctx.Clock group let listDate = match date with Some d -> d | None -> SmallGroup.localDateNow ctx.Clock group
let! reqs = let! reqs =
PrayerRequests.forGroup PrayerRequests.forGroup
{ SmallGroup = group { SmallGroup = group
Clock = ctx.Clock Clock = ctx.Clock
ListDate = Some listDate ListDate = Some listDate
ActiveOnly = true ActiveOnly = true
PageNumber = 0 PageNumber = 0 }
}
return return
{ Requests = reqs { Requests = reqs
Date = listDate Date = listDate
SmallGroup = group SmallGroup = group
ShowHeader = true ShowHeader = true
CanEmail = Option.isSome ctx.User.UserId CanEmail = Option.isSome ctx.User.UserId
Recipients = [] Recipients = [] }
}
} }
open NodaTime.Text open NodaTime.Text
/// Parse a string into a date (optionally, of course) /// Parse a string into a date (optionally, of course)
let private parseListDate (date : string option) = let private parseListDate (date: string option) =
match date with match date with
| Some dt -> match LocalDatePattern.Iso.Parse dt with it when it.Success -> Some it.Value | _ -> None | Some dt -> match LocalDatePattern.Iso.Parse dt with it when it.Success -> Some it.Value | _ -> None
| None -> None | None -> None
@ -57,7 +55,7 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
if requestId.Value = Guid.Empty then if requestId.Value = Guid.Empty then
return! return!
{ viewInfo ctx with HelpLink = Some Help.editRequest } { viewInfo ctx with HelpLink = Some Help.editRequest }
|> Views.PrayerRequest.edit EditRequest.empty (now.ToString ("R", null)) ctx |> Views.PrayerRequest.edit EditRequest.empty (now.ToString("R", null)) ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! findRequest ctx requestId with match! findRequest ctx requestId with
@ -90,14 +88,13 @@ let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let! recipients = Members.forGroup group.Id let! recipients = Members.forGroup group.Id
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails do! Email.sendEmails
{ Client = client { Client = client
Recipients = recipients Recipients = recipients
Group = group Group = group
Subject = s["Prayer Requests for {0} - {1:MMMM d, yyyy}", group.Name, list.Date].Value Subject = s["Prayer Requests for {0} - {1:MMMM d, yyyy}", group.Name, list.Date].Value
HtmlBody = list.AsHtml s HtmlBody = list.AsHtml s
PlainTextBody = list.AsText s PlainTextBody = list.AsText s
Strings = s Strings = s }
}
do! client.DisconnectAsync true do! client.DisconnectAsync true
return! return!
viewInfo ctx viewInfo ctx
@ -122,7 +119,7 @@ let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
do! PrayerRequests.updateExpiration { req with Expiration = Forced } false do! PrayerRequests.updateExpiration { req with Expiration = Forced } false
addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings["Expired"].Value.ToLower ()] addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings["Expired"].Value.ToLower()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e | Result.Error e -> return! e
} }
@ -133,22 +130,20 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
| Some group when group.Preferences.IsPublic -> | Some group when group.Preferences.IsPublic ->
let! reqs = let! reqs =
PrayerRequests.forGroup PrayerRequests.forGroup
{ SmallGroup = group { SmallGroup = group
Clock = ctx.Clock Clock = ctx.Clock
ListDate = None ListDate = None
ActiveOnly = true ActiveOnly = true
PageNumber = 0 PageNumber = 0 }
}
return! return!
viewInfo ctx viewInfo ctx
|> Views.PrayerRequest.list |> Views.PrayerRequest.list
{ Requests = reqs { Requests = reqs
Date = SmallGroup.localDateNow ctx.Clock group Date = SmallGroup.localDateNow ctx.Clock group
SmallGroup = group SmallGroup = group
ShowHeader = true ShowHeader = true
CanEmail = Option.isSome ctx.User.UserId CanEmail = Option.isSome ctx.User.UserId
Recipients = [] Recipients = [] }
}
|> renderHtml next ctx |> renderHtml next ctx
| Some _ -> | Some _ ->
addError ctx ctx.Strings["The request list for the group you tried to view is not public."] addError ctx ctx.Strings["The request list for the group you tried to view is not public."]
@ -182,23 +177,20 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
SearchTerm = Some search SearchTerm = Some search
PageNbr = Some pageNbr PageNbr = Some pageNbr }
}
| Result.Error _ -> | Result.Error _ ->
let! reqs = let! reqs =
PrayerRequests.forGroup PrayerRequests.forGroup
{ SmallGroup = group { SmallGroup = group
Clock = ctx.Clock Clock = ctx.Clock
ListDate = None ListDate = None
ActiveOnly = onlyActive ActiveOnly = onlyActive
PageNumber = pageNbr PageNumber = pageNbr }
}
return return
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
OnlyActive = Some onlyActive OnlyActive = Some onlyActive
PageNbr = if onlyActive then None else Some pageNbr PageNbr = if onlyActive then None else Some pageNbr }
}
} }
return! return!
{ viewInfo ctx with HelpLink = Some Help.maintainRequests } { viewInfo ctx with HelpLink = Some Help.maintainRequests }
@ -229,7 +221,7 @@ 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 model -> | Ok model ->
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let! req = let! req =
@ -247,7 +239,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
let updated = let updated =
{ pr with { pr with
RequestType = PrayerRequestType.fromCode model.RequestType RequestType = PrayerRequestType.fromCode model.RequestType
Requestor = match model.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 model.Text Text = ckEditorToText model.Text
Expiration = Expiration.fromCode model.Expiration Expiration = Expiration.fromCode model.Expiration
} }
@ -262,7 +254,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
| it -> { it with UpdatedDate = ctx.Now } | it -> { it with UpdatedDate = ctx.Now }
do! PrayerRequests.save updated do! PrayerRequests.save updated
let act = if model.IsNew then "Added" else "Updated" let act = if model.IsNew then "Added" else "Updated"
addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings[act].Value.ToLower ()] addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings[act].Value.ToLower()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Some _ | Some _
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx

2
src/PrayerTracker/PrayerTracker.fsproj
View File

@ -25,7 +25,7 @@
<ItemGroup> <ItemGroup>
<PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.0.0" /> <PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.0.0" />
<PackageReference Include="Giraffe.Htmx" Version="1.9.12" /> <PackageReference Include="Giraffe.Htmx" Version="2.0.0" />
<PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.1.0" /> <PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.1.0" />
<PackageReference Update="FSharp.Core" Version="8.0.300" /> <PackageReference Update="FSharp.Core" Version="8.0.300" />
</ItemGroup> </ItemGroup>

86
src/PrayerTracker/SmallGroup.fs
View File

@ -97,17 +97,17 @@ open Microsoft.AspNetCore.Authentication.Cookies
// POST /small-group/log-on/submit // POST /small-group/log-on/submit
let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task { let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<GroupLogOn> () with match! ctx.TryBindFormAsync<GroupLogOn>() with
| Ok model -> | Ok model ->
match! SmallGroups.logOn (idFromShort SmallGroupId model.SmallGroupId) model.Password with match! SmallGroups.logOn (idFromShort SmallGroupId model.SmallGroupId) model.Password with
| Some group -> | Some group ->
ctx.Session.CurrentGroup <- Some group ctx.Session.CurrentGroup <- Some group
let identity = ClaimsIdentity ( let identity = ClaimsIdentity(
Seq.singleton (Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value)), Seq.singleton (Claim(ClaimTypes.GroupSid, shortGuid group.Id.Value)),
CookieAuthenticationDefaults.AuthenticationScheme) CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync ( do! ctx.SignInAsync(
identity.AuthenticationType, ClaimsPrincipal identity, identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties ( AuthenticationProperties(
IssuedUtc = DateTimeOffset.UtcNow, IssuedUtc = DateTimeOffset.UtcNow,
IsPersistent = defaultArg model.RememberMe false)) IsPersistent = defaultArg model.RememberMe false))
addInfo ctx ctx.Strings["Log On Successful • Welcome to {0}", ctx.Strings["PrayerTracker"]] addInfo ctx ctx.Strings["Log On Successful • Welcome to {0}", ctx.Strings["PrayerTracker"]]
@ -142,29 +142,26 @@ let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let! reqs = PrayerRequests.forGroup let! reqs = PrayerRequests.forGroup
{ SmallGroup = group { SmallGroup = group
Clock = ctx.Clock Clock = ctx.Clock
ListDate = None ListDate = None
ActiveOnly = true ActiveOnly = true
PageNumber = 0 PageNumber = 0 }
}
let! reqCount = PrayerRequests.countByGroup group.Id let! reqCount = PrayerRequests.countByGroup group.Id
let! mbrCount = Members.countByGroup group.Id let! mbrCount = Members.countByGroup group.Id
let! admins = Users.listByGroupId group.Id let! admins = Users.listByGroupId group.Id
let model = let model =
{ TotalActiveReqs = List.length reqs { TotalActiveReqs = List.length reqs
AllReqs = reqCount AllReqs = reqCount
TotalMembers = mbrCount TotalMembers = mbrCount
ActiveReqsByType = ( ActiveReqsByType = (
reqs reqs
|> Seq.ofList |> Seq.ofList
|> Seq.map (fun req -> req.RequestType) |> Seq.map (fun req -> req.RequestType)
|> Seq.distinct |> Seq.distinct
|> Seq.map (fun reqType -> |> Seq.map (fun reqType -> reqType, reqs |> List.filter (fun r -> r.RequestType = reqType) |> List.length)
reqType, reqs |> List.filter (fun r -> r.RequestType = reqType) |> List.length) |> Map.ofSeq)
|> Map.ofSeq) Admins = admins }
Admins = admins
}
return! return!
viewInfo ctx viewInfo ctx
|> Views.SmallGroup.overview model |> Views.SmallGroup.overview model
@ -183,15 +180,15 @@ 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 model -> | Ok model ->
let! tryGroup = let! tryGroup =
if model.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 SmallGroups.tryById (idFromShort SmallGroupId model.SmallGroupId) else SmallGroups.tryById (idFromShort SmallGroupId model.SmallGroupId)
match tryGroup with match tryGroup with
| Some group -> | Some group ->
do! SmallGroups.save (model.populateGroup group) model.IsNew do! SmallGroups.save (model.populateGroup group) model.IsNew
let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower () let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower()
addHtmlInfo ctx ctx.Strings["Successfully {0} group “{1}”", act, model.Name] addHtmlInfo ctx ctx.Strings["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
@ -200,12 +197,12 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
// POST /small-group/member/save // POST /small-group/member/save
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 group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let! tryMbr = let! tryMbr =
if model.IsNew then if model.IsNew then
Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = group.Id }) Task.FromResult(Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = group.Id })
else Members.tryById (idFromShort MemberId model.MemberId) else Members.tryById (idFromShort MemberId model.MemberId)
match tryMbr with match tryMbr with
| Some mbr when mbr.SmallGroupId = group.Id -> | Some mbr when mbr.SmallGroupId = group.Id ->
@ -213,9 +210,8 @@ let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun n
{ mbr with { mbr with
Name = model.Name Name = model.Name
Email = model.Email Email = model.Email
Format = String.noneIfBlank model.Format |> Option.map EmailFormat.fromCode Format = String.noneIfBlank model.Format |> Option.map EmailFormat.fromCode }
} let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower()
let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addInfo ctx ctx.Strings["Successfully {0} group member", act] addInfo ctx ctx.Strings["Successfully {0} group member", act]
return! redirectTo false "/small-group/members" next ctx return! redirectTo false "/small-group/members" next ctx
| Some _ | Some _
@ -225,7 +221,7 @@ let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun n
// POST /small-group/preferences/save // POST /small-group/preferences/save
let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditPreferences> () with match! ctx.TryBindFormAsync<EditPreferences>() with
| Ok model -> | Ok model ->
// 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
@ -249,7 +245,7 @@ open Microsoft.Extensions.Configuration
// 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 {
match! ctx.TryBindFormAsync<Announcement> () with match! ctx.TryBindFormAsync<Announcement>() with
| Ok model -> | Ok model ->
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let pref = group.Preferences let pref = group.Preferences
@ -271,15 +267,14 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
} }
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails do! Email.sendEmails
{ Client = client { Client = client
Recipients = recipients Recipients = recipients
Group = group Group = group
Subject = s["Announcement for {0} - {1:MMMM d, yyyy} {2}", group.Name, now.Date, Subject = s["Announcement for {0} - {1:MMMM d, yyyy} {2}", group.Name, now.Date,
(now.ToString ("h:mm tt", null)).ToLower ()].Value now.ToString("h:mm tt", null).ToLower()].Value
HtmlBody = htmlText HtmlBody = htmlText
PlainTextBody = plainText PlainTextBody = plainText
Strings = s Strings = s }
}
do! client.DisconnectAsync true do! client.DisconnectAsync true
// Add to the request list if desired // Add to the request list if desired
match model.SendToClass, model.AddToRequestList with match model.SendToClass, model.AddToRequestList with
@ -296,12 +291,11 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
RequestType = (Option.get >> PrayerRequestType.fromCode) model.RequestType RequestType = (Option.get >> PrayerRequestType.fromCode) model.RequestType
Text = requestText Text = requestText
EnteredDate = now.Date.AtStartOfDayInZone(zone).ToInstant() EnteredDate = now.Date.AtStartOfDayInZone(zone).ToInstant()
UpdatedDate = now.InZoneLeniently(zone).ToInstant() UpdatedDate = now.InZoneLeniently(zone).ToInstant() }
}
// Tell 'em what they've won, Johnny! // Tell 'em what they've won, Johnny!
let toWhom = let toWhom =
if model.SendToClass = "N" then s["{0} users", s["PrayerTracker"]].Value if model.SendToClass = "N" then s["{0} users", s["PrayerTracker"]].Value
else s["Group Members"].Value.ToLower () else s["Group Members"].Value.ToLower()
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!

61
src/PrayerTracker/User.fs
View File

@ -19,10 +19,10 @@ module Hashing =
open System.Text open System.Text
/// Custom password hasher used to verify and upgrade old password hashes /// Custom password hasher used to verify and upgrade old password hashes
type PrayerTrackerPasswordHasher () = type PrayerTrackerPasswordHasher() =
inherit PasswordHasher<User> () inherit PasswordHasher<User>()
override this.VerifyHashedPassword (user, hashedPassword, providedPassword) = override this.VerifyHashedPassword(user, hashedPassword, providedPassword) =
if isNull hashedPassword then nullArg (nameof hashedPassword) if isNull hashedPassword then nullArg (nameof hashedPassword)
if isNull providedPassword then nullArg (nameof providedPassword) if isNull providedPassword then nullArg (nameof providedPassword)
@ -43,7 +43,7 @@ module Hashing =
| 254uy -> | 254uy ->
// v1 hashes - SHA-1 // v1 hashes - SHA-1
let v1Hash = let v1Hash =
use alg = SHA1.Create () use alg = SHA1.Create()
alg.ComputeHash (Encoding.ASCII.GetBytes providedPassword) alg.ComputeHash (Encoding.ASCII.GetBytes providedPassword)
|> Seq.map (fun byt -> byt.ToString "x2") |> Seq.map (fun byt -> byt.ToString "x2")
|> String.concat "" |> String.concat ""
@ -51,18 +51,18 @@ module Hashing =
PasswordVerificationResult.SuccessRehashNeeded PasswordVerificationResult.SuccessRehashNeeded
else else
PasswordVerificationResult.Failed PasswordVerificationResult.Failed
| _ -> base.VerifyHashedPassword (user, hashedPassword, providedPassword) | _ -> base.VerifyHashedPassword(user, hashedPassword, providedPassword)
/// Retrieve a user from the database by password, upgrading password hashes if required /// Retrieve a user from the database by password, upgrading password hashes if required
let private findUserByPassword model = task { let private findUserByPassword model = task {
match! Users.tryByEmailAndGroup model.Email (idFromShort SmallGroupId model.SmallGroupId) with match! Users.tryByEmailAndGroup model.Email (idFromShort SmallGroupId model.SmallGroupId) with
| Some user -> | Some user ->
let hasher = PrayerTrackerPasswordHasher () let hasher = PrayerTrackerPasswordHasher()
match hasher.VerifyHashedPassword (user, user.PasswordHash, model.Password) with match hasher.VerifyHashedPassword(user, user.PasswordHash, model.Password) with
| PasswordVerificationResult.Success -> return Some user | PasswordVerificationResult.Success -> return Some user
| PasswordVerificationResult.SuccessRehashNeeded -> | PasswordVerificationResult.SuccessRehashNeeded ->
let upgraded = { user with PasswordHash = hasher.HashPassword (user, model.Password) } let upgraded = { user with PasswordHash = hasher.HashPassword(user, model.Password) }
do! Users.updatePassword upgraded do! Users.updatePassword upgraded
return Some upgraded return Some upgraded
| _ -> return None | _ -> return None
@ -78,14 +78,14 @@ let sanitizeUrl providedUrl defaultUrl =
// POST /user/password/change // POST /user/password/change
let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<ChangePassword> () with match! ctx.TryBindFormAsync<ChangePassword>() with
| Ok model -> | Ok model ->
let curUsr = ctx.Session.CurrentUser.Value let curUsr = ctx.Session.CurrentUser.Value
let hasher = PrayerTrackerPasswordHasher () let hasher = PrayerTrackerPasswordHasher()
let! user = task { let! user = task {
match! Users.tryById curUsr.Id with match! Users.tryById curUsr.Id with
| Some usr -> | Some usr ->
if hasher.VerifyHashedPassword (usr, usr.PasswordHash, model.OldPassword) if hasher.VerifyHashedPassword(usr, usr.PasswordHash, model.OldPassword)
= PasswordVerificationResult.Success then = PasswordVerificationResult.Success then
return Some usr return Some usr
else return None else return None
@ -93,7 +93,7 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f
} }
match user with match user with
| Some usr when model.NewPassword = model.NewPasswordConfirm -> | Some usr when model.NewPassword = model.NewPasswordConfirm ->
do! Users.updatePassword { usr with PasswordHash = hasher.HashPassword (usr, model.NewPassword) } do! Users.updatePassword { usr with PasswordHash = hasher.HashPassword(usr, model.NewPassword) }
addInfo ctx ctx.Strings["Your password was changed successfully"] addInfo ctx ctx.Strings["Your password was changed successfully"]
return! redirectTo false "/" next ctx return! redirectTo false "/" next ctx
| Some _ -> | Some _ ->
@ -124,7 +124,7 @@ open Microsoft.AspNetCore.Html
// POST /user/log-on // POST /user/log-on
let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task { let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<UserLogOn> () with match! ctx.TryBindFormAsync<UserLogOn>() with
| Ok model -> | Ok model ->
let s = ctx.Strings let s = ctx.Strings
match! findUserByPassword model with match! findUserByPassword model with
@ -133,14 +133,14 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
| Some group -> | Some group ->
ctx.Session.CurrentUser <- Some user ctx.Session.CurrentUser <- Some user
ctx.Session.CurrentGroup <- Some group ctx.Session.CurrentGroup <- Some group
let identity = ClaimsIdentity ( let identity = ClaimsIdentity(
seq { 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)
}, CookieAuthenticationDefaults.AuthenticationScheme) }, CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync ( do! ctx.SignInAsync(
identity.AuthenticationType, ClaimsPrincipal identity, identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties ( AuthenticationProperties(
IssuedUtc = DateTimeOffset.UtcNow, IssuedUtc = DateTimeOffset.UtcNow,
IsPersistent = defaultArg model.RememberMe false)) IsPersistent = defaultArg model.RememberMe false))
do! Users.updateLastSeen user.Id ctx.Now do! Users.updateLastSeen user.Id ctx.Now
@ -152,14 +152,12 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
Text = htmlLocString s["Invalid credentials - log on unsuccessful"] Text = htmlLocString s["Invalid credentials - log on unsuccessful"]
Description = Description =
let detail = let detail =
[ "This is likely due to one of the following reasons:<ul>" [ "This is likely due to one of the following reasons:<ul>"
"<li>The e-mail address “{0}” is invalid.</li>" "<li>The e-mail address “{0}” is invalid.</li>"
"<li>The password entered does not match the password for the given e-mail address.</li>" "<li>The password entered does not match the password for the given e-mail address.</li>"
"<li>You are not authorized to administer the selected group.</li></ul>" "<li>You are not authorized to administer the selected group.</li></ul>" ]
]
|> String.concat "" |> String.concat ""
Some (HtmlString (s[detail, WebUtility.HtmlEncode model.Email].Value)) Some (HtmlString(s[detail, WebUtility.HtmlEncode model.Email].Value)) }
}
|> addUserMessage ctx |> addUserMessage ctx
return! redirectTo false "/user/log-on" next ctx return! redirectTo false "/user/log-on" next ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
@ -217,15 +215,15 @@ open System.Threading.Tasks
// 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 model -> | Ok model ->
let! user = let! user =
if model.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 Users.tryById (idFromShort UserId model.UserId) else Users.tryById (idFromShort UserId model.UserId)
match user with match user with
| Some usr -> | Some usr ->
let hasher = PrayerTrackerPasswordHasher () let hasher = PrayerTrackerPasswordHasher()
let updatedUser = model.PopulateUser usr (fun pw -> hasher.HashPassword (usr, pw)) let updatedUser = model.PopulateUser usr (fun pw -> hasher.HashPassword(usr, pw))
do! Users.save updatedUser do! Users.save updatedUser
let s = ctx.Strings let s = ctx.Strings
if model.IsNew then if model.IsNew then
@ -235,8 +233,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
Description = Description =
h s["Please select at least one group for which this user ({0}) is authorized", h s["Please select at least one group for which this user ({0}) is authorized",
updatedUser.Name] updatedUser.Name]
|> Some |> Some }
}
|> addUserMessage ctx |> addUserMessage ctx
return! redirectTo false $"/user/{shortGuid usr.Id.Value}/small-groups" next ctx return! redirectTo false $"/user/{shortGuid usr.Id.Value}/small-groups" next ctx
else else
@ -248,7 +245,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
// POST /user/small-groups/save // POST /user/small-groups/save
let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<AssignGroups> () with match! ctx.TryBindFormAsync<AssignGroups>() with
| Ok model -> | Ok model ->
match Seq.length model.SmallGroups with match Seq.length model.SmallGroups with
| 0 -> | 0 ->