bit-badger/PrayerTracker
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases 16 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

47
src/PrayerTracker/App.fs
View File

@ -7,20 +7,7 @@ open Microsoft.AspNetCore.Hosting
[<RequireQualifiedAccess>]
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.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
let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) =
@ -30,10 +17,21 @@ module Configure =
.AddEnvironmentVariables()
|> ignore
open Microsoft.AspNetCore.Server.Kestrel.Core
/// Configure Kestrel from appsettings.json
let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
(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 _ = svc.AddOptions()
let _ = svc.AddLocalization(fun options -> options.ResourcesPath <- "Resources")
@ -46,6 +44,12 @@ module Configure =
opts.DefaultRequestCulture <- RequestCulture ("en-US", "en-US")
opts.SupportedCultures <- 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.AddSession()
let _ = svc.AddAntiforgery()
@ -53,18 +57,19 @@ module Configure =
let _ = svc.AddSingleton<IClock>(SystemClock.Instance)
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 ->
options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
ServiceLifetime.Scoped, ServiceLifetime.Singleton)
()
open Giraffe
let noWeb : HttpHandler = fun next ctx ->
redirectTo true ($"""/{string ctx.Request.RouteValues["path"]}""") next ctx
open Giraffe.EndpointRouting
/// Routes for PrayerTracker
let routes = [
route "/web/{**path}" noWeb
@ -146,11 +151,15 @@ 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.")
clearResponse >=> setStatusCode 500 >=> text ex.Message
open Microsoft.Extensions.Hosting
/// Configure logging
let logging (log : ILoggingBuilder) =
let env = log.Services.BuildServiceProvider().GetService<IWebHostEnvironment> ()
@ -158,6 +167,10 @@ module Configure =
|> function l -> l.AddConsole().AddDebug()
|> ignore
open Microsoft.Extensions.Localization
open Microsoft.Extensions.Options
/// Configure the application
let app (app : IApplicationBuilder) =
let env = app.ApplicationServices.GetRequiredService<IWebHostEnvironment>()
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
let delete chId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let churchId = ChurchId chId
match! ctx.db.TryChurchById churchId with
match! ctx.Db.TryChurchById churchId with
| Some church ->
let! _, stats = findStats ctx.db churchId
ctx.db.RemoveEntry church
let! _ = ctx.db.SaveChangesAsync ()
let! _, stats = findStats ctx.Db churchId
ctx.Db.RemoveEntry church
let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
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)",
church.Name, stats.SmallGroups, stats.PrayerRequests, stats.Users]
return! redirectTo false "/churches" next ctx
| None -> return! fourOhFour next ctx
| None -> return! fourOhFour ctx
}
open System
@ -40,21 +40,21 @@ let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> ta
|> Views.Church.edit EditChurch.empty ctx
|> renderHtml next ctx
else
match! ctx.db.TryChurchById (ChurchId churchId) with
match! ctx.Db.TryChurchById (ChurchId churchId) with
| Some church ->
return!
viewInfo ctx startTicks
|> Views.Church.edit (EditChurch.fromChurch church) ctx
|> renderHtml next ctx
| None -> return! fourOhFour next ctx
| None -> return! fourOhFour ctx
}
/// GET /churches
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let await = Async.AwaitTask >> Async.RunSynchronously
let! churches = ctx.db.AllChurches ()
let stats = churches |> List.map (fun c -> await (findStats ctx.db c.Id))
let! churches = ctx.Db.AllChurches ()
let stats = churches |> List.map (fun c -> await (findStats ctx.Db c.Id))
return!
viewInfo ctx startTicks
|> Views.Church.maintain churches (stats |> Map.ofList) ctx
@ -69,16 +69,16 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
| Ok model ->
let! church =
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
| Some ch ->
model.PopulateChurch ch
|> (if model.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync ()
|> (if model.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry)
let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
let act = s[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addInfo ctx s["Successfully {0} church “{1}”", act, model.Name]
return! redirectTo false "/churches" next ctx
| None -> return! fourOhFour next ctx
| None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx
}

171
src/PrayerTracker/CommonFunctions.fs
View File

@ -41,47 +41,20 @@ let appVersion =
#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.Htmx
open PrayerTracker.Cookies
open Microsoft.AspNetCore.Http
open PrayerTracker
open PrayerTracker.ViewModels
/// Create the common view information heading
let viewInfo (ctx : HttpContext) startTicks =
let msg =
match ctx.Session.messages with
match ctx.Session.Messages with
| [] -> []
| x ->
ctx.Session.messages <- []
ctx.Session.Messages <- []
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 =
match ctx.Request.Headers.HxTarget with
| Some hdr when hdr = "pt-body" -> ContentOnly
@ -91,8 +64,8 @@ let viewInfo (ctx : HttpContext) startTicks =
Version = appVersion
Messages = msg
RequestStart = startTicks
User = ctx.Session.user
Group = ctx.Session.smallGroup
User = ctx.CurrentUser
Group = ctx.CurrentGroup
Layout = layout
}
@ -100,16 +73,17 @@ let viewInfo (ctx : HttpContext) startTicks =
let renderHtml next ctx view =
htmlView view next ctx
open Microsoft.Extensions.Logging
/// Display an error regarding form submission
let bindError (msg : string) next (ctx : HttpContext) =
Console.WriteLine msg
ctx.SetStatusCode 400
text msg next ctx
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 next (ctx : HttpContext) =
ctx.SetStatusCode 404
text "Not Found" next ctx
let fourOhFour (ctx : HttpContext) =
(setStatusCode 404 >=> text "Not Found") earlyReturn ctx
/// Handler to validate CSRF prevention token
let validateCsrf : HttpHandler = fun next ctx -> task {
@ -120,7 +94,7 @@ let validateCsrf : HttpHandler = fun next ctx -> task {
/// Add a message to the session
let addUserMessage (ctx : HttpContext) msg =
ctx.Session.messages <- msg :: ctx.Session.messages
ctx.Session.Messages <- msg :: ctx.Session.Messages
open Microsoft.AspNetCore.Html
@ -165,94 +139,27 @@ type AccessLevel =
open Microsoft.AspNetCore.Http.Extensions
open PrayerTracker.Entities
/// Require the given access role (also refreshes "Remember Me" user and group logons)
let requireAccess level : HttpHandler =
/// Is there currently a user logged on?
let isUserLoggedOn (ctx : HttpContext) =
ctx.Session.user |> Option.isSome
/// Log a user on from the timeout cookie
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 ()
addError ctx s["You are not authorized to view the requested page."]
return! redirectTo false "/unauthorized" next ctx
| _ when level |> List.contains User ->
// Redirect to the user log on page
ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
return! redirectTo false "/user/log-on" next ctx
| _ when level |> List.contains Group ->
// Redirect to the small group log on page
ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
return! redirectTo false "/small-group/log-on" next ctx
| _ ->
let s = Views.I18N.localizer.Force ()
addError ctx s["You are not authorized to view the requested page."]
return! redirectTo false "/unauthorized" next ctx
}
/// Require one of the given access roles
let requireAccess levels : HttpHandler = fun next ctx -> task {
match ctx.CurrentUser, ctx.CurrentGroup with
| _, _ when List.contains Public levels -> return! next ctx
| Some _, _ when List.contains User levels -> return! next ctx
| _, Some _ when List.contains Group levels -> return! next ctx
| Some u, _ when List.contains Admin levels && u.IsAdmin -> return! next ctx
| _, _ when List.contains Admin levels ->
let s = Views.I18N.localizer.Force ()
addError ctx s["You are not authorized to view the requested page."]
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.GetEncodedUrl ())
return! redirectTo false "/user/log-on" next ctx
| _, _ when List.contains Group levels ->
// Redirect to the small group log on page
ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
return! redirectTo false "/small-group/log-on" next ctx
| _, _ ->
let s = Views.I18N.localizer.Force ()
addError ctx s["You are not authorized to view the requested page."]
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
open Microsoft.AspNetCore.Http
open Microsoft.Extensions.DependencyInjection
open Microsoft.FSharpLu
open Newtonsoft.Json
open PrayerTracker.Entities
open PrayerTracker.ViewModels
// fsharplint:disable MemberNames
/// Extensions on the .NET session object
type ISession with
/// Set an object in the session
member this.SetObject key value =
this.SetString (key, JsonConvert.SerializeObject value)
/// Get an object from the session
member this.GetObject<'T> key =
match this.GetString key with
| 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
match this.GetString key with null -> Unchecked.defaultof<'T> | v -> JsonConvert.DeserializeObject<'T> v
/// Current messages for the session
member this.messages
member this.Messages
with get () =
match box (this.GetObject<UserMessage list> Key.Session.userMessages) with
| null -> List.empty<UserMessage>
@ -46,7 +26,27 @@ type ISession with
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
/// 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)
member this.db
with get () = this.RequestServices.GetRequiredService<AppDbContext> ()
member this.Db = this.GetService<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
|> renderHtml next ctx
/// GET /
let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks
|> Views.Home.index
|> renderHtml next ctx
/// GET /language/[culture]
let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
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
redirectTo false url next ctx
/// GET /legal/privacy-policy
let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks
|> Views.Home.privacyPolicy
|> renderHtml next ctx
/// GET /legal/terms-of-service
let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks
|> Views.Home.termsOfService
|> renderHtml next ctx
open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies
/// 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 ()
// Remove cookies if they exist
Key.Cookie.logOffCookies |> List.iter ctx.Response.Cookies.Delete
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
let s = Views.I18N.localizer.Force ()
addHtmlInfo ctx s["Log Off Successful • Have a nice day!"]
redirectTo false "/" next ctx
return! redirectTo false "/" next ctx
}
/// GET /unauthorized
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
let private findRequest (ctx : HttpContext) reqId = task {
match! ctx.db.TryRequestById reqId with
| Some req when req.SmallGroupId = (currentGroup ctx).Id -> return Ok req
match! ctx.Db.TryRequestById reqId with
| Some req when req.SmallGroupId = ctx.CurrentGroup.Value.Id -> return Ok req
| Some _ ->
let s = Views.I18N.localizer.Force ()
addError ctx s["The prayer request you tried to access is not assigned to your group"]
return Result.Error (redirectTo false "/unauthorized")
| None -> return Result.Error fourOhFour
return Result.Error (redirectTo false "/unauthorized" earlyReturn ctx)
| None -> return Result.Error (fourOhFour ctx)
}
open NodaTime
/// Generate a list of requests for the given date
let private generateRequestList ctx date = task {
let grp = currentGroup ctx
let private generateRequestList (ctx : HttpContext) date = task {
let grp = ctx.CurrentGroup.Value
let clock = ctx.GetService<IClock> ()
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
{ Requests = reqs
Date = listDate
SmallGroup = grp
ShowHeader = true
CanEmail = Option.isSome ctx.Session.user
CanEmail = Option.isSome ctx.CurrentUser
Recipients = []
}
}
@ -46,7 +46,7 @@ let private parseListDate (date : string option) =
/// GET /prayer-request/[request-id]/edit
let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx
let grp = ctx.CurrentGroup.Value
let now = grp.LocalDateNow (ctx.GetService<IClock> ())
let requestId = PrayerRequestId reqId
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 }
|> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx
|> renderHtml next ctx
| Result.Error e -> return! e next ctx
| Result.Error e -> return! e
}
/// 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 s = Views.I18N.localizer.Force ()
let listDate = parseListDate (Some date)
let grp = currentGroup ctx
let grp = ctx.CurrentGroup.Value
let! list = generateRequestList ctx listDate
let! recipients = ctx.db.AllMembersForSmallGroup grp.Id
let! recipients = ctx.Db.AllMembersForSmallGroup grp.Id
use! client = Email.getConnection ()
do! Email.sendEmails client recipients
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
| Ok req ->
let s = Views.I18N.localizer.Force ()
ctx.db.PrayerRequests.Remove req |> ignore
let! _ = ctx.db.SaveChangesAsync ()
ctx.Db.PrayerRequests.Remove req |> ignore
let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["The prayer request was deleted successfully"]
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
@ -111,20 +111,20 @@ let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task
match! findRequest ctx requestId with
| Ok req ->
let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with Expiration = Forced }
let! _ = ctx.db.SaveChangesAsync ()
ctx.Db.UpdateEntry { req with Expiration = Forced }
let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["Successfully {0} prayer request", s["Expired"].Value.ToLower ()]
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
let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
match! ctx.db.TryGroupById groupId with
match! ctx.Db.TryGroupById groupId with
| Some grp when grp.Preferences.IsPublic ->
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!
viewInfo ctx startTicks
|> Views.PrayerRequest.list
@ -132,7 +132,7 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
Date = grp.LocalDateNow clock
SmallGroup = grp
ShowHeader = true
CanEmail = Option.isSome ctx.Session.user
CanEmail = Option.isSome ctx.CurrentUser
Recipients = []
}
|> renderHtml next ctx
@ -140,13 +140,13 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
let s = Views.I18N.localizer.Force ()
addError ctx s["The request list for the group you tried to view is not public."]
return! redirectTo false "/unauthorized" next ctx
| None -> return! fourOhFour next ctx
| None -> return! fourOhFour ctx
}
/// GET /prayer-requests/lists
let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let! groups = ctx.db.PublicAndProtectedGroups ()
let! groups = ctx.Db.PublicAndProtectedGroups ()
return!
viewInfo ctx startTicks
|> Views.PrayerRequest.lists groups
@ -158,7 +158,7 @@ let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
/// GET /prayer-requests?search=[search-query]
let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx
let grp = ctx.CurrentGroup.Value
let pageNbr =
match ctx.GetQueryStringValue "page" with
| 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 {
match ctx.GetQueryStringValue "search" with
| Ok search ->
let! reqs = ctx.db.SearchRequestsForSmallGroup grp search pageNbr
let! reqs = ctx.Db.SearchRequestsForSmallGroup grp search pageNbr
return
{ MaintainRequests.empty with
Requests = reqs
@ -174,7 +174,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
PageNbr = Some pageNbr
}
| 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
{ MaintainRequests.empty with
Requests = reqs
@ -202,11 +202,11 @@ let restore reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> tas
match! findRequest ctx requestId with
| Ok req ->
let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with Expiration = Automatic; UpdatedDate = DateTime.Now }
let! _ = ctx.db.SaveChangesAsync ()
ctx.Db.UpdateEntry { req with Expiration = Automatic; UpdatedDate = DateTime.Now }
let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["Successfully {0} prayer request", s["Restored"].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e next ctx
| Result.Error e -> return! e
}
open System.Threading.Tasks
@ -217,7 +217,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
| Ok m ->
let! req =
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
| Some pr ->
let upd8 =
@ -227,26 +227,26 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
Text = ckEditorToText m.Text
Expiration = Expiration.fromCode m.Expiration
}
let grp = currentGroup ctx
let grp = ctx.CurrentGroup.Value
let now = grp.LocalDateNow (ctx.GetService<IClock> ())
match m.IsNew with
| true ->
let dt = defaultArg m.EnteredDate now
{ upd8 with
SmallGroupId = grp.Id
UserId = (currentUser ctx).Id
UserId = ctx.CurrentUser.Value.Id
EnteredDate = dt
UpdatedDate = dt
}
| false when defaultArg m.SkipDateUpdate false -> upd8
| false -> { upd8 with UpdatedDate = now }
|> if m.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry
let! _ = ctx.db.SaveChangesAsync ()
|> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry
let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
let act = if m.IsNew then "Added" else "Updated"
addInfo ctx s["Successfully {0} prayer request", s[act].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx
| None -> return! fourOhFour next ctx
| None -> return! fourOhFour ctx
| Result.Error e -> return! bindError e next ctx
}

