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

Version 8 #43

Merged
danieljsummers merged 37 commits from version-8 into main 2022-08-19 19:08:31 +00:00
Conversation 0 Commits 37 Files Changed 58 +314 -533
10 changed files with 314 additions and 533 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit 5e4891869f - Show all commits

45
src/PrayerTracker/App.fs
View File

@ -7,20 +7,7 @@ open Microsoft.AspNetCore.Hosting
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module Configure = module Configure =
open Cookies
open Giraffe
open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Localization
open Microsoft.AspNetCore.Server.Kestrel.Core
open Microsoft.EntityFrameworkCore
open Microsoft.Extensions.Configuration open Microsoft.Extensions.Configuration
open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Hosting
open Microsoft.Extensions.Localization
open Microsoft.Extensions.Logging
open Microsoft.Extensions.Options
open NodaTime
open System.Globalization
/// 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) =
@ -30,10 +17,21 @@ module Configure =
.AddEnvironmentVariables() .AddEnvironmentVariables()
|> ignore |> ignore
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
open System.Globalization
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Localization
open Microsoft.EntityFrameworkCore
open Microsoft.Extensions.DependencyInjection
open NodaTime
/// 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")
@ -46,6 +44,12 @@ module Configure =
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 _ =
svc.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie(fun opts ->
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 120.
opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/error/403")
let _ = svc.AddDistributedMemoryCache() let _ = svc.AddDistributedMemoryCache()
let _ = svc.AddSession() let _ = svc.AddSession()
let _ = svc.AddAntiforgery() let _ = svc.AddAntiforgery()
@ -53,18 +57,19 @@ module Configure =
let _ = svc.AddSingleton<IClock>(SystemClock.Instance) let _ = svc.AddSingleton<IClock>(SystemClock.Instance)
let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration>() let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration>()
let crypto = config.GetSection "CookieCrypto"
CookieCrypto (crypto["Key"], crypto["IV"]) |> setCrypto
let _ = svc.AddDbContext<AppDbContext>( let _ = svc.AddDbContext<AppDbContext>(
(fun options -> (fun options ->
options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore), options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
ServiceLifetime.Scoped, ServiceLifetime.Singleton) ServiceLifetime.Scoped, ServiceLifetime.Singleton)
() ()
open Giraffe
let noWeb : HttpHandler = fun next ctx -> let noWeb : HttpHandler = fun next ctx ->
redirectTo true ($"""/{string ctx.Request.RouteValues["path"]}""") next ctx redirectTo true ($"""/{string ctx.Request.RouteValues["path"]}""") next ctx
open Giraffe.EndpointRouting
/// Routes for PrayerTracker /// Routes for PrayerTracker
let routes = [ let routes = [
route "/web/{**path}" noWeb route "/web/{**path}" noWeb
@ -146,11 +151,15 @@ module Configure =
] ]
] ]
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
/// 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> ()
@ -158,6 +167,10 @@ module Configure =
|> function l -> l.AddConsole().AddDebug() |> function l -> l.AddConsole().AddDebug()
|> ignore |> ignore
open Microsoft.Extensions.Localization
open Microsoft.Extensions.Options
/// 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

26
src/PrayerTracker/Church.fs
View File

@ -16,17 +16,17 @@ let private findStats (db : AppDbContext) churchId = task {
/// POST /church/[church-id]/delete /// POST /church/[church-id]/delete
let delete chId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let delete chId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let churchId = ChurchId chId let churchId = ChurchId chId
match! ctx.db.TryChurchById churchId with match! ctx.Db.TryChurchById churchId with
| Some church -> | Some church ->
let! _, stats = findStats ctx.db churchId let! _, stats = findStats ctx.Db churchId
ctx.db.RemoveEntry church ctx.Db.RemoveEntry church
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addInfo ctx addInfo ctx
s["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)", s["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)",
church.Name, stats.SmallGroups, stats.PrayerRequests, stats.Users] church.Name, stats.SmallGroups, stats.PrayerRequests, stats.Users]
return! redirectTo false "/churches" next ctx return! redirectTo false "/churches" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }
open System open System
@ -40,21 +40,21 @@ let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> ta
|> Views.Church.edit EditChurch.empty ctx |> Views.Church.edit EditChurch.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.db.TryChurchById (ChurchId churchId) with match! ctx.Db.TryChurchById (ChurchId churchId) with
| Some church -> | Some church ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.Church.edit (EditChurch.fromChurch church) ctx |> Views.Church.edit (EditChurch.fromChurch church) ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }
/// GET /churches /// GET /churches
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let await = Async.AwaitTask >> Async.RunSynchronously let await = Async.AwaitTask >> Async.RunSynchronously
let! churches = ctx.db.AllChurches () let! churches = ctx.Db.AllChurches ()
let stats = churches |> List.map (fun c -> await (findStats ctx.db c.Id)) let stats = churches |> List.map (fun c -> await (findStats ctx.Db c.Id))
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.Church.maintain churches (stats |> Map.ofList) ctx |> Views.Church.maintain churches (stats |> Map.ofList) ctx
@ -69,16 +69,16 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
| 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 ctx.db.TryChurchById (idFromShort ChurchId model.ChurchId) else ctx.Db.TryChurchById (idFromShort ChurchId model.ChurchId)
match church with match church with
| Some ch -> | Some ch ->
model.PopulateChurch ch model.PopulateChurch ch
|> (if model.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry) |> (if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower () let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addInfo ctx s["Successfully {0} church “{1}”", act, model.Name] addInfo ctx s["Successfully {0} church “{1}”", act, model.Name]
return! redirectTo false "/churches" next ctx return! redirectTo false "/churches" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }

147
src/PrayerTracker/CommonFunctions.fs
View File

