Version 8 #43
|
|
@ -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>(
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
/// 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 level |> List.contains User ->
|
||||
| _, _ 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 level |> List.contains Group ->
|
||||
| _, _ 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
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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> ()
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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" />
|
||||
|
|
|
|||
|
|
@ -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 “{0}” 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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,17 +69,20 @@ 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
|
||||
|
|
@ -98,22 +90,33 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
|
|||
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 =
|
||||
let! usr = findUserByPassword model ctx.Db
|
||||
match! ctx.Db.TryGroupById (idFromShort SmallGroupId model.SmallGroupId) with
|
||||
| Some group ->
|
||||
let! nextUrl = backgroundTask {
|
||||
match usr with
|
||||
| Some _ ->
|
||||
ctx.Session.user <- usr
|
||||
ctx.Session.smallGroup <- grp
|
||||
if defaultArg model.RememberMe false then setUserCookie ctx pwHash
|
||||
| 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"
|
||||
// TODO: ensure "x" is a local URL
|
||||
| Some x when x = "" -> "/small-group"
|
||||
| Some x -> x
|
||||
| Some x when x = ""-> "/small-group"
|
||||
| Some x when x.IndexOf "://" < 0 -> x
|
||||
| _ -> "/small-group"
|
||||
| _ ->
|
||||
let grpName = match grp with Some g -> g.Name | _ -> "N/A"
|
||||
{ UserMessage.error with
|
||||
Text = htmlLocString s["Invalid credentials - log on unsuccessful"]
|
||||
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
|
||||
"</li><li>"
|
||||
s["You are not authorized to administer the group “{0}”.",
|
||||
WebUtility.HtmlEncode grpName].Value
|
||||
WebUtility.HtmlEncode group.Name].Value
|
||||
"</li></ul>"
|
||||
]
|
||||
|> String.concat ""
|
||||
|> (HtmlString >> Some)
|
||||
}
|
||||
|> addUserMessage ctx
|
||||
"/user/log-on"
|
||||
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
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user