1
src/PrayerTracker/PrayerTracker.fsproj
View File

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

149
src/PrayerTracker/SmallGroup.fs
View File

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

173
src/PrayerTracker/User.fs
View File

@ -1,21 +1,12 @@
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.Collections.Generic
open Giraffe
open Microsoft.AspNetCore.Http
open PrayerTracker
open PrayerTracker.Entities
open PrayerTracker.ViewModels
/// 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
@ -25,8 +16,8 @@ let private findUserByPassword model (db : AppDbContext) = task {
// Already upgraded; match = success
let pwHash = pbkdf2Hash (Option.get u.Salt) model.Password
if u.PasswordHash = pwHash then
return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }, pwHash
else return None, ""
return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }
else return None
| Some u when u.PasswordHash = sha1Hash model.Password ->
// Not upgraded, but password is good; upgrade 'em!
// Upgrade 'em!
@ -35,8 +26,8 @@ let private findUserByPassword model (db : AppDbContext) = task {
let upgraded = { u with Salt = Some salt; PasswordHash = pwHash }
db.UpdateEntry upgraded
let! _ = db.SaveChangesAsync ()
return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }, pwHash
| _ -> return None, ""
return Some { u with PasswordHash = ""; Salt = None; SmallGroups = List<UserSmallGroup>() }
| _ -> return None
}
open System.Threading.Tasks
@ -44,27 +35,25 @@ open System.Threading.Tasks
/// POST /user/password/change
let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<ChangePassword> () with
| Ok m ->
| Ok model ->
let s = Views.I18N.localizer.Force ()
let curUsr = currentUser ctx
let! dbUsr = ctx.db.TryUserById curUsr.Id
let curUsr = ctx.CurrentUser.Value
let! dbUsr = ctx.Db.TryUserById curUsr.Id
let! user =
match dbUsr with
| Some usr ->
// Check the old password against a possibly non-salted hash
(match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) m.OldPassword
|> ctx.db.TryUserLogOnByCookie curUsr.Id (currentGroup ctx).Id
(match usr.Salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) model.OldPassword
|> ctx.Db.TryUserLogOnByCookie curUsr.Id ctx.CurrentGroup.Value.Id
| _ -> Task.FromResult None
match user with
| Some _ when m.NewPassword = m.NewPasswordConfirm ->
| Some _ when model.NewPassword = model.NewPasswordConfirm ->
match dbUsr with
| Some usr ->
// Generate new salt whenever the password is changed
let salt = Guid.NewGuid ()
ctx.db.UpdateEntry { usr with PasswordHash = pbkdf2Hash salt m.NewPassword; Salt = Some salt }
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
ctx.Db.UpdateEntry { usr with PasswordHash = pbkdf2Hash salt model.NewPassword; Salt = Some salt }
let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["Your password was changed successfully"]
| None -> addError ctx s["Unable to change password"]
return! redirectTo false "/" next ctx
@ -80,59 +69,75 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f
/// POST /user/[user-id]/delete
let delete usrId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let userId = UserId usrId
match! ctx.db.TryUserById userId with
match! ctx.Db.TryUserById userId with
| Some user ->
ctx.db.RemoveEntry user
let! _ = ctx.db.SaveChangesAsync ()
ctx.Db.RemoveEntry user
let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
addInfo ctx s["Successfully deleted user {0}", user.Name]
return! redirectTo false "/users" next ctx
| _ -> return! fourOhFour next ctx
| _ -> return! fourOhFour ctx
}
open System.Net
open System.Security.Claims
open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Html
/// POST /user/log-on
let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<UserLogOn> () with
| Ok model ->
let s = Views.I18N.localizer.Force ()
let! usr, pwHash = findUserByPassword model ctx.db
let! grp = ctx.db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId)
let nextUrl =
match usr with
| Some _ ->
ctx.Session.user <- usr
ctx.Session.smallGroup <- grp
if defaultArg model.RememberMe false then setUserCookie ctx pwHash
addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
match model.RedirectUrl with
| None -> "/small-group"
// TODO: ensure "x" is a local URL
| Some x when x = "" -> "/small-group"
| Some x -> x
| _ ->
let grpName = match grp with Some g -> g.Name | _ -> "N/A"
{ UserMessage.error with
Text = htmlLocString s["Invalid credentials - log on unsuccessful"]
Description =
[ s["This is likely due to one of the following reasons"].Value
":<ul><li>"
s["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode model.Email].Value
"</li><li>"
s["The password entered does not match the password for the given e-mail address."].Value
"</li><li>"
s["You are not authorized to administer the group “{0}”.",
WebUtility.HtmlEncode grpName].Value
"</li></ul>"
]
|> String.concat ""
|> (HtmlString >> Some)
}
|> addUserMessage ctx
"/user/log-on"
return! redirectTo false nextUrl next ctx
let s = Views.I18N.localizer.Force ()
let! usr = findUserByPassword model ctx.Db
match! ctx.Db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId) with
| Some group ->
let! nextUrl = backgroundTask {
match usr with
| Some user ->
ctx.CurrentUser <- usr
ctx.CurrentGroup <- Some group
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"]]
return
match model.RedirectUrl with
| None -> "/small-group"
| Some x when x = ""-> "/small-group"
| Some x when x.IndexOf "://" < 0 -> x
| _ -> "/small-group"
| _ ->
{ UserMessage.error with
Text = htmlLocString s["Invalid credentials - log on unsuccessful"]
Description =
[ s["This is likely due to one of the following reasons"].Value
":<ul><li>"
s["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode model.Email].Value
"</li><li>"
s["The password entered does not match the password for the given e-mail address."].Value
"</li><li>"
s["You are not authorized to administer the group “{0}”.",
WebUtility.HtmlEncode group.Name].Value
"</li></ul>"
]
|> String.concat ""
|> (HtmlString >> Some)
}
|> addUserMessage ctx
return "/user/log-on"
}
return! redirectTo false nextUrl next ctx
| None -> return! fourOhFour 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
|> renderHtml next ctx
else
match! ctx.db.TryUserById userId with
match! ctx.Db.TryUserById userId with
| Some user ->
return!
viewInfo ctx startTicks
|> Views.User.edit (EditUser.fromUser user) 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 startTicks = DateTime.Now.Ticks
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
match url with
| Some _ ->
@ -178,7 +183,7 @@ let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
/// GET /users
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let! users = ctx.db.AllUsers ()
let! users = ctx.Db.AllUsers ()
return!
viewInfo ctx startTicks
|> Views.User.maintain users ctx
@ -199,7 +204,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
| Ok m ->
let! user =
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 =
match user with
| Some u ->
@ -214,8 +219,8 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
match saltedUser with
| Some u ->
let updatedUser = m.PopulateUser u (pbkdf2Hash (Option.get u.Salt))
updatedUser |> if m.IsNew then ctx.db.AddEntry else ctx.db.UpdateEntry
let! _ = ctx.db.SaveChangesAsync ()
updatedUser |> if m.IsNew then ctx.Db.AddEntry else ctx.Db.UpdateEntry
let! _ = ctx.Db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
if m.IsNew then
let h = CommonFunctions.htmlString
@ -230,7 +235,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
else
addInfo ctx s["Successfully {0} user", s["Updated"].Value.ToLower ()]
return! redirectTo false "/users" next ctx
| None -> return! fourOhFour next ctx
| None -> return! fourOhFour 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"]
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 ->
let groups =
model.SmallGroups.Split ','
@ -253,17 +258,17 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun
|> List.ofArray
user.SmallGroups
|> Seq.filter (fun x -> not (groups |> List.exists (fun y -> y = x.SmallGroupId)))
|> ctx.db.UserGroupXref.RemoveRange
|> ctx.Db.UserGroupXref.RemoveRange
groups
|> Seq.ofList
|> 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 })
|> List.ofSeq
|> List.iter ctx.db.AddEntry
let! _ = ctx.db.SaveChangesAsync ()
|> List.iter ctx.Db.AddEntry
let! _ = ctx.Db.SaveChangesAsync ()
addInfo ctx s["Successfully updated group permissions for {0}", model.UserName]
return! redirectTo false "/users" next ctx
| _ -> return! fourOhFour next ctx
| _ -> return! fourOhFour 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 startTicks = DateTime.Now.Ticks
let userId = UserId usrId
match! ctx.db.TryUserByIdWithGroups userId with
match! ctx.Db.TryUserByIdWithGroups userId with
| 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
return!
viewInfo ctx startTicks
|> Views.User.assignGroups (AssignGroups.fromUser user) groups curGroups ctx
|> renderHtml next ctx
| None -> return! fourOhFour next ctx
| None -> return! fourOhFour ctx
}