@ -41,47 +41,20 @@ let appVersion =
#endif #endif
open Microsoft.AspNetCore.Http
open PrayerTracker
/// The currently signed-in user (will raise if none exists)
let currentUser (ctx : HttpContext) =
match ctx.Session.user with Some u -> u | None -> nullArg "User"
/// The currently signed-in small group (will raise if none exists)
let currentGroup (ctx : HttpContext) =
match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup"
open System
open Giraffe open Giraffe
open Giraffe.Htmx open Giraffe.Htmx
open PrayerTracker.Cookies open Microsoft.AspNetCore.Http
open PrayerTracker
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
/// Create the common view information heading /// Create the common view information heading
let viewInfo (ctx : HttpContext) startTicks = let viewInfo (ctx : HttpContext) startTicks =
let msg = let msg =
match ctx.Session.messages with match ctx.Session.Messages with
| [] -> [] | [] -> []
| x -> | x ->
ctx.Session.messages <- [] ctx.Session.Messages <- []
x x
match ctx.Session.user with
| Some u ->
// The idle timeout is 2 hours; if the app pool is recycled or the actual session goes away, we will log the
// user back in transparently using this cookie. Every request resets the timer.
let timeout =
{ Id = u.Id.Value
GroupId = (currentGroup ctx).Id.Value
Until = DateTime.UtcNow.AddHours(2.).Ticks
Password = ""
}
ctx.Response.Cookies.Append
(Key.Cookie.timeout, { timeout with Password = saltedTimeoutHash timeout }.toPayload (),
CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime timeout.Until)),
HttpOnly = true))
| None -> ()
let layout = let layout =
match ctx.Request.Headers.HxTarget with match ctx.Request.Headers.HxTarget with
| Some hdr when hdr = "pt-body" -> ContentOnly | Some hdr when hdr = "pt-body" -> ContentOnly
@ -91,8 +64,8 @@ let viewInfo (ctx : HttpContext) startTicks =
Version = appVersion Version = appVersion
Messages = msg Messages = msg
RequestStart = startTicks RequestStart = startTicks
User = ctx.Session.user User = ctx.CurrentUser
Group = ctx.Session.smallGroup Group = ctx.CurrentGroup
Layout = layout Layout = layout
} }
@ -100,16 +73,17 @@ let viewInfo (ctx : HttpContext) startTicks =
let renderHtml next ctx view = let renderHtml next ctx view =
htmlView view next ctx htmlView view next ctx
open Microsoft.Extensions.Logging
/// Display an error regarding form submission /// Display an error regarding form submission
let bindError (msg : string) next (ctx : HttpContext) = let bindError (msg : string) =
Console.WriteLine msg handleContext (fun ctx ->
ctx.SetStatusCode 400 ctx.GetService<ILoggerFactory>().CreateLogger("PrayerTracker.Handlers").LogError msg
text msg next 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 next (ctx : HttpContext) = let fourOhFour (ctx : HttpContext) =
ctx.SetStatusCode 404 (setStatusCode 404 >=> text "Not Found") earlyReturn ctx
text "Not Found" next 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 {
@ -120,7 +94,7 @@ let validateCsrf : HttpHandler = fun next ctx -> task {
/// 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
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
@ -165,94 +139,27 @@ type AccessLevel =
open Microsoft.AspNetCore.Http.Extensions open Microsoft.AspNetCore.Http.Extensions
open PrayerTracker.Entities open PrayerTracker.Entities
/// Require the given access role (also refreshes "Remember Me" user and group logons) /// Require one of the given access roles
let requireAccess level : HttpHandler = let requireAccess levels : HttpHandler = fun next ctx -> task {
match ctx.CurrentUser, ctx.CurrentGroup with
/// Is there currently a user logged on? | _, _ when List.contains Public levels -> return! next ctx
let isUserLoggedOn (ctx : HttpContext) = | Some _, _ when List.contains User levels -> return! next ctx
ctx.Session.user |> Option.isSome | _, Some _ when List.contains Group levels -> return! next ctx
| Some u, _ when List.contains Admin levels && u.IsAdmin -> return! next ctx
/// Log a user on from the timeout cookie | _, _ when List.contains Admin levels ->
let logOnUserFromTimeoutCookie (ctx : HttpContext) = task {
// Make sure the cookie hasn't been tampered with
try
match TimeoutCookie.fromPayload ctx.Request.Cookies[Key.Cookie.timeout] with
| Some c when c.Password = saltedTimeoutHash c ->
let! user = ctx.db.TryUserById (UserId c.Id)
match user with
| Some _ ->
ctx.Session.user <- user
let! grp = ctx.db.TryGroupById (SmallGroupId c.GroupId)
ctx.Session.smallGroup <- grp
| _ -> ()
| _ -> ()
// If something above doesn't work, the user doesn't get logged in
with _ -> ()
}
/// Attempt to log the user on from their stored cookie
let logOnUserFromCookie (ctx : HttpContext) = task {
match UserCookie.fromPayload ctx.Request.Cookies[Key.Cookie.user] with
| Some c ->
let! user = ctx.db.TryUserLogOnByCookie (UserId c.Id) (SmallGroupId c.GroupId) c.PasswordHash
match user with
| Some _ ->
ctx.Session.user <- user
let! grp = ctx.db.TryGroupById (SmallGroupId c.GroupId)
ctx.Session.smallGroup <- grp
// Rewrite the cookie to extend the expiration
ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh)
| _ -> ()
| _ -> ()
}
/// Is there currently a small group (or member thereof) logged on?
let isGroupLoggedOn (ctx : HttpContext) =
ctx.Session.smallGroup |> Option.isSome
/// Attempt to log the small group on from their stored cookie
let logOnGroupFromCookie (ctx : HttpContext) = task {
match GroupCookie.fromPayload ctx.Request.Cookies[Key.Cookie.group] with
| Some c ->
let! grp = ctx.db.TryGroupLogOnByCookie (SmallGroupId c.GroupId) c.PasswordHash sha1Hash
match grp with
| Some _ ->
ctx.Session.smallGroup <- grp
// Rewrite the cookie to extend the expiration
ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh)
| None -> ()
| None -> ()
}
fun next ctx -> task {
// Auto-logon user or class, if required
if not (isUserLoggedOn ctx) then
do! logOnUserFromTimeoutCookie ctx
if not (isUserLoggedOn ctx) then
do! logOnUserFromCookie ctx
if not (isGroupLoggedOn ctx) then do! logOnGroupFromCookie ctx
match true with
| _ when level |> List.contains Public -> return! next ctx
| _ when level |> List.contains User && isUserLoggedOn ctx -> return! next ctx
| _ when level |> List.contains Group && isGroupLoggedOn ctx -> return! next ctx
| _ when level |> List.contains Admin && isUserLoggedOn ctx ->
match (currentUser ctx).IsAdmin with
| true -> return! next ctx
| false ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s["You are not authorized to view the requested page."] addError ctx s["You are not authorized to view the requested page."]
return! redirectTo false "/unauthorized" next ctx return! redirectTo false "/unauthorized" next ctx
| _ when level |> List.contains User -> | _, _ 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.GetEncodedUrl ()) ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
return! redirectTo false "/user/log-on" next ctx return! redirectTo false "/user/log-on" next ctx
| _ when level |> List.contains Group -> | _, _ when List.contains Group levels ->
// Redirect to the small group log on page // Redirect to the small group log on page
ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ()) ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
return! redirectTo false "/small-group/log-on" next ctx return! redirectTo false "/small-group/log-on" next ctx
| _ -> | _, _ ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s["You are not authorized to view the requested page."] addError ctx s["You are not authorized to view the requested page."]
return! redirectTo false "/unauthorized" next ctx return! redirectTo false "/unauthorized" next ctx
} }

143
src/PrayerTracker/Cookies.fs
View File

