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>
<PackageReference Include="Expecto" Version="9.0.4" />
<PackageReference Include="Expecto" Version="10.2.1" />
<PackageReference Include="NodaTime.Testing" Version="3.1.11" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
</ItemGroup>

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

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

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

@ -15,7 +15,7 @@
<ItemGroup>
<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="Microsoft.AspNetCore.Html.Abstractions" Version="2.2.0" />
<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
/// 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
/// Format a GUID as a short GUID
@ -19,19 +19,19 @@ let emptyGuid = shortGuid Guid.Empty
module String =
/// string.Trim()
let trim (str: string) = str.Trim ()
let trim (str: string) = str.Trim()
/// 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
let replaceFirst (needle : string) replacement (haystack : string) =
let replaceFirst (needle: string) replacement (haystack: string) =
match haystack.IndexOf needle with
| -1 -> haystack
| 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
let noneIfBlank (str : string) =
let noneIfBlank (str: string) =
match str with
| null -> None
| it when it.Trim () = "" -> None
@ -46,7 +46,7 @@ let stripTags allowedTags input =
let stripHtmlExp = Regex @"(<\/?[^>]+>)"
let mutable output = input
for tag in stripHtmlExp.Matches input do
let htmlTag = tag.Value.ToLower ()
let htmlTag = tag.Value.ToLower()
let shouldReplace =
allowedTags
|> List.fold (fun acc t ->
@ -100,7 +100,7 @@ let ckEditorToText (text : string) =
"</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

82
src/PrayerTracker/App.fs
View File

@ -3,9 +3,9 @@ namespace PrayerTracker
open Microsoft.AspNetCore.Http
/// 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
return! next.Invoke ctx
}
@ -21,7 +21,7 @@ open Microsoft.Extensions.Configuration
module Configure =
/// Set up the configuration for the app
let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) =
let configuration (ctx: WebHostBuilderContext) (cfg: IConfigurationBuilder) =
cfg.SetBasePath(ctx.HostingEnvironment.ContentRootPath)
.AddJsonFile("appsettings.json", optional = true, reloadOnChange = true)
.AddJsonFile($"appsettings.{ctx.HostingEnvironment.EnvironmentName}.json", optional = true)
@ -31,7 +31,7 @@ module Configure =
open Microsoft.AspNetCore.Server.Kestrel.Core
/// Configure Kestrel from appsettings.json
let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
let kestrel (ctx: WebHostBuilderContext) (opts: KestrelServerOptions) =
(ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
open System.Globalization
@ -46,37 +46,37 @@ module Configure =
/// Configure ASP.NET Core's service collection (dependency injection container)
let services (svc : IServiceCollection) =
let _ = svc.AddOptions ()
let _ = svc.AddLocalization (fun options -> options.ResourcesPath <- "Resources")
let _ = svc.AddOptions()
let _ = svc.AddLocalization(fun options -> options.ResourcesPath <- "Resources")
let _ =
svc.Configure<RequestLocalizationOptions> (fun (opts : RequestLocalizationOptions) ->
svc.Configure<RequestLocalizationOptions>(fun (opts: RequestLocalizationOptions) ->
let supportedCultures =[|
CultureInfo "en-US"; CultureInfo "en-GB"; CultureInfo "en-AU"; CultureInfo "en"
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.SupportedUICultures <- supportedCultures)
let _ =
svc.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie (fun opts ->
.AddCookie(fun opts ->
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 120.
opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/error/403")
let _ = svc.AddAuthorization ()
let _ = svc.AddAuthorization()
let cfg = svc.BuildServiceProvider().GetService<IConfiguration> ()
let dsb = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PrayerTracker")
let cfg = svc.BuildServiceProvider().GetService<IConfiguration>()
let dsb = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PrayerTracker")
let _ = dsb.UseNodaTime()
Configuration.useDataSource (dsb.Build ())
dsb.Build() |> Configuration.useDataSource
let emailCfg = cfg.GetSection "Email"
if (emailCfg.GetChildren >> Seq.isEmpty >> not) () then ConfigurationBinder.Bind(emailCfg, Email.smtpOptions)
let _ = svc.AddSingleton<IDistributedCache, DistributedCache> ()
let _ = svc.AddSession ()
let _ = svc.AddAntiforgery ()
let _ = svc.AddRouting ()
let _ = svc.AddSingleton<IDistributedCache, DistributedCache>()
let _ = svc.AddSession()
let _ = svc.AddAntiforgery()
let _ = svc.AddRouting()
let _ = svc.AddSingleton<IClock> SystemClock.Instance
()
@ -172,16 +172,16 @@ module Configure =
open Microsoft.Extensions.Logging
/// Giraffe error handler
let errorHandler (ex : exn) (logger : ILogger) =
logger.LogError (EventId(), ex, "An unhandled exception has occurred while executing the request.")
let errorHandler (ex: exn) (logger: ILogger) =
logger.LogError(EventId(), ex, "An unhandled exception has occurred while executing the request.")
clearResponse >=> setStatusCode 500 >=> text ex.Message
open Microsoft.Extensions.Hosting
/// Configure logging
let logging (log : ILoggingBuilder) =
let env = log.Services.BuildServiceProvider().GetService<IWebHostEnvironment> ()
if env.IsDevelopment () then log else log.AddFilter (fun l -> l > LogLevel.Information)
let logging (log: ILoggingBuilder) =
let env = log.Services.BuildServiceProvider().GetService<IWebHostEnvironment>()
if env.IsDevelopment() then log else log.AddFilter(fun l -> l > LogLevel.Information)
|> function l -> l.AddConsole().AddDebug()
|> ignore
@ -191,27 +191,27 @@ module Configure =
/// Configure the application
let app (app : IApplicationBuilder) =
let env = app.ApplicationServices.GetRequiredService<IWebHostEnvironment> ()
if env.IsDevelopment () then
app.UseDeveloperExceptionPage ()
let env = app.ApplicationServices.GetRequiredService<IWebHostEnvironment>()
if env.IsDevelopment() then
app.UseDeveloperExceptionPage()
else
app.UseGiraffeErrorHandler errorHandler
|> ignore
let _ = app.UseForwardedHeaders ()
let _ = app.UseCanonicalDomains ()
let _ = app.UseForwardedHeaders()
let _ = app.UseCanonicalDomains()
let _ = app.UseStatusCodePagesWithReExecute "/error/{0}"
let _ = app.UseStaticFiles ()
let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<RequestStartMiddleware> ()
let _ = app.UseRouting ()
let _ = app.UseSession ()
let _ = app.UseRequestLocalization
(app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value)
let _ = app.UseAuthentication ()
let _ = app.UseAuthorization ()
let _ = app.UseEndpoints (fun e -> e.MapGiraffeEndpoints routes)
Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService<IStringLocalizerFactory> ()
let _ = app.UseStaticFiles()
let _ = app.UseCookiePolicy(CookiePolicyOptions(MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<RequestStartMiddleware>()
let _ = app.UseRouting()
let _ = app.UseSession()
let _ = app.UseRequestLocalization(
app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value)
let _ = app.UseAuthentication()
let _ = app.UseAuthorization()
let _ = app.UseEndpoints(fun e -> e.MapGiraffeEndpoints routes)
app.ApplicationServices.GetRequiredService<IStringLocalizerFactory>() |> Views.I18N.setUpFactories
/// The web application
@ -221,16 +221,16 @@ module App =
[<EntryPoint>]
let main args =
let contentRoot = Directory.GetCurrentDirectory ()
let contentRoot = Directory.GetCurrentDirectory()
let app =
WebHostBuilder()
.UseContentRoot(contentRoot)
.ConfigureAppConfiguration(Configure.configuration)
.UseKestrel(Configure.kestrel)
.UseWebRoot(Path.Combine (contentRoot, "wwwroot"))
.UseWebRoot(Path.Combine(contentRoot, "wwwroot"))
.ConfigureServices(Configure.services)
.ConfigureLogging(Configure.logging)
.Configure(System.Action<IApplicationBuilder> Configure.app)
.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

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
| Ok model ->
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)
match church with
| Some 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]
return! redirectTo false "/churches" next 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
/// 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)
[ match withDefault with
| true ->
let s = PrayerTracker.Views.I18N.localizer.Force ()
SelectListItem ($"""&mdash; %A{s[emptyText]} &mdash;""", "")
| _ -> ()
yield! items |> Seq.map (fun x -> SelectListItem (textFunc x, valFunc x))
]
[ match withDefault with
| true ->
let s = PrayerTracker.Views.I18N.localizer.Force()
SelectListItem($"""&mdash; %A{s[emptyText]} &mdash;""", "")
| _ -> ()
yield! items |> Seq.map (fun x -> SelectListItem(textFunc x, valFunc x)) ]
/// 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
/// 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
/// The version of PrayerTracker
@ -49,7 +48,7 @@ open PrayerTracker
open PrayerTracker.ViewModels
/// Create the common view information heading
let viewInfo (ctx : HttpContext) =
let viewInfo (ctx: HttpContext) =
let msg =
match ctx.Session.Messages with
| [] -> []
@ -67,8 +66,7 @@ let viewInfo (ctx : HttpContext) =
RequestStart = ctx.Items[Key.startTime] :?> Instant
User = ctx.Session.CurrentUser
Group = ctx.Session.CurrentGroup
Layout = layout
}
Layout = layout }
/// The view is the last parameter, so it can be composed
let renderHtml next ctx view =
@ -77,24 +75,24 @@ let renderHtml next ctx view =
open Microsoft.Extensions.Logging
/// Display an error regarding form submission
let bindError (msg : string) =
let bindError (msg: string) =
handleContext (fun ctx ->
ctx.GetService<ILoggerFactory>().CreateLogger("PrayerTracker.Handlers").LogError msg
(setStatusCode 400 >=> text msg) earlyReturn ctx)
/// 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
/// Handler to validate CSRF prevention token
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
| false -> return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") earlyReturn ctx
}
/// Add a message to the session
let addUserMessage (ctx : HttpContext) msg =
let addUserMessage (ctx: HttpContext) msg =
ctx.Session.Messages <- msg :: ctx.Session.Messages
@ -102,10 +100,10 @@ open Microsoft.AspNetCore.Html
open Microsoft.Extensions.Localization
/// Convert a localized string to an HTML string
let htmlLocString (x : LocalizedString) =
let htmlLocString (x: LocalizedString) =
(System.Net.WebUtility.HtmlEncode >> HtmlString) x.Value
let htmlString (x : LocalizedString) =
let htmlString (x: LocalizedString) =
HtmlString x.Value
/// Add an error message to the session
@ -143,8 +141,8 @@ open PrayerTracker.Entities
/// Require one of the given access roles
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
let! user = ctx.CurrentUser ()
let! group = ctx.CurrentGroup ()
let! user = ctx.CurrentUser()
let! group = ctx.CurrentGroup()
match user, group with
| _, _ when List.contains Public 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
| _, _ when List.contains User levels ->
// 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
| _, _ when List.contains Group levels ->
// 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
type EmailOptions =
{ /// The SMTP client
Client : SmtpClient
{ /// The SMTP client
Client: SmtpClient
/// The people who should receive the e-mail
Recipients : Member list
/// The people who should receive the e-mail
Recipients: Member list
/// The small group for which this e-mail is being sent
Group : SmallGroup
/// The small group for which this e-mail is being sent
Group: SmallGroup
/// The subject of the e-mail
Subject : string
/// The subject of the e-mail
Subject: string
/// The body of the e-mail in HTML
HtmlBody : string
/// The body of the e-mail in HTML
HtmlBody: string
/// The body of the e-mail in plain text
PlainTextBody : string
/// The body of the e-mail in plain text
PlainTextBody: string
/// Use the current user's preferred language
Strings : IStringLocalizer
}
/// Use the current user's preferred language
Strings: IStringLocalizer }
/// Options to use when sending e-mail
type SmtpServerOptions() =
/// 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
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
member val UseSsl : bool = false with get, set
member val UseSsl: bool = false with get, set
/// 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
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
let smtpOptions = SmtpServerOptions ()
let smtpOptions = SmtpServerOptions()
/// Get an SMTP client connection
let getConnection () = task {
let client = new SmtpClient ()
do! client.ConnectAsync (smtpOptions.SmtpHost, smtpOptions.Port, smtpOptions.UseSsl)
do! client.AuthenticateAsync (smtpOptions.FromAddress, smtpOptions.Authentication)
let client = new SmtpClient()
do! client.ConnectAsync(smtpOptions.SmtpHost, smtpOptions.Port, smtpOptions.UseSsl)
do! client.AuthenticateAsync(smtpOptions.FromAddress, smtpOptions.Authentication)
return client
}
/// Create a mail message object, filled with everything but the body content
let createMessage opts =
let msg = new MimeMessage ()
msg.From.Add (MailboxAddress (opts.Group.Preferences.EmailFromName, smtpOptions.FromAddress))
let msg = new MimeMessage()
msg.From.Add(MailboxAddress(opts.Group.Preferences.EmailFromName, smtpOptions.FromAddress))
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
open MimeKit.Text
@ -72,31 +71,29 @@ open MimeKit.Text
/// Create an HTML-format e-mail message
let createHtmlMessage opts =
let bodyText =
[ """<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml"><head><title></title></head><body>"""
opts.HtmlBody
"""<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
"<br><small>"
opts.Strings["from Bit Badger Solutions"].Value
"</small></div></body></html>"
]
[ """<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml"><head><title></title></head><body>"""
opts.HtmlBody
"""<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
"<br><small>"
opts.Strings["from Bit Badger Solutions"].Value
"</small></div></body></html>" ]
|> String.concat ""
let msg = createMessage opts
msg.Body <- new TextPart (TextFormat.Html, Text = bodyText)
msg.Body <- new TextPart(TextFormat.Html, Text = bodyText)
msg
/// Create a plain-text-format e-mail message
let createTextMessage opts =
let bodyText =
[ opts.PlainTextBody
"\n\n--\n"
opts.Strings["Generated by P R A Y E R T R A C K E R"].Value
"\n"
opts.Strings["from Bit Badger Solutions"].Value
]
[ opts.PlainTextBody
"\n\n--\n"
opts.Strings["Generated by P R A Y E R T R A C K E R"].Value
"\n"
opts.Strings["from Bit Badger Solutions"].Value ]
|> String.concat ""
let msg = createMessage opts
msg.Body <- new TextPart (TextFormat.Plain, Text = bodyText)
msg.Body <- new TextPart(TextFormat.Plain, Text = bodyText)
msg
/// Send e-mails to a class
@ -105,14 +102,14 @@ let sendEmails opts = task {
use plainTextMsg = createTextMessage opts
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
| HtmlFormat ->
htmlMsg.To.Add emailTo
let! _ = opts.Client.SendAsync htmlMsg
htmlMsg.To.Clear ()
htmlMsg.To.Clear()
| PlainTextFormat ->
plainTextMsg.To.Add emailTo
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
/// Set an object in the session
member this.SetObject<'T> key (value : 'T) =
this.SetString (key, JsonConvert.SerializeObject (value, jsonSettings))
member this.SetObject<'T> key (value: 'T) =
this.SetString(key, JsonConvert.SerializeObject(value, jsonSettings))
/// Get an object from the session
member this.TryGetObject<'T> key =
match this.GetString key with
| null -> None
| v -> Some (JsonConvert.DeserializeObject<'T> (v, jsonSettings))
| v -> Some (JsonConvert.DeserializeObject<'T>(v, jsonSettings))
/// The currently logged on small group
member this.CurrentGroup
with get () = this.TryGetObject<SmallGroup> Key.Session.currentGroup
and set (v : SmallGroup option) =
and set (v: SmallGroup option) =
match v with
| Some group -> this.SetObject Key.Session.currentGroup group
| None -> this.Remove Key.Session.currentGroup
@ -36,7 +36,7 @@ type ISession with
/// The currently logged on user
member this.CurrentUser
with get () = this.TryGetObject<User> Key.Session.currentUser
and set (v : User option) =
and set (v: User option) =
match v with
| Some user -> this.SetObject Key.Session.currentUser { user with PasswordHash = "" }
| None -> this.Remove Key.Session.currentUser
@ -46,7 +46,7 @@ type ISession with
with get () =
this.TryGetObject<UserMessage list> Key.Session.userMessages
|> 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
@ -74,13 +74,13 @@ open Npgsql
type HttpContext with
/// The system clock (via DI)
member this.Clock = this.GetService<IClock> ()
member this.Clock = this.GetService<IClock>()
/// The current instant
member this.Now = this.Clock.GetCurrentInstant ()
member this.Now = this.Clock.GetCurrentInstant()
/// 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)
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"
| "es" -> "es-MX"
| _ -> $"{culture}-{culture.ToUpper ()}"
| _ -> $"{culture}-{culture.ToUpper()}"
|> (CultureInfo >> Option.ofObj)
with
| :? CultureNotFoundException
| :? ArgumentException -> None
|> function
| Some c ->
ctx.Response.Cookies.Append (
ctx.Response.Cookies.Append(
CookieRequestCultureProvider.DefaultCookieName,
CookieRequestCultureProvider.MakeCookieValue (RequestCulture c),
CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime.Now.AddYears 1))))
CookieRequestCultureProvider.MakeCookieValue(RequestCulture c),
CookieOptions(Expires = Nullable<DateTimeOffset>(DateTimeOffset(DateTime.Now.AddYears 1))))
| _ -> ()
let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/" | r -> r
redirectTo false url next ctx
@ -59,7 +59,7 @@ open Microsoft.AspNetCore.Authentication.Cookies
// GET /log-off
let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
ctx.Session.Clear ()
ctx.Session.Clear()
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
addHtmlInfo ctx ctx.Strings["Log Off Successful • Have a nice day!"]
return! redirectTo false "/" next ctx

96
src/PrayerTracker/PrayerRequest.fs
View File

@ -8,7 +8,7 @@ open PrayerTracker.Entities
open PrayerTracker.ViewModels
/// 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
| Some req when req.SmallGroupId = ctx.Session.CurrentGroup.Value.Id -> return Ok req
| Some _ ->
@ -18,31 +18,29 @@ let private findRequest (ctx : HttpContext) reqId = task {
}
/// 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 listDate = match date with Some d -> d | None -> SmallGroup.localDateNow ctx.Clock group
let! reqs =
PrayerRequests.forGroup
{ SmallGroup = group
Clock = ctx.Clock
ListDate = Some listDate
ActiveOnly = true
PageNumber = 0
}
{ SmallGroup = group
Clock = ctx.Clock
ListDate = Some listDate
ActiveOnly = true
PageNumber = 0 }
return
{ Requests = reqs
Date = listDate
SmallGroup = group
ShowHeader = true
CanEmail = Option.isSome ctx.User.UserId
Recipients = []
}
{ Requests = reqs
Date = listDate
SmallGroup = group
ShowHeader = true
CanEmail = Option.isSome ctx.User.UserId
Recipients = [] }
}
open NodaTime.Text
/// Parse a string into a date (optionally, of course)
let private parseListDate (date : string option) =
let private parseListDate (date: string option) =
match date with
| Some dt -> match LocalDatePattern.Iso.Parse dt with it when it.Success -> Some it.Value | _ -> None
| None -> None
@ -57,7 +55,7 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
if requestId.Value = Guid.Empty then
return!
{ 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
else
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
use! client = Email.getConnection ()
do! Email.sendEmails
{ Client = client
Recipients = recipients
Group = group
Subject = s["Prayer Requests for {0} - {1:MMMM d, yyyy}", group.Name, list.Date].Value
HtmlBody = list.AsHtml s
PlainTextBody = list.AsText s
Strings = s
}
{ Client = client
Recipients = recipients
Group = group
Subject = s["Prayer Requests for {0} - {1:MMMM d, yyyy}", group.Name, list.Date].Value
HtmlBody = list.AsHtml s
PlainTextBody = list.AsText s
Strings = s }
do! client.DisconnectAsync true
return!
viewInfo ctx
@ -122,7 +119,7 @@ let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task
match! findRequest ctx requestId with
| Ok req ->
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
| Result.Error e -> return! e
}
@ -133,22 +130,20 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
| Some group when group.Preferences.IsPublic ->
let! reqs =
PrayerRequests.forGroup
{ SmallGroup = group
Clock = ctx.Clock
ListDate = None
ActiveOnly = true
PageNumber = 0
}
{ SmallGroup = group
Clock = ctx.Clock
ListDate = None
ActiveOnly = true
PageNumber = 0 }
return!
viewInfo ctx
|> Views.PrayerRequest.list
{ Requests = reqs
Date = SmallGroup.localDateNow ctx.Clock group
SmallGroup = group
ShowHeader = true
CanEmail = Option.isSome ctx.User.UserId
Recipients = []
}
{ Requests = reqs
Date = SmallGroup.localDateNow ctx.Clock group
SmallGroup = group
ShowHeader = true
CanEmail = Option.isSome ctx.User.UserId
Recipients = [] }
|> renderHtml next ctx
| Some _ ->
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
Requests = reqs
SearchTerm = Some search
PageNbr = Some pageNbr
}
PageNbr = Some pageNbr }
| Result.Error _ ->
let! reqs =
PrayerRequests.forGroup
{ SmallGroup = group
Clock = ctx.Clock
ListDate = None
ActiveOnly = onlyActive
PageNumber = pageNbr
}
{ SmallGroup = group
Clock = ctx.Clock
ListDate = None
ActiveOnly = onlyActive
PageNumber = pageNbr }
return
{ MaintainRequests.empty with
Requests = reqs
OnlyActive = Some onlyActive
PageNbr = if onlyActive then None else Some pageNbr
}
PageNbr = if onlyActive then None else Some pageNbr }
}
return!
{ viewInfo ctx with HelpLink = Some Help.maintainRequests }
@ -229,7 +221,7 @@ open System.Threading.Tasks
// POST /prayer-request/save
let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditRequest> () with
match! ctx.TryBindFormAsync<EditRequest>() with
| Ok model ->
let group = ctx.Session.CurrentGroup.Value
let! req =
@ -247,7 +239,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
let updated =
{ pr with
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
Expiration = Expiration.fromCode model.Expiration
}
@ -262,7 +254,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
| it -> { it with UpdatedDate = ctx.Now }
do! PrayerRequests.save 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
| Some _
| None -> return! fourOhFour ctx

2
src/PrayerTracker/PrayerTracker.fsproj
View File

@ -25,7 +25,7 @@
<ItemGroup>
<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 Update="FSharp.Core" Version="8.0.300" />
</ItemGroup>

86
src/PrayerTracker/SmallGroup.fs
View File

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

61
src/PrayerTracker/User.fs
View File

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