@ -1,143 +0,0 @@
module PrayerTracker.Cookies
open Microsoft.AspNetCore.Http
open Newtonsoft.Json
open System
open System.Security.Cryptography
open System.IO
// fsharplint:disable MemberNames
/// Cryptography settings to use for encrypting cookies
type CookieCrypto (key : string, iv : string) =
/// The key for the AES encryptor/decryptor
member _.Key = Convert.FromBase64String key
/// The initialization vector for the AES encryptor/decryptor
member _.IV = Convert.FromBase64String iv
/// Helpers for encrypting/decrypting cookies
[<AutoOpen>]
module private Crypto =
/// An instance of the cookie cryptography settings
let mutable crypto = CookieCrypto ("", "")
/// Encrypt a cookie payload
let encrypt (payload : string) =
use aes = Aes.Create ()
use enc = aes.CreateEncryptor (crypto.Key, crypto.IV)
use ms = new MemoryStream ()
use cs = new CryptoStream (ms, enc, CryptoStreamMode.Write)
use sw = new StreamWriter (cs)
sw.Write payload
sw.Close ()
(ms.ToArray >> Convert.ToBase64String) ()
/// Decrypt a cookie payload
let decrypt payload =
use aes = Aes.Create ()
use dec = aes.CreateDecryptor (crypto.Key, crypto.IV)
use ms = new MemoryStream (Convert.FromBase64String payload)
use cs = new CryptoStream (ms, dec, CryptoStreamMode.Read)
use sr = new StreamReader (cs)
sr.ReadToEnd ()
/// Encrypt a cookie
let encryptCookie cookie =
(JsonConvert.SerializeObject >> encrypt) cookie
/// Decrypt a cookie
let decryptCookie<'T> payload =
(decrypt >> JsonConvert.DeserializeObject<'T> >> box) payload
|> function null -> None | x -> Some (unbox<'T> x)
/// Accessor so that the crypto settings instance can be set during startup
let setCrypto c = Crypto.crypto <- c
/// Properties stored in the Small Group cookie
type GroupCookie =
{ /// The Id of the small group
[<JsonProperty "g">]
GroupId : Guid
/// The password hash of the small group
[<JsonProperty "p">]
PasswordHash : string
}
with
/// Convert these properties to a cookie payload
member this.toPayload () =
encryptCookie this
/// Create a set of strongly-typed properties from the cookie payload
static member fromPayload x =
try decryptCookie<GroupCookie> x with _ -> None
/// The payload for the timeout cookie
type TimeoutCookie =
{ /// The Id of the small group to which the user is currently logged in
[<JsonProperty "g">]
GroupId : Guid
/// The Id of the user who is currently logged in
[<JsonProperty "i">]
Id : Guid
/// The salted timeout hash to ensure that there has been no tampering with the cookie
[<JsonProperty "p">]
Password : string
/// How long this cookie is valid
[<JsonProperty "u">]
Until : int64
}
with
/// Convert this set of properties to the cookie payload
member this.toPayload () =
encryptCookie this
/// Create a strongly-typed timeout cookie from the cookie payload
static member fromPayload x =
try decryptCookie<TimeoutCookie> x with _ -> None
/// The payload for the user's "Remember Me" cookie
type UserCookie =
{ /// The Id of the group into to which the user is logged
[< JsonProperty "g">]
GroupId : Guid
/// The Id of the user
[<JsonProperty "i">]
Id : Guid
/// The user's password hash
[<JsonProperty "p">]
PasswordHash : string
}
with
/// Convert this set of properties to a cookie payload
member this.toPayload () =
encryptCookie this
/// Create the strongly-typed cookie properties from a cookie payload
static member fromPayload x =
try decryptCookie<UserCookie> x with _ -> None
/// Create a salted hash to use to validate the idle timeout key
let saltedTimeoutHash (c : TimeoutCookie) =
sha1Hash $"Prayer%A{c.Id}Tracker%A{c.GroupId}Idle%d{c.Until}Timeout"
/// Cookie options to push an expiration out by 100 days
let autoRefresh =
CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime.UtcNow.AddDays 100.)), HttpOnly = true)

52
src/PrayerTracker/Extensions.fs
View File

@ -2,43 +2,23 @@
module PrayerTracker.Extensions module PrayerTracker.Extensions
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open Microsoft.Extensions.DependencyInjection
open Microsoft.FSharpLu
open Newtonsoft.Json open Newtonsoft.Json
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
// fsharplint:disable MemberNames /// Extensions on the .NET session object
type ISession with type ISession with
/// Set an object in the session /// Set an object in the session
member this.SetObject key value = member this.SetObject key value =
this.SetString (key, JsonConvert.SerializeObject value) this.SetString (key, JsonConvert.SerializeObject value)
/// Get an object from the session /// Get an object from the session
member this.GetObject<'T> key = member this.GetObject<'T> key =
match this.GetString key with match this.GetString key with null -> Unchecked.defaultof<'T> | v -> JsonConvert.DeserializeObject<'T> v
| null -> Unchecked.defaultof<'T>
| v -> JsonConvert.DeserializeObject<'T> v
/// The current small group for the session
member this.smallGroup
with get () = this.GetObject<SmallGroup> Key.Session.currentGroup |> Option.fromObject
and set (v : SmallGroup option) =
match v with
| Some group -> this.SetObject Key.Session.currentGroup group
| None -> this.Remove Key.Session.currentGroup
/// The current user for the session
member this.user
with get () = this.GetObject<User> Key.Session.currentUser |> Option.fromObject
and set (v : User option) =
match v with
| Some user -> this.SetObject Key.Session.currentUser user
| None -> this.Remove Key.Session.currentUser
/// Current messages for the session /// Current messages for the session
member this.messages member this.Messages
with get () = with get () =
match box (this.GetObject<UserMessage list> Key.Session.userMessages) with match box (this.GetObject<UserMessage list> Key.Session.userMessages) with
| null -> List.empty<UserMessage> | null -> List.empty<UserMessage>
@ -46,7 +26,27 @@ type ISession with
and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v
open Giraffe
open Microsoft.FSharpLu
/// Extensions on the ASP.NET Core HTTP context
type HttpContext with type HttpContext with
/// The currently logged on small group
member this.CurrentGroup
with get () = this.Session.GetObject<SmallGroup> Key.Session.currentGroup |> Option.fromObject
and set (v : SmallGroup option) =
match v with
| Some group -> this.Session.SetObject Key.Session.currentGroup group
| None -> this.Session.Remove Key.Session.currentGroup
/// The currently logged on user
member this.CurrentUser
with get () = this.Session.GetObject<User> Key.Session.currentUser |> Option.fromObject
and set (v : User option) =
match v with
| Some user -> this.Session.SetObject Key.Session.currentUser user
| None -> this.Session.Remove Key.Session.currentUser
/// The EF Core database context (via DI) /// The EF Core database context (via DI)
member this.db member this.Db = this.GetService<AppDbContext> ()
with get () = this.RequestServices.GetRequiredService<AppDbContext> ()

15
src/PrayerTracker/Home.fs
View File

@ -13,14 +13,12 @@ let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next
|> Views.Home.error code |> Views.Home.error code
|> renderHtml next ctx |> renderHtml next ctx
/// GET / /// GET /
let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.index |> Views.Home.index
|> renderHtml next ctx |> renderHtml next ctx
/// GET /language/[culture] /// GET /language/[culture]
let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
try try
@ -44,30 +42,29 @@ let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fu
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
/// GET /legal/privacy-policy /// GET /legal/privacy-policy
let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.privacyPolicy |> Views.Home.privacyPolicy
|> renderHtml next ctx |> renderHtml next ctx
/// GET /legal/terms-of-service /// GET /legal/terms-of-service
let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.termsOfService |> Views.Home.termsOfService
|> renderHtml next ctx |> renderHtml next ctx
open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies
/// GET /log-off /// GET /log-off
let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
ctx.Session.Clear () ctx.Session.Clear ()
// Remove cookies if they exist do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
Key.Cookie.logOffCookies |> List.iter ctx.Response.Cookies.Delete
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addHtmlInfo ctx s["Log Off Successful • Have a nice day!"] addHtmlInfo ctx s["Log Off Successful • Have a nice day!"]
redirectTo false "/" next ctx return! redirectTo false "/" next ctx
}
/// GET /unauthorized /// GET /unauthorized
let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->

70
src/PrayerTracker/PrayerRequest.fs
View File

@ -8,29 +8,29 @@ open PrayerTracker.ViewModels
/// Retrieve a prayer request, and ensure that it belongs to the current class /// Retrieve a prayer request, and ensure that it belongs to the current class
let private findRequest (ctx : HttpContext) reqId = task { let private findRequest (ctx : HttpContext) reqId = task {
match! ctx.db.TryRequestById reqId with match! ctx.Db.TryRequestById reqId with
| Some req when req.SmallGroupId = (currentGroup ctx).Id -> return Ok req | Some req when req.SmallGroupId = ctx.CurrentGroup.Value.Id -> return Ok req
| Some _ -> | Some _ ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s["The prayer request you tried to access is not assigned to your group"] addError ctx s["The prayer request you tried to access is not assigned to your group"]
return Result.Error (redirectTo false "/unauthorized") return Result.Error (redirectTo false "/unauthorized" earlyReturn ctx)
| None -> return Result.Error fourOhFour | None -> return Result.Error (fourOhFour ctx)
} }
open NodaTime open NodaTime
/// Generate a list of requests for the given date /// Generate a list of requests for the given date
let private generateRequestList ctx date = task { let private generateRequestList (ctx : HttpContext) date = task {
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let clock = ctx.GetService<IClock> () let clock = ctx.GetService<IClock> ()
let listDate = match date with Some d -> d | None -> grp.LocalDateNow clock let listDate = match date with Some d -> d | None -> grp.LocalDateNow clock
let! reqs = ctx.db.AllRequestsForSmallGroup grp clock (Some listDate) true 0 let! reqs = ctx.Db.AllRequestsForSmallGroup grp clock (Some listDate) true 0
return return
{ Requests = reqs { Requests = reqs
Date = listDate Date = listDate
SmallGroup = grp SmallGroup = grp
ShowHeader = true ShowHeader = true
CanEmail = Option.isSome ctx.Session.user CanEmail = Option.isSome ctx.CurrentUser
Recipients = [] Recipients = []
} }
} }
@ -46,7 +46,7 @@ let private parseListDate (date : string option) =
/// GET /prayer-request/[request-id]/edit /// GET /prayer-request/[request-id]/edit
let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let now = grp.LocalDateNow (ctx.GetService<IClock> ()) let now = grp.LocalDateNow (ctx.GetService<IClock> ())
let requestId = PrayerRequestId reqId let requestId = PrayerRequestId reqId
if requestId.Value = Guid.Empty then if requestId.Value = Guid.Empty then
@ -71,7 +71,7 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
{ viewInfo ctx startTicks with HelpLink = Some Help.editRequest } { viewInfo ctx startTicks with HelpLink = Some Help.editRequest }
|> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx
|> renderHtml next ctx |> renderHtml next ctx
| Result.Error e -> return! e next ctx | Result.Error e -> return! e
} }
/// GET /prayer-requests/email/[date] /// GET /prayer-requests/email/[date]
@ -79,9 +79,9 @@ let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let listDate = parseListDate (Some date) let listDate = parseListDate (Some date)
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let! list = generateRequestList ctx listDate let! list = generateRequestList ctx listDate
let! recipients = ctx.db.AllMembersForSmallGroup grp.Id let! recipients = ctx.Db.AllMembersForSmallGroup grp.Id
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails client recipients do! Email.sendEmails client recipients
grp s["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.Name, list.Date].Value grp s["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.Name, list.Date].Value
@ -98,11 +98,11 @@ let delete reqId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
ctx.db.PrayerRequests.Remove req |> ignore ctx.Db.PrayerRequests.Remove req |> ignore
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["The prayer request was deleted successfully"] addInfo ctx s["The prayer request was deleted successfully"]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e next ctx | Result.Error e -> return! e
} }
/// GET /prayer-request/[request-id]/expire /// GET /prayer-request/[request-id]/expire
@ -111,20 +111,20 @@ let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with Expiration = Forced } ctx.Db.UpdateEntry { req with Expiration = Forced }
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["Successfully {0} prayer request", s["Expired"].Value.ToLower ()] addInfo ctx s["Successfully {0} prayer request", s["Expired"].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e next ctx | Result.Error e -> return! e
} }
/// GET /prayer-requests/[group-id]/list /// GET /prayer-requests/[group-id]/list
let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
match! ctx.db.TryGroupById groupId with match! ctx.Db.TryGroupById groupId with
| Some grp when grp.Preferences.IsPublic -> | Some grp when grp.Preferences.IsPublic ->
let clock = ctx.GetService<IClock> () let clock = ctx.GetService<IClock> ()
let! reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0 let! reqs = ctx.Db.AllRequestsForSmallGroup grp clock None true 0
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.PrayerRequest.list |> Views.PrayerRequest.list
@ -132,7 +132,7 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
Date = grp.LocalDateNow clock Date = grp.LocalDateNow clock
SmallGroup = grp SmallGroup = grp
ShowHeader = true ShowHeader = true
CanEmail = Option.isSome ctx.Session.user CanEmail = Option.isSome ctx.CurrentUser
Recipients = [] Recipients = []
} }
|> renderHtml next ctx |> renderHtml next ctx
@ -140,13 +140,13 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s["The request list for the group you tried to view is not public."] addError ctx s["The request list for the group you tried to view is not public."]
return! redirectTo false "/unauthorized" next ctx return! redirectTo false "/unauthorized" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }
/// GET /prayer-requests/lists /// GET /prayer-requests/lists
let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! groups = ctx.db.PublicAndProtectedGroups () let! groups = ctx.Db.PublicAndProtectedGroups ()
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.PrayerRequest.lists groups |> Views.PrayerRequest.lists groups
@ -158,7 +158,7 @@ let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
/// GET /prayer-requests?search=[search-query] /// GET /prayer-requests?search=[search-query]
let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let pageNbr = let pageNbr =
match ctx.GetQueryStringValue "page" with match ctx.GetQueryStringValue "page" with
| Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1 | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1
@ -166,7 +166,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
let! m = backgroundTask { let! m = backgroundTask {
match ctx.GetQueryStringValue "search" with match ctx.GetQueryStringValue "search" with
| Ok search -> | Ok search ->
let! reqs = ctx.db.SearchRequestsForSmallGroup grp search pageNbr let! reqs = ctx.Db.SearchRequestsForSmallGroup grp search pageNbr
return return
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
@ -174,7 +174,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
PageNbr = Some pageNbr PageNbr = Some pageNbr
} }
| Result.Error _ -> | Result.Error _ ->
let! reqs = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr let! reqs = ctx.Db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr
return return
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
@ -202,11 +202,11 @@ let restore reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> tas
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with Expiration = Automatic; UpdatedDate = DateTime.Now } ctx.Db.UpdateEntry { req with Expiration = Automatic; UpdatedDate = DateTime.Now }
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["Successfully {0} prayer request", s["Restored"].Value.ToLower ()] addInfo ctx s["Successfully {0} prayer request", s["Restored"].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e next ctx | Result.Error e -> return! e
} }
open System.Threading.Tasks open System.Threading.Tasks
@ -217,7 +217,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
| Ok m -> | Ok m ->
let! req = let! req =
if m.IsNew then Task.FromResult (Some { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () }) if m.IsNew then Task.FromResult (Some { PrayerRequest.empty with Id = (Guid.NewGuid >> PrayerRequestId) () })
else ctx.db.TryRequestById (idFromShort PrayerRequestId m.RequestId) else ctx.Db.TryRequestById (idFromShort PrayerRequestId m.RequestId)
match req with match req with
| Some pr -> | Some pr ->
let upd8 = let upd8 =
@ -227,26 +227,26 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
Text = ckEditorToText m.Text Text = ckEditorToText m.Text
Expiration = Expiration.fromCode m.Expiration Expiration = Expiration.fromCode m.Expiration
} }
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let now = grp.LocalDateNow (ctx.GetService<IClock> ()) let now = grp.LocalDateNow (ctx.GetService<IClock> ())
match m.IsNew with match m.IsNew with
| true -> | true ->
let dt = defaultArg m.EnteredDate now let dt = defaultArg m.EnteredDate now
{ upd8 with { upd8 with
SmallGroupId = grp.Id SmallGroupId = grp.Id
UserId = (currentUser ctx).Id UserId = ctx.CurrentUser.Value.Id
EnteredDate = dt EnteredDate = dt
UpdatedDate = dt UpdatedDate = dt
} }
| false when defaultArg m.SkipDateUpdate false -> upd8 | false when defaultArg m.SkipDateUpdate false -> upd8
| false -> { upd8 with UpdatedDate = now } | false -> { upd8 with UpdatedDate = now }
|> if m.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry |> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let act = if m.IsNew then "Added" else "Updated" let act = if m.IsNew then "Added" else "Updated"
addInfo ctx s["Successfully {0} prayer request", s[act].Value.ToLower ()] addInfo ctx s["Successfully {0} prayer request", s[act].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }

1
src/PrayerTracker/PrayerTracker.fsproj
View File

@ -13,7 +13,6 @@
<ItemGroup> <ItemGroup>
<None Include="appsettings.json" /> <None Include="appsettings.json" />
<Compile Include="Extensions.fs" /> <Compile Include="Extensions.fs" />
<Compile Include="Cookies.fs" />
<Compile Include="Email.fs" /> <Compile Include="Email.fs" />
<Compile Include="CommonFunctions.fs" /> <Compile Include="CommonFunctions.fs" />
<Compile Include="Church.fs" /> <Compile Include="Church.fs" />

149
src/PrayerTracker/SmallGroup.fs
View File

@ -2,59 +2,51 @@
open System open System
open Giraffe open Giraffe
open Microsoft.AspNetCore.Http
open PrayerTracker open PrayerTracker
open PrayerTracker.Cookies
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
/// Set a small group "Remember Me" cookie
let private setGroupCookie (ctx : HttpContext) pwHash =
ctx.Response.Cookies.Append
(Key.Cookie.group, { GroupId = (currentGroup ctx).Id.Value; PasswordHash = pwHash }.toPayload (),
autoRefresh)
/// GET /small-group/announcement /// GET /small-group/announcement
let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
{ viewInfo ctx DateTime.Now.Ticks with HelpLink = Some Help.sendAnnouncement } { viewInfo ctx DateTime.Now.Ticks with HelpLink = Some Help.sendAnnouncement }
|> Views.SmallGroup.announcement (currentUser ctx).IsAdmin ctx |> Views.SmallGroup.announcement ctx.CurrentUser.Value.IsAdmin ctx
|> renderHtml next ctx |> renderHtml next ctx
/// POST /small-group/[group-id]/delete /// POST /small-group/[group-id]/delete
let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let groupId = SmallGroupId grpId let groupId = SmallGroupId grpId
match! ctx.db.TryGroupById groupId with match! ctx.Db.TryGroupById groupId with
| Some grp -> | Some grp ->
let! reqs = ctx.db.CountRequestsBySmallGroup groupId let! reqs = ctx.Db.CountRequestsBySmallGroup groupId
let! users = ctx.db.CountUsersBySmallGroup groupId let! users = ctx.Db.CountUsersBySmallGroup groupId
ctx.db.RemoveEntry grp ctx.Db.RemoveEntry grp
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx addInfo ctx
s["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)", s["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)",
grp.Name, reqs, users] grp.Name, reqs, users]
return! redirectTo false "/small-groups" next ctx return! redirectTo false "/small-groups" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }
/// POST /small-group/member/[member-id]/delete /// POST /small-group/member/[member-id]/delete
let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let memberId = MemberId mbrId let memberId = MemberId mbrId
match! ctx.db.TryMemberById memberId with match! ctx.Db.TryMemberById memberId with
| Some mbr when mbr.SmallGroupId = (currentGroup ctx).Id -> | Some mbr when mbr.SmallGroupId = ctx.CurrentGroup.Value.Id ->
ctx.db.RemoveEntry mbr ctx.Db.RemoveEntry mbr
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
addHtmlInfo ctx s["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.Name] addHtmlInfo ctx s["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.Name]
return! redirectTo false "/small-group/members" next ctx return! redirectTo false "/small-group/members" next ctx
| Some _ | Some _
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }
/// GET /small-group/[group-id]/edit /// GET /small-group/[group-id]/edit
let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! churches = ctx.db.AllChurches () let! churches = ctx.Db.AllChurches ()
let groupId = SmallGroupId grpId let groupId = SmallGroupId grpId
if groupId.Value = Guid.Empty then if groupId.Value = Guid.Empty then
return! return!
@ -62,20 +54,20 @@ let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
|> Views.SmallGroup.edit EditSmallGroup.empty churches ctx |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.db.TryGroupById groupId with match! ctx.Db.TryGroupById groupId with
| Some grp -> | Some grp ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }
/// GET /small-group/member/[member-id]/edit /// GET /small-group/member/[member-id]/edit
let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s
let memberId = MemberId mbrId let memberId = MemberId mbrId
if memberId.Value = Guid.Empty then if memberId.Value = Guid.Empty then
@ -84,20 +76,20 @@ let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
|> Views.SmallGroup.editMember EditMember.empty types ctx |> Views.SmallGroup.editMember EditMember.empty types ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.db.TryMemberById memberId with match! ctx.Db.TryMemberById memberId with
| Some mbr when mbr.SmallGroupId = grp.Id -> | Some mbr when mbr.SmallGroupId = grp.Id ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.editMember (EditMember.fromMember mbr) types ctx |> Views.SmallGroup.editMember (EditMember.fromMember mbr) types ctx
|> renderHtml next ctx |> renderHtml next ctx
| Some _ | Some _
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }
/// GET /small-group/log-on/[group-id?] /// GET /small-group/log-on/[group-id?]
let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! groups = ctx.db.ProtectedGroups () let! groups = ctx.Db.ProtectedGroups ()
let groupId = match grpId with Some gid -> shortGuid gid | None -> "" let groupId = match grpId with Some gid -> shortGuid gid | None -> ""
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.logOn } { viewInfo ctx startTicks with HelpLink = Some Help.logOn }
@ -105,27 +97,37 @@ let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun nex
|> renderHtml next ctx |> renderHtml next ctx
} }
open System.Security.Claims
open Microsoft.AspNetCore.Authentication
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 m -> | Ok model ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match! ctx.db.TryGroupLogOnByPassword (idFromShort SmallGroupId m.SmallGroupId) m.Password with match! ctx.Db.TryGroupLogOnByPassword (idFromShort SmallGroupId model.SmallGroupId) model.Password with
| Some grp -> | Some group ->
ctx.Session.smallGroup <- Some grp ctx.CurrentGroup <- Some group
if defaultArg m.RememberMe false then (setGroupCookie ctx << sha1Hash) m.Password let claims = Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value) |> Seq.singleton
let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync
(identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties (
IssuedUtc = DateTimeOffset.UtcNow,
IsPersistent = defaultArg model.RememberMe false))
addInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]] addInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
return! redirectTo false "/prayer-requests/view" next ctx return! redirectTo false "/prayer-requests/view" next ctx
| None -> | None ->
addError ctx s["Password incorrect - login unsuccessful"] addError ctx s["Password incorrect - login unsuccessful"]
return! redirectTo false $"/small-group/log-on/{m.SmallGroupId}" next ctx return! redirectTo false $"/small-group/log-on/{model.SmallGroupId}" next ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// GET /small-groups /// GET /small-groups
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! groups = ctx.db.AllGroups () let! groups = ctx.Db.AllGroups ()
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.maintain groups ctx |> Views.SmallGroup.maintain groups ctx
@ -135,9 +137,9 @@ let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
/// GET /small-group/members /// GET /small-group/members
let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let! members = ctx.db.AllMembersForSmallGroup grp.Id let! members = ctx.Db.AllMembersForSmallGroup grp.Id
let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s |> Map.ofSeq let types = ReferenceList.emailTypeList grp.Preferences.DefaultEmailType s |> Map.ofSeq
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.maintainGroupMembers } { viewInfo ctx startTicks with HelpLink = Some Help.maintainGroupMembers }
@ -151,9 +153,10 @@ open NodaTime
let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let clock = ctx.GetService<IClock> () let clock = ctx.GetService<IClock> ()
let! reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 let group = ctx.CurrentGroup.Value
let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).Id let! reqs = ctx.Db.AllRequestsForSmallGroup group clock None true 0
let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).Id let! reqCount = ctx.Db.CountRequestsBySmallGroup group.Id
let! mbrCount = ctx.Db.CountMembersForSmallGroup group.Id
let m = let m =
{ TotalActiveReqs = List.length reqs { TotalActiveReqs = List.length reqs
AllReqs = reqCount AllReqs = reqCount
@ -175,10 +178,10 @@ let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
/// GET /small-group/preferences /// GET /small-group/preferences
let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! tzs = ctx.db.AllTimeZones () let! tzs = ctx.Db.AllTimeZones ()
return! return!
{ viewInfo ctx startTicks with HelpLink = Some Help.groupPreferences } { viewInfo ctx startTicks with HelpLink = Some Help.groupPreferences }
|> Views.SmallGroup.preferences (EditPreferences.fromPreferences (currentGroup ctx).Preferences) tzs ctx |> Views.SmallGroup.preferences (EditPreferences.fromPreferences ctx.CurrentGroup.Value.Preferences) tzs ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
@ -191,20 +194,20 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let! group = let! group =
if m.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () }) if m.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () })
else ctx.db.TryGroupById (idFromShort SmallGroupId m.SmallGroupId) else ctx.Db.TryGroupById (idFromShort SmallGroupId m.SmallGroupId)
match group with match group with
| Some grp -> | Some grp ->
m.populateGroup grp m.populateGroup grp
|> function |> function
| grp when m.IsNew -> | grp when m.IsNew ->
ctx.db.AddEntry grp ctx.Db.AddEntry grp
ctx.db.AddEntry { grp.Preferences with SmallGroupId = grp.Id } ctx.Db.AddEntry { grp.Preferences with SmallGroupId = grp.Id }
| grp -> ctx.db.UpdateEntry grp | grp -> ctx.Db.UpdateEntry grp
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let act = s[if m.IsNew then "Added" else "Updated"].Value.ToLower () let act = s[if m.IsNew then "Added" else "Updated"].Value.ToLower ()
addHtmlInfo ctx s["Successfully {0} group “{1}”", act, m.Name] addHtmlInfo ctx s["Successfully {0} group “{1}”", act, m.Name]
return! redirectTo false "/small-groups" next ctx return! redirectTo false "/small-groups" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
@ -212,11 +215,11 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditMember> () with match! ctx.TryBindFormAsync<EditMember> () with
| Ok model -> | Ok model ->
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let! mMbr = let! mMbr =
if model.IsNew then if model.IsNew then
Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = grp.Id }) Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = grp.Id })
else ctx.db.TryMemberById (idFromShort MemberId model.MemberId) else ctx.Db.TryMemberById (idFromShort MemberId model.MemberId)
match mMbr with match mMbr with
| Some mbr when mbr.SmallGroupId = grp.Id -> | Some mbr when mbr.SmallGroupId = grp.Id ->
{ mbr with { mbr with
@ -224,35 +227,35 @@ let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun n
Email = model.Email Email = model.Email
Format = match model.Format with "" | null -> None | _ -> Some (EmailFormat.fromCode model.Format) Format = match model.Format with "" | null -> None | _ -> Some (EmailFormat.fromCode model.Format)
} }
|> if model.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry |> if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower () let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addInfo ctx s["Successfully {0} group member", act] addInfo ctx s["Successfully {0} group member", act]
return! redirectTo false "/small-group/members" next ctx return! redirectTo false "/small-group/members" next ctx
| Some _ | Some _
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// 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 m -> | 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
// database values, not the then out-of-sync session ones. // database values, not the then out-of-sync session ones.
match! ctx.db.TryGroupById (currentGroup ctx).Id with match! ctx.Db.TryGroupById ctx.CurrentGroup.Value.Id with
| Some grp -> | Some grp ->
let prefs = m.PopulatePreferences grp.Preferences let prefs = model.PopulatePreferences grp.Preferences
ctx.db.UpdateEntry prefs ctx.Db.UpdateEntry prefs
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
// Refresh session instance // Refresh session instance
ctx.Session.smallGroup <- Some { grp with Preferences = prefs } ctx.CurrentGroup <- Some { grp with Preferences = prefs }
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addInfo ctx s["Group preferences updated successfully"] addInfo ctx s["Group preferences updated successfully"]
return! redirectTo false "/small-group/preferences" next ctx return! redirectTo false "/small-group/preferences" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
@ -263,13 +266,13 @@ open PrayerTracker.Views.CommonFunctions
let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
match! ctx.TryBindFormAsync<Announcement> () with match! ctx.TryBindFormAsync<Announcement> () with
| Ok m -> | Ok model ->
let grp = currentGroup ctx let grp = ctx.CurrentGroup.Value
let usr = currentUser ctx let usr = ctx.CurrentUser.Value
let now = grp.LocalTimeNow (ctx.GetService<IClock> ()) let now = grp.LocalTimeNow (ctx.GetService<IClock> ())
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
// Reformat the text to use the class's font stylings // Reformat the text to use the class's font stylings
let requestText = ckEditorToText m.Text let requestText = ckEditorToText model.Text
let htmlText = let htmlText =
p [ _style $"font-family:{grp.Preferences.Fonts};font-size:%d{grp.Preferences.TextFontSize}pt;" ] p [ _style $"font-family:{grp.Preferences.Fonts};font-size:%d{grp.Preferences.TextFontSize}pt;" ]
[ rawText requestText ] [ rawText requestText ]
@ -277,16 +280,16 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
let plainText = (htmlToPlainText >> wordWrap 74) htmlText let plainText = (htmlToPlainText >> wordWrap 74) htmlText
// Send the e-mails // Send the e-mails
let! recipients = let! recipients =
match m.SendToClass with match model.SendToClass with
| "N" when usr.IsAdmin -> ctx.db.AllUsersAsMembers () | "N" when usr.IsAdmin -> ctx.Db.AllUsersAsMembers ()
| _ -> ctx.db.AllMembersForSmallGroup grp.Id | _ -> ctx.Db.AllMembersForSmallGroup grp.Id
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails client recipients grp do! Email.sendEmails client recipients grp
s["Announcement for {0} - {1:MMMM d, yyyy} {2}", grp.Name, now.Date, s["Announcement for {0} - {1:MMMM d, yyyy} {2}", grp.Name, now.Date,
(now.ToString "h:mm tt").ToLower ()].Value (now.ToString "h:mm tt").ToLower ()].Value
htmlText plainText s htmlText plainText s
// Add to the request list if desired // Add to the request list if desired
match m.SendToClass, m.AddToRequestList with match model.SendToClass, model.AddToRequestList with
| "N", _ | "N", _
| _, None -> () | _, None -> ()
| _, Some x when not x -> () | _, Some x when not x -> ()
@ -295,24 +298,24 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
Id = (Guid.NewGuid >> PrayerRequestId) () Id = (Guid.NewGuid >> PrayerRequestId) ()
SmallGroupId = grp.Id SmallGroupId = grp.Id
UserId = usr.Id UserId = usr.Id
RequestType = (Option.get >> PrayerRequestType.fromCode) m.RequestType RequestType = (Option.get >> PrayerRequestType.fromCode) model.RequestType
Text = requestText Text = requestText
EnteredDate = now EnteredDate = now
UpdatedDate = now UpdatedDate = now
} }
|> ctx.db.AddEntry |> ctx.Db.AddEntry
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
() ()
// Tell 'em what they've won, Johnny! // Tell 'em what they've won, Johnny!
let toWhom = let toWhom =
match m.SendToClass with match model.SendToClass with
| "N" -> s["{0} users", s["PrayerTracker"]].Value | "N" -> s["{0} users", s["PrayerTracker"]].Value
| _ -> s["Group Members"].Value.ToLower () | _ -> s["Group Members"].Value.ToLower ()
let andAdded = match m.AddToRequestList with Some x when x -> "and added it to the request list" | _ -> "" let andAdded = match model.AddToRequestList with Some x when x -> "and added it to the request list" | _ -> ""
addInfo ctx s["Successfully sent announcement to all {0} {1}", toWhom, s[andAdded]] addInfo ctx s["Successfully sent announcement to all {0} {1}", toWhom, s[andAdded]]
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.announcementSent { m with Text = htmlText } |> Views.SmallGroup.announcementSent { model with Text = htmlText }
|> renderHtml next ctx |> renderHtml next ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }

127
src/PrayerTracker/User.fs
View File

@ -1,21 +1,12 @@
module PrayerTracker.Handlers.User module PrayerTracker.Handlers.User
open Giraffe
open Microsoft.AspNetCore.Http
open PrayerTracker
open PrayerTracker.Cookies
open PrayerTracker.Entities
open PrayerTracker.ViewModels
/// Set the user's "remember me" cookie
let private setUserCookie (ctx : HttpContext) pwHash =
ctx.Response.Cookies.Append (
Key.Cookie.user,
{ Id = (currentUser ctx).Id.Value; GroupId = (currentGroup ctx).Id.Value; PasswordHash = pwHash }.toPayload (),
autoRefresh)
open System open System
open System.Collections.Generic open System.Collections.Generic
open Giraffe
open Microsoft.AspNetCore.Http
open PrayerTracker
open PrayerTracker.Entities
open PrayerTracker.ViewModels
/// Retrieve a user from the database by password /// Retrieve a user from the database by password
// If the hashes do not match, determine if it matches a previous scheme, and upgrade them if it does // If the hashes do not match, determine if it matches a previous scheme, and upgrade them if it does
@ -25,8 +16,8 @@ let private findUserByPassword model (db : AppDbContext) = task {
// Already upgraded; match = success // Already upgraded; match = success
let pwHash = pbkdf2Hash (Option.get u.Salt) model.Password let pwHash = pbkdf2Hash (Option.get u.Salt) model.Password
if u.PasswordHash = pwHash then if u.PasswordHash = pwHash then
return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }, pwHash return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }
else return None, "" else return None
| Some u when u.PasswordHash = sha1Hash model.Password -> | Some u when u.PasswordHash = sha1Hash model.Password ->
// Not upgraded, but password is good; upgrade 'em! // Not upgraded, but password is good; upgrade 'em!
// Upgrade 'em! // Upgrade 'em!
@ -35,8 +26,8 @@ let private findUserByPassword model (db : AppDbContext) = task {
let upgraded = { u with Salt = Some salt; PasswordHash = pwHash } let upgraded = { u with Salt = Some salt; PasswordHash = pwHash }
db.UpdateEntry upgraded db.UpdateEntry upgraded
let! _ = db.SaveChangesAsync () let! _ = db.SaveChangesAsync ()
return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }, pwHash return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }
| _ -> return None, "" | _ -> return None
} }
open System.Threading.Tasks open System.Threading.Tasks
@ -44,27 +35,25 @@ open System.Threading.Tasks
/// 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 m -> | Ok model ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let curUsr = currentUser ctx let curUsr = ctx.CurrentUser.Value
let! dbUsr = ctx.db.TryUserById curUsr.Id let! dbUsr = ctx.Db.TryUserById curUsr.Id
let! user = let! user =
match dbUsr with match dbUsr with
| Some usr -> | Some usr ->
// Check the old password against a possibly non-salted hash // Check the old password against a possibly non-salted hash
(match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) m.OldPassword (match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) model.OldPassword
|> ctx.db.TryUserLogOnByCookie curUsr.Id (currentGroup ctx).Id |> ctx.Db.TryUserLogOnByCookie curUsr.Id ctx.CurrentGroup.Value.Id
| _ -> Task.FromResult None | _ -> Task.FromResult None
match user with match user with
| Some _ when m.NewPassword = m.NewPasswordConfirm -> | Some _ when model.NewPassword = model.NewPasswordConfirm ->
match dbUsr with match dbUsr with
| Some usr -> | Some usr ->
// Generate new salt whenever the password is changed // Generate new salt whenever the password is changed
let salt = Guid.NewGuid () let salt = Guid.NewGuid ()
ctx.db.UpdateEntry { usr with PasswordHash = pbkdf2Hash salt m.NewPassword; Salt = Some salt } ctx.Db.UpdateEntry { usr with PasswordHash = pbkdf2Hash salt model.NewPassword; Salt = Some salt }
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
// If the user is remembered, update the cookie with the new hash
if ctx.Request.Cookies.Keys.Contains Key.Cookie.user then setUserCookie ctx usr.PasswordHash
addInfo ctx s["Your password was changed successfully"] addInfo ctx s["Your password was changed successfully"]
| None -> addError ctx s["Unable to change password"] | None -> addError ctx s["Unable to change password"]
return! redirectTo false "/" next ctx return! redirectTo false "/" next ctx
@ -80,17 +69,20 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f
/// POST /user/[user-id]/delete /// POST /user/[user-id]/delete
let delete usrId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let delete usrId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let userId = UserId usrId let userId = UserId usrId
match! ctx.db.TryUserById userId with match! ctx.Db.TryUserById userId with
| Some user -> | Some user ->
ctx.db.RemoveEntry user ctx.Db.RemoveEntry user
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addInfo ctx s["Successfully deleted user {0}", user.Name] addInfo ctx s["Successfully deleted user {0}", user.Name]
return! redirectTo false "/users" next ctx return! redirectTo false "/users" next ctx
| _ -> return! fourOhFour next ctx | _ -> return! fourOhFour ctx
} }
open System.Net open System.Net
open System.Security.Claims
open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
/// POST /user/log-on /// POST /user/log-on
@ -98,22 +90,33 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
match! ctx.TryBindFormAsync<UserLogOn> () with match! ctx.TryBindFormAsync<UserLogOn> () with
| Ok model -> | Ok model ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let! usr, pwHash = findUserByPassword model ctx.db let! usr = findUserByPassword model ctx.Db
let! grp = ctx.db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId) match! ctx.Db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId) with
let nextUrl = | Some group ->
let! nextUrl = backgroundTask {
match usr with match usr with
| Some _ -> | Some user ->
ctx.Session.user <- usr ctx.CurrentUser <- usr
ctx.Session.smallGroup <- grp ctx.CurrentGroup <- Some group
if defaultArg model.RememberMe false then setUserCookie ctx pwHash let claims = seq {
Claim (ClaimTypes.NameIdentifier, shortGuid user.Id.Value)
Claim (ClaimTypes.GroupSid, shortGuid group.Id.Value)
Claim (ClaimTypes.Role, if user.IsAdmin then "Admin" else "User")
}
let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync
(identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties (
IssuedUtc = DateTimeOffset.UtcNow,
IsPersistent = defaultArg model.RememberMe false))
addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]] addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
return
match model.RedirectUrl with match model.RedirectUrl with
| None -> "/small-group" | None -> "/small-group"
// TODO: ensure "x" is a local URL | Some x when x = ""-> "/small-group"
| Some x when x = "" -> "/small-group" | Some x when x.IndexOf "://" < 0 -> x
| Some x -> x | _ -> "/small-group"
| _ -> | _ ->
let grpName = match grp with Some g -> g.Name | _ -> "N/A"
{ UserMessage.error with { UserMessage.error with
Text = htmlLocString s["Invalid credentials - log on unsuccessful"] Text = htmlLocString s["Invalid credentials - log on unsuccessful"]
Description = Description =
@ -124,15 +127,17 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
s["The password entered does not match the password for the given e-mail address."].Value s["The password entered does not match the password for the given e-mail address."].Value
"</li><li>" "</li><li>"
s["You are not authorized to administer the group “{0}”.", s["You are not authorized to administer the group “{0}”.",
WebUtility.HtmlEncode grpName].Value WebUtility.HtmlEncode group.Name].Value
"</li></ul>" "</li></ul>"
] ]
|> String.concat "" |> String.concat ""
|> (HtmlString >> Some) |> (HtmlString >> Some)
} }
|> addUserMessage ctx |> addUserMessage ctx
"/user/log-on" return "/user/log-on"
}
return! redirectTo false nextUrl next ctx return! redirectTo false nextUrl next ctx
| None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
@ -147,13 +152,13 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
|> Views.User.edit EditUser.empty ctx |> Views.User.edit EditUser.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! ctx.db.TryUserById userId with match! ctx.Db.TryUserById userId with
| Some user -> | Some user ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.User.edit (EditUser.fromUser user) ctx |> Views.User.edit (EditUser.fromUser user) ctx
|> renderHtml next ctx |> renderHtml next ctx
| _ -> return! fourOhFour next ctx | _ -> return! fourOhFour ctx
} }
@ -161,7 +166,7 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let! groups = ctx.db.GroupList () let! groups = ctx.Db.GroupList ()
let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
match url with match url with
| Some _ -> | Some _ ->
@ -178,7 +183,7 @@ let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
/// GET /users /// GET /users
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! users = ctx.db.AllUsers () let! users = ctx.Db.AllUsers ()
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.User.maintain users ctx |> Views.User.maintain users ctx
@ -199,7 +204,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
| Ok m -> | Ok m ->
let! user = let! user =
if m.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () }) if m.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () })
else ctx.db.TryUserById (idFromShort UserId m.UserId) else ctx.Db.TryUserById (idFromShort UserId m.UserId)
let saltedUser = let saltedUser =
match user with match user with
| Some u -> | Some u ->
@ -214,8 +219,8 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
match saltedUser with match saltedUser with
| Some u -> | Some u ->
let updatedUser = m.PopulateUser u (pbkdf2Hash (Option.get u.Salt)) let updatedUser = m.PopulateUser u (pbkdf2Hash (Option.get u.Salt))
updatedUser |> if m.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry updatedUser |> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
if m.IsNew then if m.IsNew then
let h = CommonFunctions.htmlString let h = CommonFunctions.htmlString
@ -230,7 +235,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
else else
addInfo ctx s["Successfully {0} user", s["Updated"].Value.ToLower ()] addInfo ctx s["Successfully {0} user", s["Updated"].Value.ToLower ()]
return! redirectTo false "/users" next ctx return! redirectTo false "/users" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
@ -245,7 +250,7 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun
addError ctx s["You must select at least one group to assign"] addError ctx s["You must select at least one group to assign"]
return! redirectTo false $"/user/{model.UserId}/small-groups" next ctx return! redirectTo false $"/user/{model.UserId}/small-groups" next ctx
| _ -> | _ ->
match! ctx.db.TryUserByIdWithGroups (idFromShort UserId model.UserId) with match! ctx.Db.TryUserByIdWithGroups (idFromShort UserId model.UserId) with
| Some user -> | Some user ->
let groups = let groups =
model.SmallGroups.Split ',' model.SmallGroups.Split ','
@ -253,17 +258,17 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun
|> List.ofArray |> List.ofArray
user.SmallGroups user.SmallGroups
|> Seq.filter (fun x -> not (groups |> List.exists (fun y -> y = x.SmallGroupId))) |> Seq.filter (fun x -> not (groups |> List.exists (fun y -> y = x.SmallGroupId)))
|> ctx.db.UserGroupXref.RemoveRange |> ctx.Db.UserGroupXref.RemoveRange
groups groups
|> Seq.ofList |> Seq.ofList
|> Seq.filter (fun x -> not (user.SmallGroups |> Seq.exists (fun y -> y.SmallGroupId = x))) |> Seq.filter (fun x -> not (user.SmallGroups |> Seq.exists (fun y -> y.SmallGroupId = x)))
|> Seq.map (fun x -> { UserSmallGroup.empty with UserId = user.Id; SmallGroupId = x }) |> Seq.map (fun x -> { UserSmallGroup.empty with UserId = user.Id; SmallGroupId = x })
|> List.ofSeq |> List.ofSeq
|> List.iter ctx.db.AddEntry |> List.iter ctx.Db.AddEntry
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["Successfully updated group permissions for {0}", model.UserName] addInfo ctx s["Successfully updated group permissions for {0}", model.UserName]
return! redirectTo false "/users" next ctx return! redirectTo false "/users" next ctx
| _ -> return! fourOhFour next ctx | _ -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
@ -272,13 +277,13 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun
let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let userId = UserId usrId let userId = UserId usrId
match! ctx.db.TryUserByIdWithGroups userId with match! ctx.Db.TryUserByIdWithGroups userId with
| Some user -> | Some user ->
let! groups = ctx.db.GroupList () let! groups = ctx.Db.GroupList ()
let curGroups = user.SmallGroups |> Seq.map (fun g -> shortGuid g.SmallGroupId.Value) |> List.ofSeq let curGroups = user.SmallGroups |> Seq.map (fun g -> shortGuid g.SmallGroupId.Value) |> List.ofSeq
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.User.assignGroups (AssignGroups.fromUser user) groups curGroups ctx |> Views.User.assignGroups (AssignGroups.fromUser user) groups curGroups ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour ctx
} }