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

WIP on F# 6 formatting / conversion

Browse Source
This commit is contained in:
Daniel J. Summers 2022-07-12 22:43:01 -04:00
parent 1d4e66b863
commit 47fb9884f1
25 changed files with 4498 additions and 4516 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
src/PrayerTracker.Data/AppDbContext.fs
View File

@ -6,81 +6,85 @@ open PrayerTracker.Entities
/// EF Core data context for PrayerTracker /// EF Core data context for PrayerTracker
[<AllowNullLiteral>] [<AllowNullLiteral>]
type AppDbContext (options : DbContextOptions<AppDbContext>) = type AppDbContext (options : DbContextOptions<AppDbContext>) =
inherit DbContext (options) inherit DbContext (options)
[<DefaultValue>] [<DefaultValue>]
val mutable private churches : DbSet<Church> val mutable private churches : DbSet<Church>
[<DefaultValue>] [<DefaultValue>]
val mutable private members : DbSet<Member> val mutable private members : DbSet<Member>
[<DefaultValue>] [<DefaultValue>]
val mutable private prayerRequests : DbSet<PrayerRequest> val mutable private prayerRequests : DbSet<PrayerRequest>
[<DefaultValue>] [<DefaultValue>]
val mutable private preferences : DbSet<ListPreferences> val mutable private preferences : DbSet<ListPreferences>
[<DefaultValue>] [<DefaultValue>]
val mutable private smallGroups : DbSet<SmallGroup> val mutable private smallGroups : DbSet<SmallGroup>
[<DefaultValue>] [<DefaultValue>]
val mutable private timeZones : DbSet<TimeZone> val mutable private timeZones : DbSet<TimeZone>
[<DefaultValue>] [<DefaultValue>]
val mutable private users : DbSet<User> val mutable private users : DbSet<User>
[<DefaultValue>] [<DefaultValue>]
val mutable private userGroupXref : DbSet<UserSmallGroup> val mutable private userGroupXref : DbSet<UserSmallGroup>
/// Churches /// Churches
member this.Churches member this.Churches
with get() = this.churches with get() = this.churches
and set v = this.churches <- v and set v = this.churches <- v
/// Small group members /// Small group members
member this.Members member this.Members
with get() = this.members with get() = this.members
and set v = this.members <- v and set v = this.members <- v
/// Prayer requests /// Prayer requests
member this.PrayerRequests member this.PrayerRequests
with get() = this.prayerRequests with get() = this.prayerRequests
and set v = this.prayerRequests <- v and set v = this.prayerRequests <- v
/// Request list preferences (by class) /// Request list preferences (by class)
member this.Preferences member this.Preferences
with get() = this.preferences with get() = this.preferences
and set v = this.preferences <- v and set v = this.preferences <- v
/// Small groups /// Small groups
member this.SmallGroups member this.SmallGroups
with get() = this.smallGroups with get() = this.smallGroups
and set v = this.smallGroups <- v and set v = this.smallGroups <- v
/// Time zones /// Time zones
member this.TimeZones member this.TimeZones
with get() = this.timeZones with get() = this.timeZones
and set v = this.timeZones <- v and set v = this.timeZones <- v
/// Users /// Users
member this.Users member this.Users
with get() = this.users with get() = this.users
and set v = this.users <- v and set v = this.users <- v
/// User / small group cross-reference /// User / small group cross-reference
member this.UserGroupXref member this.UserGroupXref
with get() = this.userGroupXref with get() = this.userGroupXref
and set v = this.userGroupXref <- v and set v = this.userGroupXref <- v
/// F#-style async for saving changes /// F#-style async for saving changes
member this.AsyncSaveChanges () = member this.AsyncSaveChanges () =
this.SaveChangesAsync () |> Async.AwaitTask this.SaveChangesAsync () |> Async.AwaitTask
override __.OnModelCreating (modelBuilder : ModelBuilder) = override _.OnConfiguring (optionsBuilder : DbContextOptionsBuilder) =
base.OnModelCreating modelBuilder base.OnConfiguring optionsBuilder
optionsBuilder.UseQueryTrackingBehavior QueryTrackingBehavior.NoTracking |> ignore
override _.OnModelCreating (modelBuilder : ModelBuilder) =
base.OnModelCreating modelBuilder
modelBuilder.HasDefaultSchema "pt" |> ignore modelBuilder.HasDefaultSchema "pt" |> ignore
[ Church.configureEF [ Church.configureEF
ListPreferences.configureEF ListPreferences.configureEF
Member.configureEF Member.configureEF
PrayerRequest.configureEF PrayerRequest.configureEF
SmallGroup.configureEF SmallGroup.configureEF
TimeZone.configureEF TimeZone.configureEF
User.configureEF User.configureEF
UserSmallGroup.configureEF UserSmallGroup.configureEF
] ]
|> List.iter (fun x -> x modelBuilder) |> List.iter (fun x -> x modelBuilder)

577
src/PrayerTracker.Data/DataAccess.fs
View File

@ -1,380 +1,287 @@
[<AutoOpen>] [<AutoOpen>]
module PrayerTracker.DataAccess module PrayerTracker.DataAccess
open Microsoft.EntityFrameworkCore
open PrayerTracker.Entities
open System.Collections.Generic
open System.Linq open System.Linq
open PrayerTracker.Entities
[<AutoOpen>] [<AutoOpen>]
module private Helpers = module private Helpers =
open Microsoft.FSharpLu /// Central place to append sort criteria for prayer request queries
open System.Threading.Tasks let reqSort sort (q : IQueryable<PrayerRequest>) =
match sort with
| SortByDate ->
q.OrderByDescending(fun req -> req.updatedDate)
.ThenByDescending(fun req -> req.enteredDate)
.ThenBy (fun req -> req.requestor)
| SortByRequestor ->
q.OrderBy(fun req -> req.requestor)
.ThenByDescending(fun req -> req.updatedDate)
.ThenByDescending (fun req -> req.enteredDate)
/// Paginate a prayer request query
let paginate pageNbr pageSize (q : IQueryable<PrayerRequest>) =
q.Skip((pageNbr - 1) * pageSize).Take pageSize
/// Central place to append sort criteria for prayer request queries
let reqSort sort (q : IQueryable<PrayerRequest>) =
match sort with
| SortByDate ->
query {
for req in q do
sortByDescending req.updatedDate
thenByDescending req.enteredDate
thenBy req.requestor
}
| SortByRequestor ->
query {
for req in q do
sortBy req.requestor
thenByDescending req.updatedDate
thenByDescending req.enteredDate
}
/// Convert a possibly-null object to an option, wrapped as a task
let toOptionTask<'T> (item : 'T) = (Option.fromObject >> Task.FromResult) item
open System.Collections.Generic
open Microsoft.EntityFrameworkCore
open Microsoft.FSharpLu
type AppDbContext with type AppDbContext with
(*-- DISCONNECTED DATA EXTENSIONS --*) (*-- DISCONNECTED DATA EXTENSIONS --*)
/// Add an entity entry to the tracked data context with the status of Added /// Add an entity entry to the tracked data context with the status of Added
member this.AddEntry<'TEntity when 'TEntity : not struct> (e : 'TEntity) = member this.AddEntry<'TEntity when 'TEntity : not struct> (e : 'TEntity) =
this.Entry<'TEntity>(e).State <- EntityState.Added this.Entry<'TEntity>(e).State <- EntityState.Added
/// Add an entity entry to the tracked data context with the status of Updated /// Add an entity entry to the tracked data context with the status of Updated
member this.UpdateEntry<'TEntity when 'TEntity : not struct> (e : 'TEntity) = member this.UpdateEntry<'TEntity when 'TEntity : not struct> (e : 'TEntity) =
this.Entry<'TEntity>(e).State <- EntityState.Modified this.Entry<'TEntity>(e).State <- EntityState.Modified
/// Add an entity entry to the tracked data context with the status of Deleted /// Add an entity entry to the tracked data context with the status of Deleted
member this.RemoveEntry<'TEntity when 'TEntity : not struct> (e : 'TEntity) = member this.RemoveEntry<'TEntity when 'TEntity : not struct> (e : 'TEntity) =
this.Entry<'TEntity>(e).State <- EntityState.Deleted this.Entry<'TEntity>(e).State <- EntityState.Deleted
(*-- CHURCH EXTENSIONS --*) (*-- CHURCH EXTENSIONS --*)
/// Find a church by its Id /// Find a church by its Id
member this.TryChurchById cId = member this.TryChurchById cId = backgroundTask {
query { let! church = this.Churches.SingleOrDefaultAsync (fun ch -> ch.churchId = cId)
for ch in this.Churches.AsNoTracking () do return Option.fromObject church
where (ch.churchId = cId) }
exactlyOneOrDefault
} /// Find all churches
|> toOptionTask member this.AllChurches () = backgroundTask {
let! churches = this.Churches.OrderBy(fun ch -> ch.name).ToListAsync ()
/// Find all churches return List.ofSeq churches
member this.AllChurches () = }
task {
let q =
query {
for ch in this.Churches.AsNoTracking () do
sortBy ch.name
}
let! churches = q.ToListAsync ()
return List.ofSeq churches
}
(*-- MEMBER EXTENSIONS --*) (*-- MEMBER EXTENSIONS --*)
/// Get a small group member by its Id /// Get a small group member by its Id
member this.TryMemberById mId = member this.TryMemberById mbrId = backgroundTask {
query { let! mbr = this.Members.SingleOrDefaultAsync (fun m -> m.memberId = mbrId)
for mbr in this.Members.AsNoTracking () do return Option.fromObject mbr
where (mbr.memberId = mId) }
select mbr
exactlyOneOrDefault
}
|> toOptionTask
/// Find all members for a small group /// Find all members for a small group
member this.AllMembersForSmallGroup gId = member this.AllMembersForSmallGroup gId = backgroundTask {
task { let! members =
let q = this.Members.Where(fun mbr -> mbr.smallGroupId = gId)
query { .OrderBy(fun mbr -> mbr.memberName)
for mbr in this.Members.AsNoTracking () do .ToListAsync ()
where (mbr.smallGroupId = gId) return List.ofSeq members
sortBy mbr.memberName }
}
let! mbrs = q.ToListAsync ()
return List.ofSeq mbrs
}
/// Count members for a small group /// Count members for a small group
member this.CountMembersForSmallGroup gId = member this.CountMembersForSmallGroup gId = backgroundTask {
this.Members.CountAsync (fun m -> m.smallGroupId = gId) return! this.Members.CountAsync (fun m -> m.smallGroupId = gId)
}
(*-- PRAYER REQUEST EXTENSIONS --*)
(*-- PRAYER REQUEST EXTENSIONS --*) /// Get a prayer request by its Id
member this.TryRequestById reqId = backgroundTask {
let! req = this.PrayerRequests.SingleOrDefaultAsync (fun r -> r.prayerRequestId = reqId)
return Option.fromObject req
}
/// Get a prayer request by its Id /// Get all (or active) requests for a small group as of now or the specified date
member this.TryRequestById reqId = member this.AllRequestsForSmallGroup (grp : SmallGroup) clock listDate activeOnly pageNbr = backgroundTask {
query { let theDate = match listDate with Some dt -> dt | _ -> grp.localDateNow clock
for req in this.PrayerRequests.AsNoTracking () do let query =
where (req.prayerRequestId = reqId) this.PrayerRequests.Where(fun req -> req.smallGroupId = grp.smallGroupId)
exactlyOneOrDefault |> function
} | q when activeOnly ->
|> toOptionTask let asOf = theDate.AddDays(-(float grp.preferences.daysToExpire)).Date
q.Where(fun req ->
( req.updatedDate > asOf
|| req.expiration = Manual
|| req.requestType = LongTermRequest
|| req.requestType = Expecting)
&& req.expiration <> Forced)
|> reqSort grp.preferences.requestSort
|> paginate pageNbr grp.preferences.pageSize
| q -> reqSort grp.preferences.requestSort q
let! reqs = query.ToListAsync ()
return List.ofSeq reqs
}
/// Get all (or active) requests for a small group as of now or the specified date /// Count prayer requests for the given small group Id
// TODO: why not make this an async list like the rest of these methods? member this.CountRequestsBySmallGroup gId = backgroundTask {
member this.AllRequestsForSmallGroup (grp : SmallGroup) clock listDate activeOnly pageNbr : PrayerRequest seq = return! this.PrayerRequests.CountAsync (fun pr -> pr.smallGroupId = gId)
let theDate = match listDate with Some dt -> dt | _ -> grp.localDateNow clock }
query {
for req in this.PrayerRequests.AsNoTracking () do
where (req.smallGroupId = grp.smallGroupId)
}
|> function
| q when activeOnly ->
let asOf = theDate.AddDays(-(float grp.preferences.daysToExpire)).Date
query {
for req in q do
where ( ( req.updatedDate > asOf
|| req.expiration = Manual
|| req.requestType = LongTermRequest
|| req.requestType = Expecting)
&& req.expiration <> Forced)
}
| q -> q
|> reqSort grp.preferences.requestSort
|> function
| q ->
match activeOnly with
| true -> upcast q
| false ->
upcast query {
for req in q do
skip ((pageNbr - 1) * grp.preferences.pageSize)
take grp.preferences.pageSize
}
/// Count prayer requests for the given small group Id
member this.CountRequestsBySmallGroup gId =
this.PrayerRequests.CountAsync (fun pr -> pr.smallGroupId = gId)
/// Count prayer requests for the given church Id /// Count prayer requests for the given church Id
member this.CountRequestsByChurch cId = member this.CountRequestsByChurch cId = backgroundTask {
this.PrayerRequests.CountAsync (fun pr -> pr.smallGroup.churchId = cId) return! this.PrayerRequests.CountAsync (fun pr -> pr.smallGroup.churchId = cId)
}
/// Get all (or active) requests for a small group as of now or the specified date /// Get all (or active) requests for a small group as of now or the specified date
// TODO: same as above... member this.SearchRequestsForSmallGroup (grp : SmallGroup) (searchTerm : string) pageNbr = backgroundTask {
member this.SearchRequestsForSmallGroup (grp : SmallGroup) (searchTerm : string) pageNbr : PrayerRequest seq = let sql = """
let pgSz = grp.preferences.pageSize SELECT * FROM pt."PrayerRequest" WHERE "SmallGroupId" = {0} AND "Text" ILIKE {1}
let toSkip = (pageNbr - 1) * pgSz
let sql =
""" SELECT * FROM pt."PrayerRequest" WHERE "SmallGroupId" = {0} AND "Text" ILIKE {1}
UNION UNION
SELECT * FROM pt."PrayerRequest" WHERE "SmallGroupId" = {0} AND COALESCE("Requestor", '') ILIKE {1}""" SELECT * FROM pt."PrayerRequest" WHERE "SmallGroupId" = {0} AND COALESCE("Requestor", '') ILIKE {1}"""
let like = sprintf "%%%s%%" let like = sprintf "%%%s%%"
this.PrayerRequests.FromSqlRaw(sql, grp.smallGroupId, like searchTerm).AsNoTracking () let query =
|> reqSort grp.preferences.requestSort this.PrayerRequests.FromSqlRaw(sql, grp.smallGroupId, like searchTerm)
|> function |> reqSort grp.preferences.requestSort
| q -> |> paginate pageNbr grp.preferences.pageSize
upcast query { let! reqs = query.ToListAsync ()
for req in q do return List.ofSeq reqs
skip toSkip }
take pgSz
} (*-- SMALL GROUP EXTENSIONS --*)
(*-- SMALL GROUP EXTENSIONS --*) /// Find a small group by its Id
member this.TryGroupById gId = backgroundTask {
let! grp =
this.SmallGroups.Include(fun sg -> sg.preferences)
.SingleOrDefaultAsync (fun sg -> sg.smallGroupId = gId)
return Option.fromObject grp
}
/// Find a small group by its Id /// Get small groups that are public or password protected
member this.TryGroupById gId = member this.PublicAndProtectedGroups () = backgroundTask {
query { let! groups =
for grp in this.SmallGroups.AsNoTracking().Include (fun sg -> sg.preferences) do this.SmallGroups.Include(fun sg -> sg.preferences).Include(fun sg -> sg.church)
where (grp.smallGroupId = gId) .Where(fun sg ->
exactlyOneOrDefault sg.preferences.isPublic
} || (sg.preferences.groupPassword <> null && sg.preferences.groupPassword <> ""))
|> toOptionTask .OrderBy(fun sg -> sg.church.name).ThenBy(fun sg -> sg.name)
.ToListAsync ()
return List.ofSeq groups
}
/// Get small groups that are public or password protected /// Get small groups that are password protected
member this.PublicAndProtectedGroups () = member this.ProtectedGroups () = backgroundTask {
task { let! groups =
let smallGroups = this.SmallGroups.AsNoTracking().Include(fun sg -> sg.preferences).Include (fun sg -> sg.church) this.SmallGroups.Include(fun sg -> sg.church)
let q = .Where(fun sg -> sg.preferences.groupPassword <> null && sg.preferences.groupPassword <> "")
query { .OrderBy(fun sg -> sg.church.name).ThenBy(fun sg -> sg.name)
for grp in smallGroups do .ToListAsync ()
where ( grp.preferences.isPublic return List.ofSeq groups
|| (grp.preferences.groupPassword <> null && grp.preferences.groupPassword <> "")) }
sortBy grp.church.name
thenBy grp.name
}
let! grps = q.ToListAsync ()
return List.ofSeq grps
}
/// Get small groups that are password protected /// Get all small groups
member this.ProtectedGroups () = member this.AllGroups () = backgroundTask {
task { let! groups =
let q = this.SmallGroups
query { .Include(fun sg -> sg.church)
for grp in this.SmallGroups.AsNoTracking().Include (fun sg -> sg.church) do .Include(fun sg -> sg.preferences)
where (grp.preferences.groupPassword <> null && grp.preferences.groupPassword <> "") .Include(fun sg -> sg.preferences.timeZone)
sortBy grp.church.name .OrderBy(fun sg -> sg.name)
thenBy grp.name .ToListAsync ()
} return List.ofSeq groups
let! grps = q.ToListAsync () }
return List.ofSeq grps
}
/// Get all small groups /// Get a small group list by their Id, with their church prepended to their name
member this.AllGroups () = member this.GroupList () = backgroundTask {
task { let! groups =
let! grps = this.SmallGroups.Include(fun sg -> sg.church)
this.SmallGroups.AsNoTracking() .OrderBy(fun sg -> sg.church.name).ThenBy(fun sg -> sg.name)
.Include(fun sg -> sg.church) .ToListAsync ()
.Include(fun sg -> sg.preferences) return groups
.Include(fun sg -> sg.preferences.timeZone) |> Seq.map (fun sg -> sg.smallGroupId.ToString "N", $"{sg.church.name} | {sg.name}")
.OrderBy(fun sg -> sg.name) |> List.ofSeq
.ToListAsync () }
return List.ofSeq grps
}
/// Get a small group list by their Id, with their church prepended to their name /// Log on a small group
member this.GroupList () = member this.TryGroupLogOnByPassword gId pw = backgroundTask {
task { match! this.TryGroupById gId with
let q = | None -> return None
query { | Some grp -> return if pw = grp.preferences.groupPassword then Some grp else None
for grp in this.SmallGroups.AsNoTracking().Include (fun sg -> sg.church) do }
sortBy grp.church.name
thenBy grp.name
}
let! grps = q.ToListAsync ()
return grps
|> Seq.map (fun grp -> grp.smallGroupId.ToString "N", $"{grp.church.name} | {grp.name}")
|> List.ofSeq
}
/// Log on a small group /// Check a cookie log on for a small group
member this.TryGroupLogOnByPassword gId pw = member this.TryGroupLogOnByCookie gId pwHash (hasher : string -> string) = backgroundTask {
task { match! this.TryGroupById gId with
match! this.TryGroupById gId with | None -> return None
| None -> return None | Some grp -> return if pwHash = hasher grp.preferences.groupPassword then Some grp else None
| Some grp -> }
match pw = grp.preferences.groupPassword with
| true -> return Some grp
| _ -> return None
}
/// Check a cookie log on for a small group /// Count small groups for the given church Id
member this.TryGroupLogOnByCookie gId pwHash (hasher : string -> string) = member this.CountGroupsByChurch cId = backgroundTask {
task { return! this.SmallGroups.CountAsync (fun sg -> sg.churchId = cId)
match! this.TryGroupById gId with }
| None -> return None
| Some grp -> (*-- TIME ZONE EXTENSIONS --*)
match pwHash = hasher grp.preferences.groupPassword with
| true -> return Some grp
| _ -> return None
}
/// Count small groups for the given church Id /// Get a time zone by its Id
member this.CountGroupsByChurch cId = member this.TryTimeZoneById tzId = backgroundTask {
this.SmallGroups.CountAsync (fun sg -> sg.churchId = cId) let! zone = this.TimeZones.SingleOrDefaultAsync (fun tz -> tz.timeZoneId = tzId)
return Option.fromObject zone
(*-- TIME ZONE EXTENSIONS --*) }
/// Get a time zone by its Id /// Get all time zones
member this.TryTimeZoneById tzId = member this.AllTimeZones () = backgroundTask {
query { let! zones = this.TimeZones.OrderBy(fun tz -> tz.sortOrder).ToListAsync ()
for tz in this.TimeZones do return List.ofSeq zones
where (tz.timeZoneId = tzId) }
exactlyOneOrDefault
} (*-- USER EXTENSIONS --*)
|> toOptionTask
/// Get all time zones /// Find a user by its Id
member this.AllTimeZones () = member this.TryUserById uId = backgroundTask {
task { let! usr = this.Users.SingleOrDefaultAsync (fun u -> u.userId = uId)
let q = return Option.fromObject usr
query { }
for tz in this.TimeZones do
sortBy tz.sortOrder
}
let! tzs = q.ToListAsync ()
return List.ofSeq tzs
}
(*-- USER EXTENSIONS --*)
/// Find a user by its Id /// Find a user by its e-mail address and authorized small group
member this.TryUserById uId = member this.TryUserByEmailAndGroup email gId = backgroundTask {
query { let! usr =
for usr in this.Users.AsNoTracking () do this.Users.SingleOrDefaultAsync (fun u ->
where (usr.userId = uId) u.emailAddress = email && u.smallGroups.Any (fun xref -> xref.smallGroupId = gId))
exactlyOneOrDefault return Option.fromObject usr
} }
|> toOptionTask
/// Find a user by its Id, eagerly loading the user's groups
member this.TryUserByIdWithGroups uId = backgroundTask {
let! usr = this.Users.Include(fun u -> u.smallGroups).SingleOrDefaultAsync (fun u -> u.userId = uId)
return Option.fromObject usr
}
/// Find a user by its e-mail address and authorized small group /// Get a list of all users
member this.TryUserByEmailAndGroup email gId = member this.AllUsers () = backgroundTask {
query { let! users = this.Users.OrderBy(fun u -> u.lastName).ThenBy(fun u -> u.firstName).ToListAsync ()
for usr in this.Users.AsNoTracking () do return List.ofSeq users
where (usr.emailAddress = email && usr.smallGroups.Any (fun xref -> xref.smallGroupId = gId)) }
exactlyOneOrDefault
}
|> toOptionTask
/// Find a user by its Id (tracked entity), eagerly loading the user's groups /// Get all PrayerTracker users as members (used to send e-mails)
member this.TryUserByIdWithGroups uId = member this.AllUsersAsMembers () = backgroundTask {
query { let! users = this.AllUsers ()
for usr in this.Users.AsNoTracking().Include (fun u -> u.smallGroups) do return users |> List.map (fun u -> { Member.empty with email = u.emailAddress; memberName = u.fullName })
where (usr.userId = uId) }
exactlyOneOrDefault
}
|> toOptionTask
/// Get a list of all users /// Find a user based on their credentials
member this.AllUsers () = member this.TryUserLogOnByPassword email pwHash gId = backgroundTask {
task { let! usr =
let q = this.Users.SingleOrDefaultAsync (fun u ->
query { u.emailAddress = email
for usr in this.Users.AsNoTracking () do && u.passwordHash = pwHash
sortBy usr.lastName && u.smallGroups.Any (fun xref -> xref.smallGroupId = gId))
thenBy usr.firstName return Option.fromObject usr
} }
let! usrs = q.ToListAsync ()
return List.ofSeq usrs
}
/// Get all PrayerTracker users as members (used to send e-mails) /// Find a user based on credentials stored in a cookie
member this.AllUsersAsMembers () = member this.TryUserLogOnByCookie uId gId pwHash = backgroundTask {
task { match! this.TryUserByIdWithGroups uId with
let q = | None -> return None
query { | Some usr ->
for usr in this.Users.AsNoTracking () do if pwHash = usr.passwordHash && usr.smallGroups |> Seq.exists (fun xref -> xref.smallGroupId = gId) then
sortBy usr.lastName return Some { usr with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }
thenBy usr.firstName else return None
select { Member.empty with email = usr.emailAddress; memberName = usr.fullName } }
}
let! usrs = q.ToListAsync ()
return List.ofSeq usrs
}
/// Find a user based on their credentials /// Count the number of users for a small group
member this.TryUserLogOnByPassword email pwHash gId = member this.CountUsersBySmallGroup gId = backgroundTask {
query { return! this.Users.CountAsync (fun u -> u.smallGroups.Any (fun xref -> xref.smallGroupId = gId))
for usr in this.Users.AsNoTracking () do }
where ( usr.emailAddress = email
&& usr.passwordHash = pwHash
&& usr.smallGroups.Any (fun xref -> xref.smallGroupId = gId))
exactlyOneOrDefault
}
|> toOptionTask
/// Find a user based on credentials stored in a cookie /// Count the number of users for a church
member this.TryUserLogOnByCookie uId gId pwHash = member this.CountUsersByChurch cId = backgroundTask {
task { return! this.Users.CountAsync (fun u -> u.smallGroups.Any (fun xref -> xref.smallGroup.churchId = cId))
match! this.TryUserByIdWithGroups uId with }
| None -> return None
| Some usr ->
match pwHash = usr.passwordHash && usr.smallGroups |> Seq.exists (fun xref -> xref.smallGroupId = gId) with
| true ->
this.Entry<User>(usr).State <- EntityState.Detached
return Some { usr with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }
| _ -> return None
}
/// Count the number of users for a small group
member this.CountUsersBySmallGroup gId =
this.Users.CountAsync (fun u -> u.smallGroups.Any (fun xref -> xref.smallGroupId = gId))
/// Count the number of users for a church
member this.CountUsersByChurch cId =
this.Users.CountAsync (fun u -> u.smallGroups.Any (fun xref -> xref.smallGroup.churchId = cId))

1232
src/PrayerTracker.Data/Entities.fs
View File

File diff suppressed because it is too large Load Diff

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

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

313
src/PrayerTracker.Tests/UI/UtilsTests.fs
View File

@ -5,189 +5,192 @@ open PrayerTracker
[<Tests>] [<Tests>]
let ckEditorToTextTests = let ckEditorToTextTests =
testList "ckEditorToText" [ testList "ckEditorToText" [
test "replaces newline/tab sequence with nothing" { test "replaces newline/tab sequence with nothing" {
Expect.equal (ckEditorToText "Here is some \n\ttext") "Here is some text" Expect.equal (ckEditorToText "Here is some \n\ttext") "Here is some text"
"Newline/tab sequence should have been removed" "Newline/tab sequence should have been removed"
} }
test "replaces &nbsp; with a space" { test "replaces &nbsp; with a space" {
Expect.equal (ckEditorToText "Test&nbsp;text") "Test text" "&nbsp; should have been replaced with a space" Expect.equal (ckEditorToText "Test&nbsp;text") "Test text" "&nbsp; should have been replaced with a space"
} }
test "replaces double space with one non-breaking space and one regular space" { test "replaces double space with one non-breaking space and one regular space" {
Expect.equal (ckEditorToText "Test text") "Test&#xa0; text" Expect.equal (ckEditorToText "Test text") "Test&#xa0; text"
"double space should have been replaced with one non-breaking space and one regular space" "double space should have been replaced with one non-breaking space and one regular space"
} }
test "replaces paragraph break with two line breaks" { test "replaces paragraph break with two line breaks" {
Expect.equal (ckEditorToText "some</p><p>text") "some<br><br>text" Expect.equal (ckEditorToText "some</p><p>text") "some<br><br>text"
"paragraph break should have been replaced with two line breaks" "paragraph break should have been replaced with two line breaks"
} }
test "removes start and end paragraph tags" { test "removes start and end paragraph tags" {
Expect.equal (ckEditorToText "<p>something something</p>") "something something" Expect.equal (ckEditorToText "<p>something something</p>") "something something"
"start/end paragraph tags should have been removed" "start/end paragraph tags should have been removed"
} }
test "trims the result" { test "trims the result" {
Expect.equal (ckEditorToText " abc ") "abc" "Should have trimmed the resulting text" Expect.equal (ckEditorToText " abc ") "abc" "Should have trimmed the resulting text"
} }
test "does all the replacements and removals at one time" { test "does all the replacements and removals at one time" {
Expect.equal (ckEditorToText " <p>Paragraph&nbsp;1\n\t line two</p><p>Paragraph 2 x</p>") Expect.equal (ckEditorToText " <p>Paragraph&nbsp;1\n\t line two</p><p>Paragraph 2 x</p>")
"Paragraph 1 line two<br><br>Paragraph 2&#xa0; x" "Paragraph 1 line two<br><br>Paragraph 2&#xa0; x"
"all replacements and removals were not made correctly" "all replacements and removals were not made correctly"
} }
] ]
[<Tests>] [<Tests>]
let htmlToPlainTextTests = let htmlToPlainTextTests =
testList "htmlToPlainText" [ testList "htmlToPlainText" [
test "decodes HTML-encoded entities" { test "decodes HTML-encoded entities" {
Expect.equal (htmlToPlainText "1 &gt; 0") "1 > 0" "HTML-encoded entities should have been decoded" Expect.equal (htmlToPlainText "1 &gt; 0") "1 > 0" "HTML-encoded entities should have been decoded"
} }
test "trims the input HTML" { test "trims the input HTML" {
Expect.equal (htmlToPlainText " howdy ") "howdy" "HTML input string should have been trimmed" Expect.equal (htmlToPlainText " howdy ") "howdy" "HTML input string should have been trimmed"
} }
test "replaces line breaks with new lines" { test "replaces line breaks with new lines" {
Expect.equal (htmlToPlainText "Lots<br>of<br />new<br>lines") "Lots\nof\nnew\nlines" Expect.equal (htmlToPlainText "Lots<br>of<br />new<br>lines") "Lots\nof\nnew\nlines"
"Break tags should have been converted to newline characters" "Break tags should have been converted to newline characters"
} }
test "replaces non-breaking spaces with spaces" { test "replaces non-breaking spaces with spaces" {
Expect.equal (htmlToPlainText "Here&nbsp;is&#xa0;some&nbsp;more&#xa0;text") "Here is some more text" Expect.equal (htmlToPlainText "Here&nbsp;is&#xa0;some&nbsp;more&#xa0;text") "Here is some more text"
"Non-breaking spaces should have been replaced with spaces" "Non-breaking spaces should have been replaced with spaces"
} }
test "does all replacements at one time" { test "does all replacements at one time" {
Expect.equal (htmlToPlainText " &lt;&nbsp;&lt;<br>test") "< <\ntest" "All replacements were not made correctly" Expect.equal (htmlToPlainText " &lt;&nbsp;&lt;<br>test") "< <\ntest"
} "All replacements were not made correctly"
test "does not fail when passed null" { }
Expect.equal (htmlToPlainText null) "" "Should return an empty string for null input" test "does not fail when passed null" {
} Expect.equal (htmlToPlainText null) "" "Should return an empty string for null input"
test "does not fail when passed an empty string" { }
Expect.equal (htmlToPlainText "") "" "Should return an empty string when given an empty string" test "does not fail when passed an empty string" {
} Expect.equal (htmlToPlainText "") "" "Should return an empty string when given an empty string"
test "preserves blank lines for two consecutive line breaks" { }
let expected = "Paragraph 1\n\nParagraph 2\n\n...and paragraph 3" test "preserves blank lines for two consecutive line breaks" {
Expect.equal (htmlToPlainText "Paragraph 1<br><br>Paragraph 2<br><br>...and <strong>paragraph</strong> <i>3</i>") let expected = "Paragraph 1\n\nParagraph 2\n\n...and paragraph 3"
expected "Blank lines not preserved for consecutive line breaks" Expect.equal
} (htmlToPlainText "Paragraph 1<br><br>Paragraph 2<br><br>...and <strong>paragraph</strong> <i>3</i>")
expected "Blank lines not preserved for consecutive line breaks"
}
] ]
[<Tests>] [<Tests>]
let makeUrlTests = let makeUrlTests =
testList "makeUrl" [ testList "makeUrl" [
test "returns the URL when there are no parameters" { test "returns the URL when there are no parameters" {
Expect.equal (makeUrl "/test" []) "/test" "The URL should not have had any query string parameters added" Expect.equal (makeUrl "/test" []) "/test" "The URL should not have had any query string parameters added"
} }
test "returns the URL with one query string parameter" { test "returns the URL with one query string parameter" {
Expect.equal (makeUrl "/test" [ "unit", "true" ]) "/test?unit=true" "The URL was not constructed properly" Expect.equal (makeUrl "/test" [ "unit", "true" ]) "/test?unit=true" "The URL was not constructed properly"
} }
test "returns the URL with multiple encoded query string parameters" { test "returns the URL with multiple encoded query string parameters" {
let url = makeUrl "/test" [ "space", "a space"; "turkey", "=" ] let url = makeUrl "/test" [ "space", "a space"; "turkey", "=" ]
Expect.equal url "/test?space=a+space&turkey=%3D" "The URL was not constructed properly" Expect.equal url "/test?space=a+space&turkey=%3D" "The URL was not constructed properly"
} }
] ]
[<Tests>] [<Tests>]
let sndAsStringTests = let sndAsStringTests =
testList "sndAsString" [ testList "sndAsString" [
test "converts the second item to a string" { test "converts the second item to a string" {
Expect.equal (sndAsString ("a", 5)) "5" "The second part of the tuple should have been converted to a string" Expect.equal (sndAsString ("a", 5)) "5"
} "The second part of the tuple should have been converted to a string"
}
] ]
module StringTests = module StringTests =
open PrayerTracker.Utils.String open PrayerTracker.Utils.String
[<Tests>] [<Tests>]
let replaceFirstTests = let replaceFirstTests =
testList "String.replaceFirst" [ testList "String.replaceFirst" [
test "replaces the first occurrence when it is found at the beginning of the string" { test "replaces the first occurrence when it is found at the beginning of the string" {
let testString = "unit unit unit" let testString = "unit unit unit"
Expect.equal (replaceFirst "unit" "test" testString) "test unit unit" Expect.equal (replaceFirst "unit" "test" testString) "test unit unit"
"First occurrence of a substring was not replaced properly at the beginning of the string" "First occurrence of a substring was not replaced properly at the beginning of the string"
} }
test "replaces the first occurrence when it is found in the center of the string" { test "replaces the first occurrence when it is found in the center of the string" {
let testString = "test unit test" let testString = "test unit test"
Expect.equal (replaceFirst "unit" "test" testString) "test test test" Expect.equal (replaceFirst "unit" "test" testString) "test test test"
"First occurrence of a substring was not replaced properly when it is in the center of the string" "First occurrence of a substring was not replaced properly when it is in the center of the string"
} }
test "returns the original string if the replacement isn't found" { test "returns the original string if the replacement isn't found" {
let testString = "unit tests" let testString = "unit tests"
Expect.equal (replaceFirst "tested" "testing" testString) "unit tests" Expect.equal (replaceFirst "tested" "testing" testString) "unit tests"
"String which did not have the target substring was not returned properly" "String which did not have the target substring was not returned properly"
} }
] ]
[<Tests>] [<Tests>]
let replaceTests = let replaceTests =
testList "String.replace" [ testList "String.replace" [
test "succeeds" { test "succeeds" {
Expect.equal (replace "a" "b" "abacab") "bbbcbb" "String did not replace properly" Expect.equal (replace "a" "b" "abacab") "bbbcbb" "String did not replace properly"
} }
] ]
[<Tests>] [<Tests>]
let trimTests = let trimTests =
testList "String.trim" [ testList "String.trim" [
test "succeeds" { test "succeeds" {
Expect.equal (trim " abc ") "abc" "Space not trimmed from string properly" Expect.equal (trim " abc ") "abc" "Space not trimmed from string properly"
} }
] ]
[<Tests>] [<Tests>]
let stripTagsTests = let stripTagsTests =
let testString = "<p class=\"testing\">Here is some text<br> <br />and some more</p>" let testString = "<p class=\"testing\">Here is some text<br> <br />and some more</p>"
testList "stripTags" [ testList "stripTags" [
test "does nothing if all tags are allowed" { test "does nothing if all tags are allowed" {
Expect.equal (stripTags [ "p"; "br" ] testString) testString Expect.equal (stripTags [ "p"; "br" ] testString) testString
"There should have been no replacements in the target string" "There should have been no replacements in the target string"
} }
test "strips the start/end tag for non allowed tag" { test "strips the start/end tag for non allowed tag" {
Expect.equal (stripTags [ "br" ] testString) "Here is some text<br> <br />and some more" Expect.equal (stripTags [ "br" ] testString) "Here is some text<br> <br />and some more"
"There should have been no \"p\" tag, but all \"br\" tags, in the returned string" "There should have been no \"p\" tag, but all \"br\" tags, in the returned string"
} }
test "strips void/self-closing tags" { test "strips void/self-closing tags" {
Expect.equal (stripTags [] testString) "Here is some text and some more" Expect.equal (stripTags [] testString) "Here is some text and some more"
"There should have been no tags; all void and self-closing tags should have been stripped" "There should have been no tags; all void and self-closing tags should have been stripped"
} }
] ]
[<Tests>] [<Tests>]
let wordWrapTests = let wordWrapTests =
testList "wordWrap" [ testList "wordWrap" [
test "breaks where it is supposed to" { test "breaks where it is supposed to" {
let testString = "The quick brown fox jumps over the lazy dog\nIt does!" let testString = "The quick brown fox jumps over the lazy dog\nIt does!"
Expect.equal (wordWrap 20 testString) "The quick brown fox\njumps over the lazy\ndog\nIt does!\n" Expect.equal (wordWrap 20 testString) "The quick brown fox\njumps over the lazy\ndog\nIt does!\n"
"Line not broken correctly" "Line not broken correctly"
} }
test "wraps long line without a space" { test "wraps long line without a space" {
let testString = "Asamatteroffact, the dog does too" let testString = "Asamatteroffact, the dog does too"
Expect.equal (wordWrap 10 testString) "Asamattero\nffact, the\ndog does\ntoo\n" Expect.equal (wordWrap 10 testString) "Asamattero\nffact, the\ndog does\ntoo\n"
"Longer line not broken correctly" "Longer line not broken correctly"
} }
test "preserves blank lines" { test "preserves blank lines" {
let testString = "Here is\n\na string with blank lines" let testString = "Here is\n\na string with blank lines"
Expect.equal (wordWrap 80 testString) testString "Blank lines were not preserved" Expect.equal (wordWrap 80 testString) testString "Blank lines were not preserved"
} }
] ]
[<Tests>] [<Tests>]
let wordWrapBTests = let wordWrapBTests =
testList "wordWrapB" [ testList "wordWrapB" [
test "breaks where it is supposed to" { test "breaks where it is supposed to" {
let testString = "The quick brown fox jumps over the lazy dog\nIt does!" let testString = "The quick brown fox jumps over the lazy dog\nIt does!"
Expect.equal (wordWrap 20 testString) "The quick brown fox\njumps over the lazy\ndog\nIt does!\n" Expect.equal (wordWrap 20 testString) "The quick brown fox\njumps over the lazy\ndog\nIt does!\n"
"Line not broken correctly" "Line not broken correctly"
} }
test "wraps long line without a space and a line with exact length" { test "wraps long line without a space and a line with exact length" {
let testString = "Asamatteroffact, the dog does too" let testString = "Asamatteroffact, the dog does too"
Expect.equal (wordWrap 10 testString) "Asamattero\nffact, the\ndog does\ntoo\n" Expect.equal (wordWrap 10 testString) "Asamattero\nffact, the\ndog does\ntoo\n"
"Longer line not broken correctly" "Longer line not broken correctly"
} }
test "wraps long line without a space and a line with non-exact length" { test "wraps long line without a space and a line with non-exact length" {
let testString = "Asamatteroffact, that dog does too" let testString = "Asamatteroffact, that dog does too"
Expect.equal (wordWrap 10 testString) "Asamattero\nffact,\nthat dog\ndoes too\n" Expect.equal (wordWrap 10 testString) "Asamattero\nffact,\nthat dog\ndoes too\n"
"Longer line not broken correctly" "Longer line not broken correctly"
} }
test "preserves blank lines" { test "preserves blank lines" {
let testString = "Here is\n\na string with blank lines" let testString = "Here is\n\na string with blank lines"
Expect.equal (wordWrap 80 testString) testString "Blank lines were not preserved" Expect.equal (wordWrap 80 testString) testString "Blank lines were not preserved"
} }
] ]

183
src/PrayerTracker.UI/Church.fs
View File

@ -6,104 +6,107 @@ open PrayerTracker.ViewModels
/// View for the church edit page /// View for the church edit page
let edit (m : EditChurch) ctx vi = let edit (m : EditChurch) ctx vi =
let pageTitle = match m.isNew () with true -> "Add a New Church" | false -> "Edit Church" let pageTitle = match m.isNew () with true -> "Add a New Church" | false -> "Edit Church"
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
[ form [ _action "/web/church/save"; _method "post"; _class "pt-center-columns" ] [ [ form [ _action "/web/church/save"; _method "post"; _class "pt-center-columns" ] [
style [ _scoped ] style [ _scoped ] [
[ rawText "#name { width: 20rem; } #city { width: 10rem; } #st { width: 3rem; } #interfaceAddress { width: 30rem; }" ] rawText "#name { width: 20rem; } #city { width: 10rem; } #st { width: 3rem; } #interfaceAddress { width: 30rem; }"
csrfToken ctx
input [ _type "hidden"; _name "churchId"; _value (flatGuid m.churchId) ]
div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [
label [ _for "name" ] [ locStr s.["Church Name"] ]
input [ _type "text"; _name "name"; _id "name"; _required; _autofocus; _value m.name ]
]
div [ _class "pt-field" ] [
label [ _for "City"] [ locStr s.["City"] ]
input [ _type "text"; _name "city"; _id "city"; _required; _value m.city ]
]
div [ _class "pt-field" ] [
label [ _for "ST" ] [ locStr s.["State"] ]
input [ _type "text"; _name "st"; _id "st"; _required; _minlength "2"; _maxlength "2"; _value m.st ]
]
] ]
div [ _class "pt-field-row" ] [ csrfToken ctx
div [ _class "pt-checkbox-field" ] [ input [ _type "hidden"; _name "churchId"; _value (flatGuid m.churchId) ]
input [ _type "checkbox" div [ _class "pt-field-row" ] [
_name "hasInterface" div [ _class "pt-field" ] [
_id "hasInterface" label [ _for "name" ] [ locStr s["Church Name"] ]
_value "True" input [ _type "text"; _name "name"; _id "name"; _required; _autofocus; _value m.name ]
match m.hasInterface with Some x when x -> _checked | _ -> () ] ]
label [ _for "hasInterface" ] [ locStr s.["Has an interface with Virtual Prayer Room"] ] div [ _class "pt-field" ] [
] label [ _for "City"] [ locStr s["City"] ]
input [ _type "text"; _name "city"; _id "city"; _required; _value m.city ]
]
div [ _class "pt-field" ] [
label [ _for "ST" ] [ locStr s["State"] ]
input [ _type "text"; _name "st"; _id "st"; _required; _minlength "2"; _maxlength "2"; _value m.st ]
]
] ]
div [ _class "pt-field-row pt-fadeable"; _id "divInterfaceAddress" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [ div [ _class "pt-checkbox-field" ] [
label [ _for "interfaceAddress" ] [ locStr s.["VPR Interface URL"] ] input [ _type "checkbox"
input [ _type "url"; _name "interfaceAddress"; _id "interfaceAddress"; _name "hasInterface"
_value (match m.interfaceAddress with Some ia -> ia | None -> "") ] _id "hasInterface"
] _value "True"
match m.hasInterface with Some x when x -> _checked | _ -> () ]
label [ _for "hasInterface" ] [ locStr s["Has an interface with Virtual Prayer Room"] ]
]
] ]
div [ _class "pt-field-row" ] [ submit [] "save" s.["Save Church"] ] div [ _class "pt-field-row pt-fadeable"; _id "divInterfaceAddress" ] [
] div [ _class "pt-field" ] [
script [] [ rawText "PT.onLoad(PT.church.edit.onPageLoad)" ] label [ _for "interfaceAddress" ] [ locStr s["VPR Interface URL"] ]
input
[ _type "url"; _name "interfaceAddress"; _id "interfaceAddress";
_value (match m.interfaceAddress with Some ia -> ia | None -> "")
]
]
]
div [ _class "pt-field-row" ] [ submit [] "save" s["Save Church"] ]
]
script [] [ rawText "PT.onLoad(PT.church.edit.onPageLoad)" ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi pageTitle |> Layout.standard vi pageTitle
/// View for church maintenance page /// View for church maintenance page
let maintain (churches : Church list) (stats : Map<string, ChurchStats>) ctx vi = let maintain (churches : Church list) (stats : Map<string, ChurchStats>) ctx vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let chTbl = let chTbl =
match churches with match churches with
| [] -> space | [] -> space
| _ -> | _ ->
table [ _class "pt-table pt-action-table" ] [ table [ _class "pt-table pt-action-table" ] [
thead [] [ thead [] [
tr [] [ tr [] [
th [] [ locStr s.["Actions"] ] th [] [ locStr s["Actions"] ]
th [] [ locStr s.["Name"] ] th [] [ locStr s["Name"] ]
th [] [ locStr s.["Location"] ] th [] [ locStr s["Location"] ]
th [] [ locStr s.["Groups"] ] th [] [ locStr s["Groups"] ]
th [] [ locStr s.["Requests"] ] th [] [ locStr s["Requests"] ]
th [] [ locStr s.["Users"] ] th [] [ locStr s["Users"] ]
th [] [ locStr s.["Interface?"] ] th [] [ locStr s["Interface?"] ]
] ]
]
churches
|> List.map (fun ch ->
let chId = flatGuid ch.churchId
let delAction = $"/web/church/{chId}/delete"
let delPrompt = s["Are you sure you want to delete this {0}? This action cannot be undone.",
$"""{s["Church"].Value.ToLower ()} ({ch.name})"""]
tr [] [
td [] [
a [ _href $"/web/church/{chId}/edit"; _title s["Edit This Church"].Value ] [ icon "edit" ]
a [ _href delAction
_title s["Delete This Church"].Value
_onclick $"return PT.confirmDelete('{delAction}','{delPrompt}')" ]
[ icon "delete_forever" ]
]
td [] [ str ch.name ]
td [] [ str ch.city; rawText ", "; str ch.st ]
td [ _class "pt-right-text" ] [ rawText (stats[chId].smallGroups.ToString "N0") ]
td [ _class "pt-right-text" ] [ rawText (stats[chId].prayerRequests.ToString "N0") ]
td [ _class "pt-right-text" ] [ rawText (stats[chId].users.ToString "N0") ]
td [ _class "pt-center-text" ] [ locStr s[if ch.hasInterface then "Yes" else "No"] ]
])
|> tbody []
] ]
churches [ div [ _class "pt-center-text" ] [
|> List.map (fun ch -> br []
let chId = flatGuid ch.churchId a [ _href $"/web/church/{emptyGuid}/edit"; _title s["Add a New Church"].Value ]
let delAction = $"/web/church/{chId}/delete" [ icon "add_circle"; rawText " &nbsp;"; locStr s["Add a New Church"] ]
let delPrompt = s.["Are you sure you want to delete this {0}? This action cannot be undone.", br []
$"""{s.["Church"].Value.ToLower ()} ({ch.name})"""] br []
tr [] [
td [] [
a [ _href $"/web/church/{chId}/edit"; _title s.["Edit This Church"].Value ] [ icon "edit" ]
a [ _href delAction
_title s.["Delete This Church"].Value
_onclick $"return PT.confirmDelete('{delAction}','{delPrompt}')" ]
[ icon "delete_forever" ]
]
td [] [ str ch.name ]
td [] [ str ch.city; rawText ", "; str ch.st ]
td [ _class "pt-right-text" ] [ rawText (stats.[chId].smallGroups.ToString "N0") ]
td [ _class "pt-right-text" ] [ rawText (stats.[chId].prayerRequests.ToString "N0") ]
td [ _class "pt-right-text" ] [ rawText (stats.[chId].users.ToString "N0") ]
td [ _class "pt-center-text" ] [ locStr s.[match ch.hasInterface with true -> "Yes" | false -> "No"] ]
])
|> tbody []
]
[ div [ _class "pt-center-text" ] [
br []
a [ _href $"/web/church/{emptyGuid}/edit"; _title s.["Add a New Church"].Value ]
[ icon "add_circle"; rawText " &nbsp;"; locStr s.["Add a New Church"] ]
br []
br []
] ]
tableSummary churches.Length s tableSummary churches.Length s
chTbl chTbl
form [ _id "DeleteForm"; _action ""; _method "post" ] [ csrfToken ctx ] form [ _id "DeleteForm"; _action ""; _method "post" ] [ csrfToken ctx ]
] ]
|> Layout.Content.wide |> Layout.Content.wide
|> Layout.standard vi "Maintain Churches" |> Layout.standard vi "Maintain Churches"

146
src/PrayerTracker.UI/CommonFunctions.fs
View File

@ -1,26 +1,24 @@
[<AutoOpen>] [<AutoOpen>]
module PrayerTracker.Views.CommonFunctions module PrayerTracker.Views.CommonFunctions
open System.IO
open System.Text.Encodings.Web
open Giraffe open Giraffe
open Giraffe.ViewEngine open Giraffe.ViewEngine
open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Antiforgery
open Microsoft.AspNetCore.Html
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Mvc.Localization open Microsoft.AspNetCore.Mvc.Localization
open Microsoft.Extensions.Localization open Microsoft.Extensions.Localization
open System
open System.IO
open System.Text.Encodings.Web
/// Encoded text for a localized string /// Encoded text for a localized string
let locStr (text : LocalizedString) = str text.Value let locStr (text : LocalizedString) = str text.Value
/// Raw text for a localized HTML string /// Raw text for a localized HTML string
let rawLocText (writer : StringWriter) (text : LocalizedHtmlString) = let rawLocText (writer : StringWriter) (text : LocalizedHtmlString) =
text.WriteTo (writer, HtmlEncoder.Default) text.WriteTo (writer, HtmlEncoder.Default)
let txt = string writer let txt = string writer
writer.GetStringBuilder().Clear () |> ignore writer.GetStringBuilder().Clear () |> ignore
rawText txt rawText txt
/// A space (used for back-to-back localization string breaks) /// A space (used for back-to-back localization string breaks)
let space = rawText " " let space = rawText " "
@ -33,69 +31,73 @@ let iconSized size name = i [ _class $"material-icons md-{size}" ] [ rawText nam
/// Generate a CSRF prevention token /// Generate a CSRF prevention token
let csrfToken (ctx : HttpContext) = let csrfToken (ctx : HttpContext) =
let antiForgery = ctx.GetService<IAntiforgery> () let antiForgery = ctx.GetService<IAntiforgery> ()
let tokenSet = antiForgery.GetAndStoreTokens ctx let tokenSet = antiForgery.GetAndStoreTokens ctx
input [ _type "hidden"; _name tokenSet.FormFieldName; _value tokenSet.RequestToken ] input [ _type "hidden"; _name tokenSet.FormFieldName; _value tokenSet.RequestToken ]
/// Create a summary for a table of items /// Create a summary for a table of items
let tableSummary itemCount (s : IStringLocalizer) = let tableSummary itemCount (s : IStringLocalizer) =
div [ _class "pt-center-text" ] [ div [ _class "pt-center-text" ] [
small [] [ small [] [
match itemCount with match itemCount with
| 0 -> s.["No Entries to Display"] | 0 -> s["No Entries to Display"]
| 1 -> s.["Displaying {0} Entry", itemCount] | 1 -> s["Displaying {0} Entry", itemCount]
| _ -> s.["Displaying {0} Entries", itemCount] | _ -> s["Displaying {0} Entries", itemCount]
|> locStr |> locStr
] ]
] ]
/// Generate a list of named HTML colors /// Generate a list of named HTML colors
let namedColorList name selected attrs (s : IStringLocalizer) = let namedColorList name selected attrs (s : IStringLocalizer) =
/// The list of HTML named colors (name, display, text color) // The list of HTML named colors (name, display, text color)
seq { seq {
("aqua", s.["Aqua"], "black") ("aqua", s["Aqua"], "black")
("black", s.["Black"], "white") ("black", s["Black"], "white")
("blue", s.["Blue"], "white") ("blue", s["Blue"], "white")
("fuchsia", s.["Fuchsia"], "black") ("fuchsia", s["Fuchsia"], "black")
("gray", s.["Gray"], "white") ("gray", s["Gray"], "white")
("green", s.["Green"], "white") ("green", s["Green"], "white")
("lime", s.["Lime"], "black") ("lime", s["Lime"], "black")
("maroon", s.["Maroon"], "white") ("maroon", s["Maroon"], "white")
("navy", s.["Navy"], "white") ("navy", s["Navy"], "white")
("olive", s.["Olive"], "white") ("olive", s["Olive"], "white")
("purple", s.["Purple"], "white") ("purple", s["Purple"], "white")
("red", s.["Red"], "black") ("red", s["Red"], "black")
("silver", s.["Silver"], "black") ("silver", s["Silver"], "black")
("teal", s.["Teal"], "white") ("teal", s["Teal"], "white")
("white", s.["White"], "black") ("white", s["White"], "black")
("yellow", s.["Yellow"], "black") ("yellow", s["Yellow"], "black")
} }
|> Seq.map (fun color -> |> Seq.map (fun color ->
let (colorName, dispText, txtColor) = color let colorName, text, txtColor = color
option [ yield _value colorName option
yield _style $"background-color:{colorName};color:{txtColor};" [ _value colorName
match colorName = selected with true -> yield _selected | false -> () ] [ _style $"background-color:{colorName};color:{txtColor};"
encodedText (dispText.Value.ToLower ()) if colorName = selected then _selected
]) ] [ encodedText (text.Value.ToLower ()) ])
|> List.ofSeq |> List.ofSeq
|> select (_name name :: attrs) |> select (_name name :: attrs)
/// Generate an input[type=radio] that is selected if its value is the current value /// Generate an input[type=radio] that is selected if its value is the current value
let radio name domId value current = let radio name domId value current =
input [ _type "radio" input
[ _type "radio"
_name name _name name
_id domId _id domId
_value value _value value
match value = current with true -> _checked | false -> () ] if value = current then _checked
]
/// Generate a select list with the current value selected /// Generate a select list with the current value selected
let selectList name selected attrs items = let selectList name selected attrs items =
items items
|> Seq.map (fun (value, text) -> |> Seq.map (fun (value, text) ->
option [ _value value option
match value = selected with true -> _selected | false -> () ] [ encodedText text ]) [ _value value
|> List.ofSeq if value = selected then _selected
|> select (List.concat [ [ _name name; _id name ]; attrs ]) ] [ encodedText text ])
|> List.ofSeq
|> select (List.concat [ [ _name name; _id name ]; attrs ])
/// Generate the text for a default entry at the top of a select list /// Generate the text for a default entry at the top of a select list
let selectDefault text = $"— {text} —" let selectDefault text = $"— {text} —"
@ -103,6 +105,9 @@ let selectDefault text = $"— {text} —"
/// Generate a standard submit button with icon and text /// Generate a standard submit button with icon and text
let submit attrs ico text = button (_type "submit" :: attrs) [ icon ico; rawText " &nbsp;"; locStr text ] let submit attrs ico text = button (_type "submit" :: attrs) [ icon ico; rawText " &nbsp;"; locStr text ]
open System
/// Format a GUID with no dashes (used for URLs and forms) /// Format a GUID with no dashes (used for URLs and forms)
let flatGuid (x : Guid) = x.ToString "N" let flatGuid (x : Guid) = x.ToString "N"
@ -129,6 +134,9 @@ let _scoped = flag "scoped"
/// The name this function used to have when the view engine was part of Giraffe /// The name this function used to have when the view engine was part of Giraffe
let renderHtmlNode = RenderView.AsString.htmlNode let renderHtmlNode = RenderView.AsString.htmlNode
open Microsoft.AspNetCore.Html
/// Render an HTML node, then return the value as an HTML string /// Render an HTML node, then return the value as an HTML string
let renderHtmlString = renderHtmlNode >> HtmlString let renderHtmlString = renderHtmlNode >> HtmlString
@ -136,20 +144,20 @@ let renderHtmlString = renderHtmlNode >> HtmlString
/// Utility methods to help with time zones (and localization of their names) /// Utility methods to help with time zones (and localization of their names)
module TimeZones = module TimeZones =
open System.Collections.Generic open System.Collections.Generic
/// Cross-reference between time zone Ids and their English names /// Cross-reference between time zone Ids and their English names
let private xref = let private xref =
[ "America/Chicago", "Central" [ "America/Chicago", "Central"
"America/Denver", "Mountain" "America/Denver", "Mountain"
"America/Los_Angeles", "Pacific" "America/Los_Angeles", "Pacific"
"America/New_York", "Eastern" "America/New_York", "Eastern"
"America/Phoenix", "Mountain (Arizona)" "America/Phoenix", "Mountain (Arizona)"
"Europe/Berlin", "Central European" "Europe/Berlin", "Central European"
] ]
|> Map.ofList |> Map.ofList
/// Get the name of a time zone, given its Id /// Get the name of a time zone, given its Id
let name tzId (s : IStringLocalizer) = let name tzId (s : IStringLocalizer) =
try s.[xref.[tzId]] try s[xref[tzId]]
with :? KeyNotFoundException -> LocalizedString (tzId, tzId) with :? KeyNotFoundException -> LocalizedString (tzId, tzId)

421
src/PrayerTracker.UI/Home.fs
View File

@ -1,262 +1,261 @@
/// Views associated with the home page, or those that don't fit anywhere else /// Views associated with the home page, or those that don't fit anywhere else
module PrayerTracker.Views.Home module PrayerTracker.Views.Home
open Giraffe.ViewEngine
open Microsoft.AspNetCore.Html
open PrayerTracker.ViewModels
open System.IO open System.IO
open Giraffe.ViewEngine
open PrayerTracker.ViewModels
/// The error page /// The error page
let error code vi = let error code vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let l = I18N.forView "Home/Error" let l = I18N.forView "Home/Error"
use sw = new StringWriter () use sw = new StringWriter ()
let raw = rawLocText sw let raw = rawLocText sw
let is404 = "404" = code let is404 = "404" = code
let pageTitle = match is404 with true -> "Page Not Found" | false -> "Server Error" let pageTitle = if is404 then "Page Not Found" else "Server Error"
[ yield! [ yield!
match is404 with if is404 then
| true -> [ p [] [
[ p [] [ raw l["The page you requested cannot be found."]
raw l.["The page you requested cannot be found."] raw l["Please use your &ldquo;Back&rdquo; button to return to {0}.", s["PrayerTracker"]]
raw l.["Please use your &ldquo;Back&rdquo; button to return to {0}.", s.["PrayerTracker"]]
] ]
p [] [ p [] [
raw l.["If you reached this page from a link within {0}, please copy the link from the browser's address bar, and send it to support, along with the group for which you were currently authenticated (if any).", raw l["If you reached this page from a link within {0}, please copy the link from the browser's address bar, and send it to support, along with the group for which you were currently authenticated (if any).",
s.["PrayerTracker"]] s["PrayerTracker"]]
] ]
] ]
| false -> else
[ p [] [ [ p [] [
raw l.["An error ({0}) has occurred.", code] raw l["An error ({0}) has occurred.", code]
raw l.["Please use your &ldquo;Back&rdquo; button to return to {0}.", s.["PrayerTracker"]] raw l["Please use your &ldquo;Back&rdquo; button to return to {0}.", s["PrayerTracker"]]
] ]
] ]
br [] br []
hr [] hr []
div [ _style "font-size:70%;font-family:-apple-system,BlinkMacSystemFont,'Segoe UI',Roboto,Oxygen-Sans,Ubuntu,Cantarell,'Helvetica Neue',sans-serif" ] [ div [ _style "font-size:70%;font-family:-apple-system,BlinkMacSystemFont,'Segoe UI',Roboto,Oxygen-Sans,Ubuntu,Cantarell,'Helvetica Neue',sans-serif" ] [
img [ _src $"""/img/%A{s.["footer_en"]}.png""" img [ _src $"""/img/%A{s["footer_en"]}.png"""
_alt $"""%A{s.["PrayerTracker"]} %A{s.["from Bit Badger Solutions"]}""" _alt $"""%A{s["PrayerTracker"]} %A{s["from Bit Badger Solutions"]}"""
_title $"""%A{s.["PrayerTracker"]} %A{s.["from Bit Badger Solutions"]}""" _title $"""%A{s["PrayerTracker"]} %A{s["from Bit Badger Solutions"]}"""
_style "vertical-align:text-bottom;" ] _style "vertical-align:text-bottom;" ]
str vi.version str vi.version
] ]
] ]
|> div [] |> div []
|> Layout.bare pageTitle |> Layout.bare pageTitle
/// The home page /// The home page
let index vi = let index vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let l = I18N.forView "Home/Index" let l = I18N.forView "Home/Index"
use sw = new StringWriter () use sw = new StringWriter ()
let raw = rawLocText sw let raw = rawLocText sw
[ p [] [ [ p [] [
raw l.["Welcome to <strong>{0}</strong>!", s.["PrayerTracker"]] raw l["Welcome to <strong>{0}</strong>!", s["PrayerTracker"]]
space space
raw l.["{0} is an interactive website that provides churches, Sunday School classes, and other organizations an easy way to keep up with their prayer requests.", raw l["{0} is an interactive website that provides churches, Sunday School classes, and other organizations an easy way to keep up with their prayer requests.",
s.["PrayerTracker"]] s["PrayerTracker"]]
space space
raw l.["It is provided at no charge, as a ministry and a community service."] raw l["It is provided at no charge, as a ministry and a community service."]
] ]
h4 [] [ raw l.["What Does It Do?"] ] h4 [] [ raw l["What Does It Do?"] ]
p [] [ p [] [
raw l.["{0} has what you need to make maintaining a prayer request list a breeze.", s.["PrayerTracker"]] raw l["{0} has what you need to make maintaining a prayer request list a breeze.", s["PrayerTracker"]]
space space
raw l.["Some of the things it can do..."] raw l["Some of the things it can do..."]
] ]
ul [] [ ul [] [
li [] [ li [] [
raw l.["It drops old requests off the list automatically."] raw l["It drops old requests off the list automatically."]
space space
raw l.["Requests other than “{0}” requests will expire at 14 days, though this can be changed by the organization.", raw l["Requests other than “{0}” requests will expire at 14 days, though this can be changed by the organization.",
s.["Long-Term Requests"]] s["Long-Term Requests"]]
space space
raw l.["This expiration is based on the last update, not the initial request."] raw l["This expiration is based on the last update, not the initial request."]
space space
raw l.["(And, once requests do “drop off”, they are not gone - they may be recovered if needed.)"] raw l["(And, once requests do “drop off”, they are not gone - they may be recovered if needed.)"]
] ]
li [] [ li [] [
raw l.["Requests can be viewed any time."] raw l["Requests can be viewed any time."]
space space
raw l.["Lists can be made public, or they can be secured with a password, if desired."] raw l["Lists can be made public, or they can be secured with a password, if desired."]
] ]
li [] [ li [] [
raw l.["Lists can be e-mailed to a pre-defined list of members."] raw l["Lists can be e-mailed to a pre-defined list of members."]
space space
raw l.["This can be useful for folks who may not be able to write down all the requests during class, but want a list so that they can pray for them the rest of week."] raw l["This can be useful for folks who may not be able to write down all the requests during class, but want a list so that they can pray for them the rest of week."]
space space
raw l.["E-mails are sent individually to each person, which keeps the e-mail list private and keeps the messages from being flagged as spam."] raw l["E-mails are sent individually to each person, which keeps the e-mail list private and keeps the messages from being flagged as spam."]
] ]
li [] [ li [] [
raw l.["The look and feel of the list can be configured for each group."] raw l["The look and feel of the list can be configured for each group."]
space space
raw l.["All fonts, colors, and sizes can be customized."] raw l["All fonts, colors, and sizes can be customized."]
space space
raw l.["This allows for configuration of large-print lists, among other things."] raw l["This allows for configuration of large-print lists, among other things."]
] ]
] ]
h4 [] [ raw l.["How Can Your Organization Use {0}?", s.["PrayerTracker"]] ] h4 [] [ raw l["How Can Your Organization Use {0}?", s["PrayerTracker"]] ]
p [] [ p [] [
raw l.["Like God’s gift of salvation, {0} is free for the asking for any church, Sunday School class, or other organization who wishes to use it.", raw l["Like God’s gift of salvation, {0} is free for the asking for any church, Sunday School class, or other organization who wishes to use it.",
s.["PrayerTracker"]] s["PrayerTracker"]]
space space
raw l.["If your organization would like to get set up, just <a href=\"mailto:daniel@djs-consulting.com?subject=New%20{0}%20Class\">e-mail</a> Daniel and let him know.", raw l["If your organization would like to get set up, just <a href=\"mailto:daniel@djs-consulting.com?subject=New%20{0}%20Class\">e-mail</a> Daniel and let him know.",
s.["PrayerTracker"]] s["PrayerTracker"]]
] ]
h4 [] [ raw l.["Do I Have to Register to See the Requests?"] ] h4 [] [ raw l["Do I Have to Register to See the Requests?"] ]
p [] [ p [] [
raw l.["This depends on the group."] raw l["This depends on the group."]
space space
raw l.["Lists can be configured to be password-protected, but they do not have to be."] raw l["Lists can be configured to be password-protected, but they do not have to be."]
space space
raw l.["If you click on the “{0}” link above, you will see a list of groups - those that do not indicate that they require logging in are publicly viewable.", raw l["If you click on the “{0}” link above, you will see a list of groups - those that do not indicate that they require logging in are publicly viewable.",
s.["View Request List"]] s["View Request List"]]
] ]
h4 [] [ raw l.["How Does It Work?"] ] h4 [] [ raw l["How Does It Work?"] ]
p [] [ p [] [
raw l.["Check out the “{0}” link above - it details each of the processes and how they work.", s.["Help"]] raw l["Check out the “{0}” link above - it details each of the processes and how they work.", s["Help"]]
] ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "Welcome!" |> Layout.standard vi "Welcome!"
/// Privacy Policy page /// Privacy Policy page
let privacyPolicy vi = let privacyPolicy vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let l = I18N.forView "Home/PrivacyPolicy" let l = I18N.forView "Home/PrivacyPolicy"
use sw = new StringWriter () use sw = new StringWriter ()
let raw = rawLocText sw let raw = rawLocText sw
[ p [ _class "pt-right-text" ] [ small[] [ em [] [ raw l.["(as of July 31, 2018)"] ] ] ] [ p [ _class "pt-right-text" ] [ small [] [ em [] [ raw l["(as of July 31, 2018)"] ] ] ]
p [] [ p [] [
raw l.["The nature of the service is one where privacy is a must."] raw l["The nature of the service is one where privacy is a must."]
space space
raw l.["The items below will help you understand the data we collect, access, and store on your behalf as you use this service."] raw l["The items below will help you understand the data we collect, access, and store on your behalf as you use this service."]
]
h3 [] [ raw l.["What We Collect"] ]
ul [] [
li [] [
strong [] [ raw l.["Identifying Data"] ]
rawText " &ndash; "
raw l.["{0} stores the first and last names, e-mail addresses, and hashed passwords of all authorized users.", s.["PrayerTracker"]]
space
raw l.["Users are also associated with one or more small groups."]
] ]
li [] [ h3 [] [ raw l["What We Collect"] ]
strong [] [ raw l.["User Provided Data"] ] ul [] [
rawText " &ndash; " li [] [
raw l.["{0} stores the text of prayer requests.", s.["PrayerTracker"]] strong [] [ raw l["Identifying Data"] ]
space rawText " &ndash; "
raw l.["It also stores names and e-mail addreses of small group members, and plain-text passwords for small groups with password-protected lists."] raw l["{0} stores the first and last names, e-mail addresses, and hashed passwords of all authorized users.",
s["PrayerTracker"]]
space
raw l["Users are also associated with one or more small groups."]
]
li [] [
strong [] [ raw l["User Provided Data"] ]
rawText " &ndash; "
raw l["{0} stores the text of prayer requests.", s["PrayerTracker"]]
space
raw l["It also stores names and e-mail addreses of small group members, and plain-text passwords for small groups with password-protected lists."]
]
]
h3 [] [ raw l["How Your Data Is Accessed / Secured"] ]
ul [] [
li [] [
raw l["While you are signed in, {0} utilizes a session cookie, and transmits that cookie to the server to establish your identity.",
s["PrayerTracker"]]
space
raw l["If you utilize the “{0}” box on sign in, a second cookie is stored, and transmitted to establish a session; this cookie is removed by clicking the “{1}” link.",
s["Remember Me"], s["Log Off"]]
space
raw l["Both of these cookies are encrypted, both in your browser and in transit."]
space
raw l["Finally, a third cookie is used to maintain your currently selected language, so that this selection is maintained across browser sessions."]
]
li [] [
raw l["Data for your small group is returned to you, as required, to display and edit."]
space
raw l["{0} also sends e-mails on behalf of the configured owner of a small group; these e-mails are sent from prayer@djs-consulting.com, with the “Reply To” header set to the configured owner of the small group.",
s["PrayerTracker"]]
space
raw l["Distinct e-mails are sent to each user, as to not disclose the other recipients."]
space
raw l["On the server, all data is stored in a controlled-access database."]
]
li [] [
raw l["Your data is backed up, along with other Bit Badger Solutions hosted systems, in a rolling manner; backups are preserved for the prior 7 days, and backups from the 1st and 15th are preserved for 3 months."]
space
raw l["These backups are stored in a private cloud data repository."]
]
li [] [
raw l["Access to servers and backups is strictly controlled and monitored for unauthorized access attempts."]
]
]
h3 [] [ raw l["Removing Your Data"] ]
p [] [
raw l["At any time, you may choose to discontinue using {0}; just e-mail Daniel, as you did to register, and request deletion of your small group.",
s["PrayerTracker"]]
] ]
] ]
h3 [] [ raw l.["How Your Data Is Accessed / Secured"] ] |> Layout.Content.standard
ul [] [ |> Layout.standard vi "Privacy Policy"
li [] [
raw l.["While you are signed in, {0} utilizes a session cookie, and transmits that cookie to the server to establish your identity.",
s.["PrayerTracker"]]
space
raw l.["If you utilize the “{0}” box on sign in, a second cookie is stored, and transmitted to establish a session; this cookie is removed by clicking the “{1}” link.",
s.["Remember Me"], s.["Log Off"]]
space
raw l.["Both of these cookies are encrypted, both in your browser and in transit."]
space
raw l.["Finally, a third cookie is used to maintain your currently selected language, so that this selection is maintained across browser sessions."]
]
li [] [
raw l.["Data for your small group is returned to you, as required, to display and edit."]
space
raw l.["{0} also sends e-mails on behalf of the configured owner of a small group; these e-mails are sent from prayer@djs-consulting.com, with the “Reply To” header set to the configured owner of the small group.",
s.["PrayerTracker"]]
space
raw l.["Distinct e-mails are sent to each user, as to not disclose the other recipients."]
space
raw l.["On the server, all data is stored in a controlled-access database."]
]
li [] [
raw l.["Your data is backed up, along with other Bit Badger Solutions hosted systems, in a rolling manner; backups are preserved for the prior 7 days, and backups from the 1st and 15th are preserved for 3 months."]
space
raw l.["These backups are stored in a private cloud data repository."]
]
li [] [
raw l.["Access to servers and backups is strictly controlled and monitored for unauthorized access attempts."]
]
]
h3 [] [ raw l.["Removing Your Data"] ]
p [] [
raw l.["At any time, you may choose to discontinue using {0}; just e-mail Daniel, as you did to register, and request deletion of your small group.",
s.["PrayerTracker"]]
]
]
|> Layout.Content.standard
|> Layout.standard vi "Privacy Policy"
/// Terms of Service page /// Terms of Service page
let termsOfService vi = let termsOfService vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let l = I18N.forView "Home/TermsOfService" let l = I18N.forView "Home/TermsOfService"
use sw = new StringWriter () use sw = new StringWriter ()
let raw = rawLocText sw let raw = rawLocText sw
let ppLink = let ppLink =
a [ _href "/web/legal/privacy-policy" ] [ str (s.["Privacy Policy"].Value.ToLower ()) ] a [ _href "/web/legal/privacy-policy" ] [ str (s["Privacy Policy"].Value.ToLower ()) ]
|> renderHtmlString |> renderHtmlString
[ p [ _class "pt-right-text" ] [ small [] [ em [] [ raw l.["(as of May 24, 2018)"] ] ] ] [ p [ _class "pt-right-text" ] [ small [] [ em [] [ raw l["(as of May 24, 2018)"] ] ] ]
h3 [] [ str "1. "; raw l.["Acceptance of Terms"] ] h3 [] [ str "1. "; raw l["Acceptance of Terms"] ]
p [] [ p [] [
raw l.["By accessing this web site, you are agreeing to be bound by these Terms and Conditions, and that you are responsible to ensure that your use of this site complies with all applicable laws."] raw l["By accessing this web site, you are agreeing to be bound by these Terms and Conditions, and that you are responsible to ensure that your use of this site complies with all applicable laws."]
space space
raw l.["Your continued use of this site implies your acceptance of these terms."] raw l["Your continued use of this site implies your acceptance of these terms."]
] ]
h3 [] [ str "2. "; raw l.["Description of Service and Registration"] ] h3 [] [ str "2. "; raw l["Description of Service and Registration"] ]
p [] [ p [] [
raw l.["{0} is a service that allows individuals to enter and amend prayer requests on behalf of organizations.", raw l["{0} is a service that allows individuals to enter and amend prayer requests on behalf of organizations.",
s.["PrayerTracker"]] s["PrayerTracker"]]
space space
raw l.["Registration is accomplished via e-mail to Daniel Summers (daniel at bitbadger dot solutions, substituting punctuation)."] raw l["Registration is accomplished via e-mail to Daniel Summers (daniel at bitbadger dot solutions, substituting punctuation)."]
space space
raw l.["See our {0} for details on the personal (user) information we maintain.", ppLink] raw l["See our {0} for details on the personal (user) information we maintain.", ppLink]
] ]
h3 [] [ str "3. "; raw l.["Liability"] ] h3 [] [ str "3. "; raw l["Liability"] ]
p [] [ p [] [
raw l.["This service is provided “as is”, and no warranty (express or implied) exists."] raw l["This service is provided “as is”, and no warranty (express or implied) exists."]
space space
raw l.["The service and its developers may not be held liable for any damages that may arise through the use of this service."] raw l["The service and its developers may not be held liable for any damages that may arise through the use of this service."]
] ]
h3 [] [ str "4. "; raw l.["Updates to Terms"] ] h3 [] [ str "4. "; raw l["Updates to Terms"] ]
p [] [ p [] [
raw l.["These terms and conditions may be updated at any time."] raw l["These terms and conditions may be updated at any time."]
space space
raw l.["When these terms are updated, users will be notified by a system-generated announcement."] raw l["When these terms are updated, users will be notified by a system-generated announcement."]
space space
raw l.["Additionally, the date at the top of this page will be updated."] raw l["Additionally, the date at the top of this page will be updated."]
] ]
hr [] hr []
p [] [ raw l.["You may also wish to review our {0} to learn how we handle your data.", ppLink] ] p [] [ raw l["You may also wish to review our {0} to learn how we handle your data.", ppLink] ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "Terms of Service" |> Layout.standard vi "Terms of Service"
/// View for unauthorized page /// View for unauthorized page
let unauthorized vi = let unauthorized vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let l = I18N.forView "Home/Unauthorized" let l = I18N.forView "Home/Unauthorized"
use sw = new StringWriter () use sw = new StringWriter ()
let raw = rawLocText sw let raw = rawLocText sw
[ p [] [ [ p [] [
raw l.["If you feel you have reached this page in error, please <a href=\"mailto:daniel@djs-consulting.com?Subject={0}%20Unauthorized%20Access\">contact Daniel</a> and provide the details as to what you were doing (i.e., what link did you click, where had you been, etc.).", raw l["If you feel you have reached this page in error, please <a href=\"mailto:daniel@djs-consulting.com?Subject={0}%20Unauthorized%20Access\">contact Daniel</a> and provide the details as to what you were doing (i.e., what link did you click, where had you been, etc.).",
s.["PrayerTracker"]] s["PrayerTracker"]]
] ]
p [] [ p [] [
raw l.["Otherwise, you may select one of the links above to get back into an authorized portion of {0}.", raw l["Otherwise, you may select one of the links above to get back into an authorized portion of {0}.",
s.["PrayerTracker"]] s["PrayerTracker"]]
] ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "Unauthorized Access" |> Layout.standard vi "Unauthorized Access"

6
src/PrayerTracker.UI/I18N.fs
View File

@ -11,12 +11,12 @@ let private resAsmName = typeof<Common>.Assembly.GetName().Name
/// Set up the string and HTML localizer factories /// Set up the string and HTML localizer factories
let setUpFactories fac = let setUpFactories fac =
stringLocFactory <- fac stringLocFactory <- fac
htmlLocFactory <- HtmlLocalizerFactory stringLocFactory htmlLocFactory <- HtmlLocalizerFactory stringLocFactory
/// An instance of the common string localizer /// An instance of the common string localizer
let localizer = lazy (stringLocFactory.Create ("Common", resAsmName)) let localizer = lazy (stringLocFactory.Create ("Common", resAsmName))
/// Get a view localizer /// Get a view localizer
let forView (view : string) = let forView (view : string) =
htmlLocFactory.Create ($"""Views.{view.Replace ('/', '.')}""", resAsmName) htmlLocFactory.Create ($"""Views.{view.Replace ('/', '.')}""", resAsmName)

461
src/PrayerTracker.UI/Layout.fs
View File

@ -6,285 +6,288 @@ open PrayerTracker
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open System open System
open System.Globalization open System.Globalization
/// Get the two-character language code for the current request /// Get the two-character language code for the current request
let langCode () = match CultureInfo.CurrentCulture.Name.StartsWith "es" with true -> "es" | _ -> "en" let langCode () = if CultureInfo.CurrentCulture.Name.StartsWith "es" then "es" else "en"
/// Navigation items /// Navigation items
module Navigation = module Navigation =
/// Top navigation bar /// Top navigation bar
let top m = let top m =
let s = PrayerTracker.Views.I18N.localizer.Force () let s = I18N.localizer.Force ()
let menuSpacer = rawText "&nbsp; " let menuSpacer = rawText "&nbsp; "
let leftLinks = [ let leftLinks = [
match m.user with
| Some u ->
li [ _class "dropdown" ] [
a [ _class "dropbtn"; _role "button"; _aria "label" s.["Requests"].Value; _title s.["Requests"].Value ]
[ icon "question_answer"; space; locStr s.["Requests"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/prayer-requests" ] [ icon "compare_arrows"; menuSpacer; locStr s.["Maintain"] ]
a [ _href "/web/prayer-requests/view" ] [ icon "list"; menuSpacer; locStr s.["View List"] ]
]
]
li [ _class "dropdown" ] [
a [ _class "dropbtn"; _role "button"; _aria "label" s.["Group"].Value; _title s.["Group"].Value ]
[ icon "group"; space; locStr s.["Group"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/small-group/members" ] [ icon "email"; menuSpacer; locStr s.["Maintain Group Members"] ]
a [ _href "/web/small-group/announcement" ] [ icon "send"; menuSpacer; locStr s.["Send Announcement"] ]
a [ _href "/web/small-group/preferences" ] [ icon "build"; menuSpacer; locStr s.["Change Preferences"] ]
]
]
match u.isAdmin with
| true ->
li [ _class "dropdown" ] [
a [ _class "dropbtn"; _role "button"; _aria "label" s.["Administration"].Value; _title s.["Administration"].Value ]
[ icon "settings"; space; locStr s.["Administration"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/churches" ] [ icon "home"; menuSpacer; locStr s.["Churches"] ]
a [ _href "/web/small-groups" ] [ icon "send"; menuSpacer; locStr s.["Groups"] ]
a [ _href "/web/users" ] [ icon "build"; menuSpacer; locStr s.["Users"] ]
]
]
| false -> ()
| None ->
match m.group with
| Some _ ->
li [] [
a [ _href "/web/prayer-requests/view"
_aria "label" s.["View Request List"].Value
_title s.["View Request List"].Value ]
[ icon "list"; space; locStr s.["View Request List"] ]
]
| None ->
li [ _class "dropdown" ] [
a [ _class "dropbtn"; _role "button"; _aria "label" s.["Log On"].Value; _title s.["Log On"].Value ]
[ icon "security"; space; locStr s.["Log On"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/user/log-on" ] [ icon "person"; menuSpacer; locStr s.["User"] ]
a [ _href "/web/small-group/log-on" ] [ icon "group"; menuSpacer; locStr s.["Group"] ]
]
]
li [] [
a [ _href "/web/prayer-requests/lists"
_aria "label" s.["View Request List"].Value
_title s.["View Request List"].Value ]
[ icon "list"; space; locStr s.["View Request List"] ]
]
li [] [
a [ _href $"https://docs.prayer.bitbadger.solutions/{langCode ()}"
_aria "label" s.["Help"].Value;
_title s.["View Help"].Value
_target "_blank"
]
[ icon "help"; space; locStr s.["Help"] ]
]
]
let rightLinks =
match m.group with
| Some _ ->
[ match m.user with
| Some _ ->
li [] [
a [ _href "/web/user/password"
_aria "label" s.["Change Your Password"].Value
_title s.["Change Your Password"].Value ]
[ icon "lock"; space; locStr s.["Change Your Password"] ]
]
| None -> ()
li [] [
a [ _href "/web/log-off"; _aria "label" s.["Log Off"].Value; _title s.["Log Off"].Value ]
[ icon "power_settings_new"; space; locStr s.["Log Off"] ]
]
]
| None -> List.empty
header [ _class "pt-title-bar" ] [
section [ _class "pt-title-bar-left" ] [
span [ _class "pt-title-bar-home" ] [
a [ _href "/web/"; _title s.["Home"].Value ] [ locStr s.["PrayerTracker"] ]
]
ul [] leftLinks
]
section [ _class "pt-title-bar-center" ] []
section [ _class "pt-title-bar-right"; _role "toolbar" ] [
ul [] rightLinks
]
]
/// Identity bar (below top nav)
let identity m =
let s = I18N.localizer.Force ()
header [ _id "pt-language" ] [
div [] [
span [ _class "u" ] [ locStr s.["Language"]; rawText ": " ]
match langCode () with
| "es" ->
locStr s.["Spanish"]
rawText " &nbsp; &bull; &nbsp; "
a [ _href "/web/language/en" ] [ locStr s.["Change to English"] ]
| _ ->
locStr s.["English"]
rawText " &nbsp; &bull; &nbsp; "
a [ _href "/web/language/es" ] [ locStr s.["Cambie a Español"] ]
]
match m.group with
| Some g ->
[ match m.user with
| Some u ->
span [ _class "u" ] [ locStr s.["Currently Logged On"] ]
rawText "&nbsp; &nbsp;"
icon "person"
strong [] [ str u.fullName ]
rawText "&nbsp; &nbsp; "
| None ->
locStr s.["Logged On as a Member of"]
rawText "&nbsp; "
icon "group"
space
match m.user with match m.user with
| Some _ -> a [ _href "/web/small-group" ] [ strong [] [ str g.name ] ] | Some u ->
| None -> strong [] [ str g.name ] li [ _class "dropdown" ] [
rawText " &nbsp;" a [ _class "dropbtn"; _role "button"; _aria "label" s["Requests"].Value; _title s["Requests"].Value ]
[ icon "question_answer"; space; locStr s["Requests"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/prayer-requests" ] [ icon "compare_arrows"; menuSpacer; locStr s["Maintain"] ]
a [ _href "/web/prayer-requests/view" ] [ icon "list"; menuSpacer; locStr s["View List"] ]
]
]
li [ _class "dropdown" ] [
a [ _class "dropbtn"; _role "button"; _aria "label" s["Group"].Value; _title s["Group"].Value ]
[ icon "group"; space; locStr s["Group"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/small-group/members" ]
[ icon "email"; menuSpacer; locStr s["Maintain Group Members"] ]
a [ _href "/web/small-group/announcement" ]
[ icon "send"; menuSpacer; locStr s["Send Announcement"] ]
a [ _href "/web/small-group/preferences" ]
[ icon "build"; menuSpacer; locStr s["Change Preferences"] ]
]
]
if u.isAdmin then
li [ _class "dropdown" ] [
a [ _class "dropbtn"
_role "button"
_aria "label" s["Administration"].Value
_title s["Administration"].Value
] [ icon "settings"; space; locStr s["Administration"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/churches" ] [ icon "home"; menuSpacer; locStr s["Churches"] ]
a [ _href "/web/small-groups" ] [ icon "send"; menuSpacer; locStr s["Groups"] ]
a [ _href "/web/users" ] [ icon "build"; menuSpacer; locStr s["Users"] ]
]
]
| None ->
match m.group with
| Some _ ->
li [] [
a [ _href "/web/prayer-requests/view"
_aria "label" s["View Request List"].Value
_title s["View Request List"].Value
] [ icon "list"; space; locStr s["View Request List"] ]
]
| None ->
li [ _class "dropdown" ] [
a [ _class "dropbtn"
_role "button"
_aria "label" s["Log On"].Value
_title s["Log On"].Value
] [ icon "security"; space; locStr s["Log On"]; space; icon "keyboard_arrow_down" ]
div [ _class "dropdown-content"; _role "menu" ] [
a [ _href "/web/user/log-on" ] [ icon "person"; menuSpacer; locStr s["User"] ]
a [ _href "/web/small-group/log-on" ] [ icon "group"; menuSpacer; locStr s["Group"] ]
]
]
li [] [
a [ _href "/web/prayer-requests/lists"
_aria "label" s["View Request List"].Value
_title s["View Request List"].Value
] [ icon "list"; space; locStr s["View Request List"] ]
]
li [] [
a [ _href $"https://docs.prayer.bitbadger.solutions/{langCode ()}"
_aria "label" s["Help"].Value;
_title s["View Help"].Value
_target "_blank"
] [ icon "help"; space; locStr s["Help"] ]
] ]
| None -> [] ]
|> div [] let rightLinks =
] match m.group with
| Some _ -> [
match m.user with
| Some _ ->
li [] [
a [ _href "/web/user/password"
_aria "label" s["Change Your Password"].Value
_title s["Change Your Password"].Value
] [ icon "lock"; space; locStr s["Change Your Password"] ]
]
| None -> ()
li [] [
a [ _href "/web/log-off"; _aria "label" s["Log Off"].Value; _title s["Log Off"].Value ]
[ icon "power_settings_new"; space; locStr s["Log Off"] ]
]
]
| None -> []
header [ _class "pt-title-bar" ] [
section [ _class "pt-title-bar-left" ] [
span [ _class "pt-title-bar-home" ] [
a [ _href "/web/"; _title s["Home"].Value ] [ locStr s["PrayerTracker"] ]
]
ul [] leftLinks
]
section [ _class "pt-title-bar-center" ] []
section [ _class "pt-title-bar-right"; _role "toolbar" ] [
ul [] rightLinks
]
]
/// Identity bar (below top nav)
let identity m =
let s = I18N.localizer.Force ()
header [ _id "pt-language" ] [
div [] [
span [ _class "u" ] [ locStr s["Language"]; rawText ": " ]
match langCode () with
| "es" ->
locStr s["Spanish"]
rawText " &nbsp; &bull; &nbsp; "
a [ _href "/web/language/en" ] [ locStr s["Change to English"] ]
| _ ->
locStr s["English"]
rawText " &nbsp; &bull; &nbsp; "
a [ _href "/web/language/es" ] [ locStr s["Cambie a Español"] ]
]
match m.group with
| Some g ->[
match m.user with
| Some u ->
span [ _class "u" ] [ locStr s["Currently Logged On"] ]
rawText "&nbsp; &nbsp;"
icon "person"
strong [] [ str u.fullName ]
rawText "&nbsp; &nbsp; "
| None ->
locStr s["Logged On as a Member of"]
rawText "&nbsp; "
icon "group"
space
match m.user with
| Some _ -> a [ _href "/web/small-group" ] [ strong [] [ str g.name ] ]
| None -> strong [] [ str g.name ]
rawText " &nbsp;"
]
| None -> []
|> div []
]
/// Content layouts /// Content layouts
module Content = module Content =
/// Content layout that tops at 60rem
let standard = div [ _class "pt-content" ] /// Content layout that tops at 60rem
let standard = div [ _class "pt-content" ]
/// Content layout that uses the full width of the browser window /// Content layout that uses the full width of the browser window
let wide = div [ _class "pt-content pt-full-width" ] let wide = div [ _class "pt-content pt-full-width" ]
/// Separator for parts of the title /// Separator for parts of the title
let private titleSep = rawText " &#xab; " let private titleSep = rawText " &#xab; "
/// Common HTML head tag items
let private commonHead = let private commonHead =
[ meta [ _name "viewport"; _content "width=device-width, initial-scale=1" ] [ meta [ _name "viewport"; _content "width=device-width, initial-scale=1" ]
meta [ _name "generator"; _content "Giraffe" ] meta [ _name "generator"; _content "Giraffe" ]
link [ _rel "stylesheet"; _href "https://fonts.googleapis.com/icon?family=Material+Icons" ] link [ _rel "stylesheet"; _href "https://fonts.googleapis.com/icon?family=Material+Icons" ]
link [ _rel "stylesheet"; _href "/css/app.css" ] link [ _rel "stylesheet"; _href "/css/app.css" ]
script [ _src "/js/app.js" ] [] script [ _src "/js/app.js" ] []
] ]
/// Render the <head> portion of the page /// Render the <head> portion of the page
let private htmlHead m pageTitle = let private htmlHead m pageTitle =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
head [] [ head [] [
meta [ _charset "UTF-8" ] meta [ _charset "UTF-8" ]
title [] [ locStr pageTitle; titleSep; locStr s.["PrayerTracker"] ] title [] [ locStr pageTitle; titleSep; locStr s["PrayerTracker"] ]
yield! commonHead yield! commonHead
for cssFile in m.style do for cssFile in m.style do
link [ _rel "stylesheet"; _href $"/css/{cssFile}.css"; _type "text/css" ] link [ _rel "stylesheet"; _href $"/css/{cssFile}.css"; _type "text/css" ]
for jsFile in m.script do for jsFile in m.script do
script [ _src $"/js/{jsFile}.js" ] [] script [ _src $"/js/{jsFile}.js" ] []
] ]
/// Render a link to the help page for the current page /// Render a link to the help page for the current page
let private helpLink link = let private helpLink link =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
sup [] [ sup [] [
a [ _href link a [ _href link; _title s["Click for Help on This Page"].Value; _onclick $"return PT.showHelp('{link}')" ]
_title s.["Click for Help on This Page"].Value [ icon "help_outline" ]
_onclick $"return PT.showHelp('{link}')" ] [
icon "help_outline"
]
] ]
/// Render the page title, and optionally a help link /// Render the page title, and optionally a help link
let private renderPageTitle m pageTitle = let private renderPageTitle m pageTitle =
h2 [ _id "pt-page-title" ] [ h2 [ _id "pt-page-title" ] [
match m.helpLink with Some link -> Help.fullLink (langCode ()) link |> helpLink | None -> () match m.helpLink with Some link -> Help.fullLink (langCode ()) link |> helpLink | None -> ()
locStr pageTitle locStr pageTitle
] ]
/// Render the messages that may need to be displayed to the user /// Render the messages that may need to be displayed to the user
let private messages m = let private messages m =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
m.messages m.messages
|> List.map (fun msg -> |> List.map (fun msg ->
table [ _class $"pt-msg {msg.level.ToLower ()}" ] [ table [ _class $"pt-msg {msg.level.ToLower ()}" ] [
tr [] [ tr [] [
td [] [ td [] [
match msg.level with match msg.level with
| "Info" -> () | "Info" -> ()
| lvl -> | lvl ->
strong [] [ locStr s.[lvl] ] strong [] [ locStr s[lvl] ]
rawText " &#xbb; " rawText " &#xbb; "
rawText msg.text.Value rawText msg.text.Value
match msg.description with match msg.description with
| Some desc -> | Some desc ->
br [] br []
div [ _class "description" ] [ rawText desc.Value ] div [ _class "description" ] [ rawText desc.Value ]
| None -> () | None -> ()
]
] ]
]
]) ])
/// Render the <footer> at the bottom of the page /// Render the <footer> at the bottom of the page
let private htmlFooter m = let private htmlFooter m =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let imgText = sprintf "%O %O" s.["PrayerTracker"] s.["from Bit Badger Solutions"] let imgText = sprintf "%O %O" s["PrayerTracker"] s["from Bit Badger Solutions"]
let resultTime = TimeSpan(DateTime.Now.Ticks - m.requestStart).TotalSeconds let resultTime = TimeSpan(DateTime.Now.Ticks - m.requestStart).TotalSeconds
footer [] [ footer [] [
div [ _id "pt-legal" ] [ div [ _id "pt-legal" ] [
a [ _href "/web/legal/privacy-policy" ] [ locStr s.["Privacy Policy"] ] a [ _href "/web/legal/privacy-policy" ] [ locStr s["Privacy Policy"] ]
rawText " &bull; " rawText " &bull; "
a [ _href "/web/legal/terms-of-service" ] [ locStr s.["Terms of Service"] ] a [ _href "/web/legal/terms-of-service" ] [ locStr s["Terms of Service"] ]
rawText " &bull; " rawText " &bull; "
a [ _href "https://github.com/bit-badger/PrayerTracker" a [ _href "https://github.com/bit-badger/PrayerTracker"
_title s.["View source code and get technical support"].Value _title s["View source code and get technical support"].Value
_target "_blank" _target "_blank"
_rel "noopener" ] [ _rel "noopener"
locStr s.["Source & Support"] ] [ locStr s["Source & Support"]
]
] ]
] div [ _id "pt-footer" ] [
div [ _id "pt-footer" ] [ a [ _href "/web/"; _style "line-height:28px;" ]
a [ _href "/web/"; _style "line-height:28px;" ] [ [ img [ _src $"""/img/%O{s["footer_en"]}.png"""; _alt imgText; _title imgText ] ]
img [ _src $"""/img/%O{s.["footer_en"]}.png"""; _alt imgText; _title imgText ] str m.version
space
i [ _title s["This page loaded in {0:N3} seconds", resultTime].Value; _class "material-icons md-18" ]
[ str "schedule" ]
] ]
str m.version
space
i [ _title s.["This page loaded in {0:N3} seconds", resultTime].Value; _class "material-icons md-18" ] [
str "schedule"
]
]
] ]
/// The standard layout for PrayerTracker /// The standard layout for PrayerTracker
let standard m pageTitle (content : XmlNode) = let standard m pageTitle (content : XmlNode) =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let ttl = s.[pageTitle] let ttl = s[pageTitle]
html [ _lang "" ] [ html [ _lang "" ] [
htmlHead m ttl htmlHead m ttl
body [] [ body [] [
Navigation.top m Navigation.top m
div [ _id "pt-body" ] [ div [ _id "pt-body" ] [
Navigation.identity m Navigation.identity m
renderPageTitle m ttl renderPageTitle m ttl
yield! messages m yield! messages m
content content
htmlFooter m htmlFooter m
]
] ]
]
] ]
/// A layout with nothing but a title and content /// A layout with nothing but a title and content
let bare pageTitle content = let bare pageTitle content =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let ttl = s.[pageTitle] let ttl = s[pageTitle]
html [ _lang "" ] [ html [ _lang "" ] [
head [] [ head [] [
meta [ _charset "UTF-8" ] meta [ _charset "UTF-8" ]
title [] [ locStr ttl; titleSep; locStr s.["PrayerTracker"] ] title [] [ locStr ttl; titleSep; locStr s["PrayerTracker"] ]
] ]
body [] [ content ] body [] [ content ]
] ]

613
src/PrayerTracker.UI/PrayerRequest.fs
View File

@ -1,5 +1,7 @@
module PrayerTracker.Views.PrayerRequest module PrayerTracker.Views.PrayerRequest
open System
open System.IO
open Giraffe open Giraffe
open Giraffe.ViewEngine open Giraffe.ViewEngine
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
@ -7,364 +9,347 @@ open NodaTime
open PrayerTracker open PrayerTracker
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open System
open System.IO
open System.Text
/// View for the prayer request edit page /// View for the prayer request edit page
let edit (m : EditRequest) today ctx vi = let edit (m : EditRequest) today ctx vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let pageTitle = match m.isNew () with true -> "Add a New Request" | false -> "Edit Request" let pageTitle = if m.isNew () then "Add a New Request" else "Edit Request"
[ form [ _action "/web/prayer-request/save"; _method "post"; _class "pt-center-columns" ] [ [ form [ _action "/web/prayer-request/save"; _method "post"; _class "pt-center-columns" ] [
csrfToken ctx csrfToken ctx
input [ _type "hidden"; _name "requestId"; _value (flatGuid m.requestId) ] input [ _type "hidden"; _name "requestId"; _value (flatGuid m.requestId) ]
div [ _class "pt-field-row" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [
label [ _for "requestType" ] [ locStr s.["Request Type"] ]
ReferenceList.requestTypeList s
|> Seq.ofList
|> Seq.map (fun (typ, desc) -> typ.code, desc.Value)
|> selectList "requestType" m.requestType [ _required; _autofocus ]
]
div [ _class "pt-field" ] [
label [ _for "requestor" ] [ locStr s.["Requestor / Subject"] ]
input [ _type "text"
_name "requestor"
_id "requestor"
_value (match m.requestor with Some x -> x | None -> "") ]
]
match m.isNew () with
| true ->
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "enteredDate" ] [ locStr s.["Date"] ] label [ _for "requestType" ] [ locStr s["Request Type"] ]
input [ _type "date"; _name "enteredDate"; _id "enteredDate"; _placeholder today ] ReferenceList.requestTypeList s
] |> Seq.ofList
| false -> |> Seq.map (fun (typ, desc) -> typ.code, desc.Value)
|> selectList "requestType" m.requestType [ _required; _autofocus ]
]
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
div [ _class "pt-checkbox-field" ] [ label [ _for "requestor" ] [ locStr s["Requestor / Subject"] ]
br [] input [ _type "text"
input [ _type "checkbox"; _name "skipDateUpdate"; _id "skipDateUpdate"; _value "True" ] _name "requestor"
label [ _for "skipDateUpdate" ] [ locStr s.["Check to not update the date"] ] _id "requestor"
br [] _value (match m.requestor with Some x -> x | None -> "") ]
small [] [ em [] [ str (s.["Typo Corrections"].Value.ToLower ()); rawText ", etc." ] ] ]
if m.isNew () then
div [ _class "pt-field" ] [
label [ _for "enteredDate" ] [ locStr s["Date"] ]
input [ _type "date"; _name "enteredDate"; _id "enteredDate"; _placeholder today ]
]
else
div [ _class "pt-field" ] [
div [ _class "pt-checkbox-field" ] [
br []
input [ _type "checkbox"; _name "skipDateUpdate"; _id "skipDateUpdate"; _value "True" ]
label [ _for "skipDateUpdate" ] [ locStr s["Check to not update the date"] ]
br []
small [] [ em [] [ str (s["Typo Corrections"].Value.ToLower ()); rawText ", etc." ] ]
]
] ]
]
] ]
div [ _class "pt-field-row" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [] [ locStr s.["Expiration"] ] label [] [ locStr s["Expiration"] ]
ReferenceList.expirationList s ((m.isNew >> not) ()) ReferenceList.expirationList s ((m.isNew >> not) ())
|> List.map (fun exp -> |> List.map (fun exp ->
let radioId = $"expiration_{fst exp}" let radioId = $"expiration_{fst exp}"
span [ _class "text-nowrap" ] [ span [ _class "text-nowrap" ] [
radio "expiration" radioId (fst exp) m.expiration radio "expiration" radioId (fst exp) m.expiration
label [ _for radioId ] [ locStr (snd exp) ] label [ _for radioId ] [ locStr (snd exp) ]
rawText " &nbsp; &nbsp; " rawText " &nbsp; &nbsp; "
]) ])
|> div [ _class "pt-center-text" ] |> div [ _class "pt-center-text" ]
] ]
] ]
div [ _class "pt-field-row" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field pt-editor" ] [ div [ _class "pt-field pt-editor" ] [
label [ _for "text" ] [ locStr s.["Request"] ] label [ _for "text" ] [ locStr s["Request"] ]
textarea [ _name "text"; _id "text" ] [ str m.text ] textarea [ _name "text"; _id "text" ] [ str m.text ]
] ]
] ]
div [ _class "pt-field-row" ] [ submit [] "save" s.["Save Request"] ] div [ _class "pt-field-row" ] [ submit [] "save" s["Save Request"] ]
] ]
script [] [ rawText "PT.onLoad(PT.initCKEditor)" ] script [] [ rawText "PT.onLoad(PT.initCKEditor)" ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi pageTitle |> Layout.standard vi pageTitle
/// View for the request e-mail results page /// View for the request e-mail results page
let email m vi = let email m vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let pageTitle = $"""{s.["Prayer Requests"].Value} • {m.listGroup.name}""" let pageTitle = $"""{s["Prayer Requests"].Value} • {m.listGroup.name}"""
let prefs = m.listGroup.preferences let prefs = m.listGroup.preferences
let addresses = let addresses = String.Join (", ", m.recipients |> List.map (fun mbr -> $"{mbr.memberName} <{mbr.email}>"))
m.recipients [ p [ _style $"font-family:{prefs.listFonts};font-size:%i{prefs.textFontSize}pt;" ] [
|> List.fold (fun (acc : StringBuilder) mbr -> acc.AppendFormat(", {0} <{1}>", mbr.memberName, mbr.email)) locStr s["The request list was sent to the following people, via individual e-mails"]
(StringBuilder ()) rawText ":"
[ p [ _style $"font-family:{prefs.listFonts};font-size:%i{prefs.textFontSize}pt;" ] [ br []
locStr s.["The request list was sent to the following people, via individual e-mails"] small [] [ str addresses ]
rawText ":"
br []
small [] [ str (addresses.Remove(0, 2).ToString ()) ]
] ]
span [ _class "pt-email-heading" ] [ locStr s.["HTML Format"]; rawText ":" ] span [ _class "pt-email-heading" ] [ locStr s["HTML Format"]; rawText ":" ]
div [ _class "pt-email-canvas" ] [ rawText (m.asHtml s) ] div [ _class "pt-email-canvas" ] [ rawText (m.asHtml s) ]
br [] br []
br [] br []
span [ _class "pt-email-heading" ] [ locStr s.["Plain-Text Format"]; rawText ":" ] span [ _class "pt-email-heading" ] [ locStr s["Plain-Text Format"]; rawText ":" ]
div[ _class "pt-email-canvas" ] [ pre [] [ str (m.asText s) ] ] div [ _class "pt-email-canvas" ] [ pre [] [ str (m.asText s) ] ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi pageTitle |> Layout.standard vi pageTitle
/// View for a small group's public prayer request list /// View for a small group's public prayer request list
let list (m : RequestList) vi = let list (m : RequestList) vi =
[ br [] [ br []
I18N.localizer.Force () |> (m.asHtml >> rawText) I18N.localizer.Force () |> (m.asHtml >> rawText)
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "View Request List" |> Layout.standard vi "View Request List"
/// View for the prayer request lists page /// View for the prayer request lists page
let lists (grps : SmallGroup list) vi = let lists (groups : SmallGroup list) vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let l = I18N.forView "Requests/Lists" let l = I18N.forView "Requests/Lists"
use sw = new StringWriter () use sw = new StringWriter ()
let raw = rawLocText sw let raw = rawLocText sw
[ p [] [ [ p [] [
raw l.["The groups listed below have either public or password-protected request lists."] raw l["The groups listed below have either public or password-protected request lists."]
space space
raw l.["Those with list icons are public, and those with log on icons are password-protected."] raw l["Those with list icons are public, and those with log on icons are password-protected."]
space space
raw l.["Click the appropriate icon to log on or view the request list."] raw l["Click the appropriate icon to log on or view the request list."]
] ]
match grps.Length with match groups.Length with
| 0 -> p [] [ raw l.["There are no groups with public or password-protected request lists."] ] | 0 -> p [] [ raw l["There are no groups with public or password-protected request lists."] ]
| count -> | count ->
tableSummary count s tableSummary count s
table [ _class "pt-table pt-action-table" ] [ table [ _class "pt-table pt-action-table" ] [
thead [] [ thead [] [
tr [] [ tr [] [
th [] [ locStr s.["Actions"] ] th [] [ locStr s["Actions"] ]
th [] [ locStr s.["Church"] ] th [] [ locStr s["Church"] ]
th [] [ locStr s.["Group"] ] th [] [ locStr s["Group"] ]
]
] ]
] groups
grps |> List.map (fun grp ->
|> List.map (fun grp -> let grpId = flatGuid grp.smallGroupId
let grpId = flatGuid grp.smallGroupId tr [] [
tr [] [ if grp.preferences.isPublic then
match grp.preferences.isPublic with a [ _href $"/web/prayer-requests/{grpId}/list"; _title s["View"].Value ] [ icon "list" ]
| true -> else
a [ _href $"/web/prayer-requests/{grpId}/list"; _title s.["View"].Value ] [ icon "list" ] a [ _href $"/web/small-group/log-on/{grpId}"; _title s["Log On"].Value ]
| false -> [ icon "verified_user" ]
a [ _href $"/web/small-group/log-on/{grpId}"; _title s.["Log On"].Value ] |> List.singleton
[ icon "verified_user" ] |> td []
|> List.singleton td [] [ str grp.church.name ]
|> td [] td [] [ str grp.name ]
td [] [ str grp.church.name ] ])
td [] [ str grp.name ] |> tbody []
])
|> tbody []
] ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "Request Lists" |> Layout.standard vi "Request Lists"
/// View for the prayer request maintenance page /// View for the prayer request maintenance page
let maintain m (ctx : HttpContext) vi = let maintain m (ctx : HttpContext) vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let l = I18N.forView "Requests/Maintain" let l = I18N.forView "Requests/Maintain"
use sw = new StringWriter () use sw = new StringWriter ()
let raw = rawLocText sw let raw = rawLocText sw
let now = m.smallGroup.localDateNow (ctx.GetService<IClock> ()) let now = m.smallGroup.localDateNow (ctx.GetService<IClock> ())
let typs = ReferenceList.requestTypeList s |> Map.ofList let typs = ReferenceList.requestTypeList s |> Map.ofList
let updReq (req : PrayerRequest) = let updReq (req : PrayerRequest) =
match req.updateRequired now m.smallGroup.preferences.daysToExpire m.smallGroup.preferences.longTermUpdateWeeks with if req.updateRequired now m.smallGroup.preferences.daysToExpire m.smallGroup.preferences.longTermUpdateWeeks then
| true -> "pt-request-update" "pt-request-update"
| false -> "" else ""
|> _class |> _class
let reqExp (req : PrayerRequest) = let reqExp (req : PrayerRequest) =
_class (match req.isExpired now m.smallGroup.preferences.daysToExpire with true -> "pt-request-expired" | false -> "") _class (if req.isExpired now m.smallGroup.preferences.daysToExpire then "pt-request-expired" else "")
/// Iterate the sequence once, before we render, so we can get the count of it at the top of the table /// Iterate the sequence once, before we render, so we can get the count of it at the top of the table
let requests = let requests =
m.requests m.requests
|> Seq.map (fun req -> |> Seq.map (fun req ->
let reqId = flatGuid req.prayerRequestId let reqId = flatGuid req.prayerRequestId
let reqText = htmlToPlainText req.text let reqText = htmlToPlainText req.text
let delAction = $"/web/prayer-request/{reqId}/delete" let delAction = $"/web/prayer-request/{reqId}/delete"
let delPrompt = let delPrompt =
[ s.["Are you sure you want to delete this {0}? This action cannot be undone.", [ s["Are you sure you want to delete this {0}? This action cannot be undone.",
s.["Prayer Request"].Value.ToLower() ] s["Prayer Request"].Value.ToLower() ].Value
.Value "\\n"
"\\n" l["(If the prayer request has been answered, or an event has passed, consider inactivating it instead.)"]
l.["(If the prayer request has been answered, or an event has passed, consider inactivating it instead.)"] .Value
.Value ]
] |> String.concat ""
|> String.concat ""
tr [] [
td [] [
a [ _href $"/web/prayer-request/{reqId}/edit"; _title l.["Edit This Prayer Request"].Value ]
[ icon "edit" ]
match req.isExpired now m.smallGroup.preferences.daysToExpire with
| true ->
a [ _href $"/web/prayer-request/{reqId}/restore"
_title l.["Restore This Inactive Request"].Value ]
[ icon "visibility" ]
| false ->
a [ _href $"/web/prayer-request/{reqId}/expire"
_title l.["Expire This Request Immediately"].Value ]
[ icon "visibility_off" ]
a [ _href delAction; _title l.["Delete This Request"].Value;
_onclick $"return PT.confirmDelete('{delAction}','{delPrompt}')" ]
[ icon "delete_forever" ]
]
td [ updReq req ] [
str (req.updatedDate.ToString(s.["MMMM d, yyyy"].Value, Globalization.CultureInfo.CurrentUICulture))
]
td [] [ locStr typs.[req.requestType] ]
td [ reqExp req ] [ str (match req.requestor with Some r -> r | None -> " ") ]
td [] [
match reqText.Length with
| len when len < 60 -> rawText reqText
| _ -> rawText $"{reqText.[0..59]}&hellip;"
]
])
|> List.ofSeq
[ div [ _class "pt-center-text" ] [
br []
a [ _href $"/web/prayer-request/{emptyGuid}/edit"; _title s.["Add a New Request"].Value ]
[ icon "add_circle"; rawText " &nbsp;"; locStr s.["Add a New Request"] ]
rawText " &nbsp; &nbsp; &nbsp; "
a [ _href "/web/prayer-requests/view"; _title s.["View Prayer Request List"].Value ]
[ icon "list"; rawText " &nbsp;"; locStr s.["View Prayer Request List"] ]
match m.searchTerm with
| Some _ ->
rawText " &nbsp; &nbsp; &nbsp; "
a [ _href "/web/prayer-requests"; _title l.["Clear Search Criteria"].Value ]
[ icon "highlight_off"; rawText " &nbsp;"; raw l.["Clear Search Criteria"] ]
| None -> ()
]
form [ _action "/web/prayer-requests"; _method "get"; _class "pt-center-text pt-search-form" ] [
input [ _type "text"
_name "search"
_placeholder l.["Search requests..."].Value
_value (defaultArg m.searchTerm "")
]
space
submit [] "search" s.["Search"]
]
br []
tableSummary requests.Length s
match requests.Length with
| 0 -> ()
| _ ->
table [ _class "pt-table pt-action-table" ] [
thead [] [
tr [] [ tr [] [
th [] [ locStr s.["Actions"] ] td [] [
th [] [ locStr s.["Updated Date"] ] a [ _href $"/web/prayer-request/{reqId}/edit"; _title l["Edit This Prayer Request"].Value ]
th [] [ locStr s.["Type"] ] [ icon "edit" ]
th [] [ locStr s.["Requestor"] ] if req.isExpired now m.smallGroup.preferences.daysToExpire then
th [] [ locStr s.["Request"] ] a [ _href $"/web/prayer-request/{reqId}/restore"
] _title l["Restore This Inactive Request"].Value ]
] [ icon "visibility" ]
tbody [] requests else
] a [ _href $"/web/prayer-request/{reqId}/expire"
div [ _class "pt-center-text" ] [ _title l["Expire This Request Immediately"].Value ]
br [] [ icon "visibility_off" ]
match m.onlyActive with a [ _href delAction; _title l["Delete This Request"].Value;
| Some true -> _onclick $"return PT.confirmDelete('{delAction}','{delPrompt}')" ]
raw l.["Inactive requests are currently not shown"] [ icon "delete_forever" ]
br [] ]
a [ _href "/web/prayer-requests/inactive" ] [ raw l.["Show Inactive Requests"] ] td [ updReq req ] [
| _ -> str (req.updatedDate.ToString(s["MMMM d, yyyy"].Value, Globalization.CultureInfo.CurrentUICulture))
match Option.isSome m.onlyActive with ]
| true -> td [] [ locStr typs[req.requestType] ]
raw l.["Inactive requests are currently shown"] td [ reqExp req ] [ str (match req.requestor with Some r -> r | None -> " ") ]
br [] td [] [
a [ _href "/web/prayer-requests" ] [ raw l.["Do Not Show Inactive Requests"] ] match reqText.Length with
br [] | len when len < 60 -> rawText reqText
br [] | _ -> rawText $"{reqText[0..59]}&hellip;"
| false -> () ]
let srch = [ match m.searchTerm with Some s -> "search", s | None -> () ] ])
let pg = defaultArg m.pageNbr 1 |> List.ofSeq
let url = [ div [ _class "pt-center-text" ] [
match m.onlyActive with Some true | None -> "" | _ -> "/inactive" |> sprintf "/web/prayer-requests%s" br []
match pg with a [ _href $"/web/prayer-request/{emptyGuid}/edit"; _title s["Add a New Request"].Value ]
| 1 -> () [ icon "add_circle"; rawText " &nbsp;"; locStr s["Add a New Request"] ]
| _ -> rawText " &nbsp; &nbsp; &nbsp; "
// button (_type "submit" :: attrs) [ icon ico; rawText " &nbsp;"; locStr text ] a [ _href "/web/prayer-requests/view"; _title s["View Prayer Request List"].Value ]
let withPage = match pg with 2 -> srch | _ -> ("page", string (pg - 1)) :: srch [ icon "list"; rawText " &nbsp;"; locStr s["View Prayer Request List"] ]
a [ _href (makeUrl url withPage) ] match m.searchTerm with
[ icon "keyboard_arrow_left"; space; raw l.["Previous Page"] ] | Some _ ->
rawText " &nbsp; &nbsp; " rawText " &nbsp; &nbsp; &nbsp; "
match requests.Length = m.smallGroup.preferences.pageSize with a [ _href "/web/prayer-requests"; _title l["Clear Search Criteria"].Value ]
| true -> [ icon "highlight_off"; rawText " &nbsp;"; raw l["Clear Search Criteria"] ]
a [ _href (makeUrl url (("page", string (pg + 1)) :: srch)) ] | None -> ()
[ raw l.["Next Page"]; space; icon "keyboard_arrow_right" ]
| false -> ()
] ]
form [ _id "DeleteForm"; _action ""; _method "post" ] [ csrfToken ctx ] form [ _action "/web/prayer-requests"; _method "get"; _class "pt-center-text pt-search-form" ] [
input [ _type "text"
_name "search"
_placeholder l["Search requests..."].Value
_value (defaultArg m.searchTerm "")
]
space
submit [] "search" s["Search"]
]
br []
tableSummary requests.Length s
match requests.Length with
| 0 -> ()
| _ ->
table [ _class "pt-table pt-action-table" ] [
thead [] [
tr [] [
th [] [ locStr s["Actions"] ]
th [] [ locStr s["Updated Date"] ]
th [] [ locStr s["Type"] ]
th [] [ locStr s["Requestor"] ]
th [] [ locStr s["Request"] ]
]
]
tbody [] requests
]
div [ _class "pt-center-text" ] [
br []
match m.onlyActive with
| Some true ->
raw l["Inactive requests are currently not shown"]
br []
a [ _href "/web/prayer-requests/inactive" ] [ raw l["Show Inactive Requests"] ]
| _ ->
match Option.isSome m.onlyActive with
| true ->
raw l["Inactive requests are currently shown"]
br []
a [ _href "/web/prayer-requests" ] [ raw l["Do Not Show Inactive Requests"] ]
br []
br []
| false -> ()
let srch = [ match m.searchTerm with Some s -> "search", s | None -> () ]
let pg = defaultArg m.pageNbr 1
let url =
match m.onlyActive with Some true | None -> "" | _ -> "/inactive" |> sprintf "/web/prayer-requests%s"
match pg with
| 1 -> ()
| _ ->
// button (_type "submit" :: attrs) [ icon ico; rawText " &nbsp;"; locStr text ]
let withPage = match pg with 2 -> srch | _ -> ("page", string (pg - 1)) :: srch
a [ _href (makeUrl url withPage) ]
[ icon "keyboard_arrow_left"; space; raw l["Previous Page"] ]
rawText " &nbsp; &nbsp; "
match requests.Length = m.smallGroup.preferences.pageSize with
| true ->
a [ _href (makeUrl url (("page", string (pg + 1)) :: srch)) ]
[ raw l["Next Page"]; space; icon "keyboard_arrow_right" ]
| false -> ()
]
form [ _id "DeleteForm"; _action ""; _method "post" ] [ csrfToken ctx ]
] ]
|> Layout.Content.wide |> Layout.Content.wide
|> Layout.standard vi (match m.searchTerm with Some _ -> "Search Results" | None -> "Maintain Requests") |> Layout.standard vi (match m.searchTerm with Some _ -> "Search Results" | None -> "Maintain Requests")
/// View for the printable prayer request list /// View for the printable prayer request list
let print m version = let print m version =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let pageTitle = $"""{s.["Prayer Requests"].Value} • {m.listGroup.name}""" let pageTitle = $"""{s["Prayer Requests"].Value} • {m.listGroup.name}"""
let imgAlt = $"""{s.["PrayerTracker"].Value} {s.["from Bit Badger Solutions"].Value}""" let imgAlt = $"""{s["PrayerTracker"].Value} {s["from Bit Badger Solutions"].Value}"""
article [] [ article [] [
rawText (m.asHtml s) rawText (m.asHtml s)
br [] br []
hr [] hr []
div [ _style $"font-size:70%%;font-family:{m.listGroup.preferences.listFonts};" ] [ div [ _style $"font-size:70%%;font-family:{m.listGroup.preferences.listFonts};" ] [
img [ _src $"""/img/{s.["footer_en"].Value}.png""" img [ _src $"""/img/{s["footer_en"].Value}.png"""
_style "vertical-align:text-bottom;" _style "vertical-align:text-bottom;"
_alt imgAlt _alt imgAlt
_title imgAlt ] _title imgAlt ]
space space
str version str version
] ]
] ]
|> Layout.bare pageTitle |> Layout.bare pageTitle
/// View for the prayer request list /// View for the prayer request list
let view m vi = let view m vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let pageTitle = $"""{s.["Prayer Requests"].Value} • {m.listGroup.name}""" let pageTitle = $"""{s["Prayer Requests"].Value} • {m.listGroup.name}"""
let spacer = rawText " &nbsp; &nbsp; &nbsp; " let spacer = rawText " &nbsp; &nbsp; &nbsp; "
let dtString = m.date.ToString "yyyy-MM-dd" let dtString = m.date.ToString "yyyy-MM-dd"
[ div [ _class "pt-center-text" ] [ [ div [ _class "pt-center-text" ] [
br [] br []
a [ _class "pt-icon-link" a [ _class "pt-icon-link"
_href $"/web/prayer-requests/print/{dtString}" _href $"/web/prayer-requests/print/{dtString}"
_title s.["View Printable"].Value ] [ _title s["View Printable"].Value
icon "print"; rawText " &nbsp;"; locStr s.["View Printable"] ] [ icon "print"; rawText " &nbsp;"; locStr s["View Printable"] ]
] if m.canEmail then
match m.canEmail with spacer
| true -> if m.date.DayOfWeek <> DayOfWeek.Sunday then
spacer let rec findSunday (date : DateTime) =
match m.date.DayOfWeek = DayOfWeek.Sunday with if date.DayOfWeek = DayOfWeek.Sunday then date else findSunday (date.AddDays 1.)
| true -> () let sunday = findSunday m.date
| false -> a [ _class "pt-icon-link"
let rec findSunday (date : DateTime) = _href $"""/web/prayer-requests/view/{sunday.ToString "yyyy-MM-dd"}"""
match date.DayOfWeek = DayOfWeek.Sunday with _title s["List for Next Sunday"].Value ] [
| true -> date icon "update"; rawText " &nbsp;"; locStr s["List for Next Sunday"]
| false -> findSunday (date.AddDays 1.)
let sunday = findSunday m.date
a [ _class "pt-icon-link"
_href $"""/web/prayer-requests/view/{sunday.ToString "yyyy-MM-dd"}"""
_title s.["List for Next Sunday"].Value ] [
icon "update"; rawText " &nbsp;"; locStr s.["List for Next Sunday"]
] ]
spacer spacer
let emailPrompt = s.["This will e-mail the current list to every member of your group, without further prompting. Are you sure this is what you are ready to do?"].Value let emailPrompt = s["This will e-mail the current list to every member of your group, without further prompting. Are you sure this is what you are ready to do?"].Value
a [ _class "pt-icon-link" a [ _class "pt-icon-link"
_href $"/web/prayer-requests/email/{dtString}" _href $"/web/prayer-requests/email/{dtString}"
_title s.["Send via E-mail"].Value _title s["Send via E-mail"].Value
_onclick $"return PT.requests.view.promptBeforeEmail('{emailPrompt}')" ] [ _onclick $"return PT.requests.view.promptBeforeEmail('{emailPrompt}')" ] [
icon "mail_outline"; rawText " &nbsp;"; locStr s.["Send via E-mail"] icon "mail_outline"; rawText " &nbsp;"; locStr s["Send via E-mail"]
] ]
spacer spacer
a [ _class "pt-icon-link"; _href "/web/prayer-requests"; _title s.["Maintain Prayer Requests"].Value ] [ a [ _class "pt-icon-link"; _href "/web/prayer-requests"; _title s["Maintain Prayer Requests"].Value ] [
icon "compare_arrows"; rawText " &nbsp;"; locStr s.["Maintain Prayer Requests"] icon "compare_arrows"; rawText " &nbsp;"; locStr s["Maintain Prayer Requests"]
] ]
| false -> ()
] ]
br [] br []
rawText (m.asHtml s) rawText (m.asHtml s)
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi pageTitle |> Layout.standard vi pageTitle

915
src/PrayerTracker.UI/SmallGroup.fs
View File

File diff suppressed because it is too large Load Diff

362
src/PrayerTracker.UI/User.fs
View File

@ -6,221 +6,219 @@ open PrayerTracker.ViewModels
/// View for the group assignment page /// View for the group assignment page
let assignGroups m groups curGroups ctx vi = let assignGroups m groups curGroups ctx vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let pageTitle = sprintf "%s • %A" m.userName s.["Assign Groups"] let pageTitle = sprintf "%s • %A" m.userName s["Assign Groups"]
form [ _action "/web/user/small-groups/save"; _method "post"; _class "pt-center-columns" ] [ form [ _action "/web/user/small-groups/save"; _method "post"; _class "pt-center-columns" ] [
csrfToken ctx csrfToken ctx
input [ _type "hidden"; _name "userId"; _value (flatGuid m.userId) ] input [ _type "hidden"; _name "userId"; _value (flatGuid m.userId) ]
input [ _type "hidden"; _name "userName"; _value m.userName ] input [ _type "hidden"; _name "userName"; _value m.userName ]
table [ _class "pt-table" ] [ table [ _class "pt-table" ] [
thead [] [ thead [] [
tr [] [ tr [] [
th [] [ rawText "&nbsp;" ] th [] [ rawText "&nbsp;" ]
th [] [ locStr s.["Group"] ] th [] [ locStr s["Group"] ]
] ]
]
groups
|> List.map (fun (grpId, grpName) ->
let inputId = $"id-{grpId}"
tr [] [
td [] [
input [ _type "checkbox"
_name "smallGroups"
_id inputId
_value grpId
match curGroups |> List.contains grpId with true -> _checked | false -> () ]
]
td [] [ label [ _for inputId ] [ str grpName ] ]
])
|> tbody []
] ]
groups div [ _class "pt-field-row" ] [ submit [] "save" s["Save Group Assignments"] ]
|> List.map (fun (grpId, grpName) ->
let inputId = $"id-{grpId}"
tr [] [
td [] [
input [ _type "checkbox"
_name "smallGroups"
_id inputId
_value grpId
match curGroups |> List.contains grpId with true -> _checked | false -> () ]
]
td [] [ label [ _for inputId ] [ str grpName ] ]
])
|> tbody []
]
div [ _class "pt-field-row" ] [ submit [] "save" s.["Save Group Assignments"] ]
] ]
|> List.singleton |> List.singleton
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi pageTitle |> Layout.standard vi pageTitle
/// View for the password change page /// View for the password change page
let changePassword ctx vi = let changePassword ctx vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
[ p [ _class "pt-center-text" ] [ [ p [ _class "pt-center-text" ] [
locStr s.["To change your password, enter your current password in the specified box below, then enter your new password twice."] locStr s["To change your password, enter your current password in the specified box below, then enter your new password twice."]
] ]
form [ _action "/web/user/password/change" form [ _action "/web/user/password/change"
_method "post" _method "post"
_onsubmit $"""return PT.compareValidation('newPassword','newPasswordConfirm','%A{s.["The passwords do not match"]}')""" ] [ _onsubmit $"""return PT.compareValidation('newPassword','newPasswordConfirm','%A{s["The passwords do not match"]}')""" ] [
style [ _scoped ] [ rawText "#oldPassword, #newPassword, #newPasswordConfirm { width: 10rem; } "] style [ _scoped ] [ rawText "#oldPassword, #newPassword, #newPasswordConfirm { width: 10rem; } "]
csrfToken ctx csrfToken ctx
div [ _class "pt-field-row" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "oldPassword" ] [ locStr s.["Current Password"] ] label [ _for "oldPassword" ] [ locStr s["Current Password"] ]
input [ _type "password"; _name "oldPassword"; _id "oldPassword"; _required; _autofocus ] input [ _type "password"; _name "oldPassword"; _id "oldPassword"; _required; _autofocus ]
]
] ]
] div [ _class "pt-field-row" ] [
div [ _class "pt-field-row" ] [ div [ _class "pt-field" ] [
div [ _class "pt-field" ] [ label [ _for "newPassword" ] [ locStr s["New Password Twice"] ]
label [ _for "newPassword" ] [ locStr s.["New Password Twice"] ] input [ _type "password"; _name "newPassword"; _id "newPassword"; _required ]
input [ _type "password"; _name "newPassword"; _id "newPassword"; _required ] ]
div [ _class "pt-field" ] [
label [] [ rawText "&nbsp;" ]
input [ _type "password"; _name "newPasswordConfirm"; _id "newPasswordConfirm"; _required ]
]
] ]
div [ _class "pt-field" ] [ div [ _class "pt-field-row" ] [
label [] [ rawText "&nbsp;" ] submit [ _onclick "document.getElementById('newPasswordConfirm').setCustomValidity('')" ] "done"
input [ _type "password"; _name "newPasswordConfirm"; _id "newPasswordConfirm"; _required ] s["Change Your Password"]
] ]
]
div [ _class "pt-field-row" ] [
submit [ _onclick "document.getElementById('newPasswordConfirm').setCustomValidity('')" ] "done"
s.["Change Your Password"]
]
] ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "Change Your Password" |> Layout.standard vi "Change Your Password"
/// View for the edit user page /// View for the edit user page
let edit (m : EditUser) ctx vi = let edit (m : EditUser) ctx vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let pageTitle = match m.isNew () with true -> "Add a New User" | false -> "Edit User" let pageTitle = if m.isNew () then "Add a New User" else "Edit User"
let pwPlaceholder = s.[match m.isNew () with true -> "" | false -> "No change"].Value let pwPlaceholder = s[if m.isNew () then "" else "No change"].Value
[ form [ _action "/web/user/edit/save"; _method "post"; _class "pt-center-columns" [ form [ _action "/web/user/edit/save"; _method "post"; _class "pt-center-columns"
_onsubmit $"""return PT.compareValidation('password','passwordConfirm','%A{s.["The passwords do not match"]}')""" ] [ _onsubmit $"""return PT.compareValidation('password','passwordConfirm','%A{s["The passwords do not match"]}')""" ] [
style [ _scoped ] style [ _scoped ]
[ rawText "#firstName, #lastName, #password, #passwordConfirm { width: 10rem; } #emailAddress { width: 20rem; } " ] [ rawText "#firstName, #lastName, #password, #passwordConfirm { width: 10rem; } #emailAddress { width: 20rem; } " ]
csrfToken ctx csrfToken ctx
input [ _type "hidden"; _name "userId"; _value (flatGuid m.userId) ] input [ _type "hidden"; _name "userId"; _value (flatGuid m.userId) ]
div [ _class "pt-field-row" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "firstName" ] [ locStr s.["First Name"] ] label [ _for "firstName" ] [ locStr s["First Name"] ]
input [ _type "text"; _name "firstName"; _id "firstName"; _value m.firstName; _required; _autofocus ] input [ _type "text"; _name "firstName"; _id "firstName"; _value m.firstName; _required; _autofocus ]
] ]
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "lastName" ] [ locStr s.["Last Name"] ] label [ _for "lastName" ] [ locStr s["Last Name"] ]
input [ _type "text"; _name "lastName"; _id "lastName"; _value m.lastName; _required ] input [ _type "text"; _name "lastName"; _id "lastName"; _value m.lastName; _required ]
] ]
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "emailAddress" ] [ locStr s.["E-mail Address"] ] label [ _for "emailAddress" ] [ locStr s["E-mail Address"] ]
input [ _type "email"; _name "emailAddress"; _id "emailAddress"; _value m.emailAddress; _required ] input [ _type "email"; _name "emailAddress"; _id "emailAddress"; _value m.emailAddress; _required ]
] ]
] ]
div [ _class "pt-field-row" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "password" ] [ locStr s.["Password"] ] label [ _for "password" ] [ locStr s["Password"] ]
input [ _type "password"; _name "password"; _id "password"; _placeholder pwPlaceholder ] input [ _type "password"; _name "password"; _id "password"; _placeholder pwPlaceholder ]
] ]
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "passwordConfirm" ] [ locStr s.["Password Again"] ] label [ _for "passwordConfirm" ] [ locStr s["Password Again"] ]
input [ _type "password"; _name "passwordConfirm"; _id "passwordConfirm"; _placeholder pwPlaceholder ] input [ _type "password"; _name "passwordConfirm"; _id "passwordConfirm"; _placeholder pwPlaceholder ]
] ]
] ]
div [ _class "pt-checkbox-field" ] [ div [ _class "pt-checkbox-field" ] [
input [ _type "checkbox" input [ _type "checkbox"
_name "isAdmin" _name "isAdmin"
_id "isAdmin" _id "isAdmin"
_value "True" _value "True"
match m.isAdmin with Some x when x -> _checked | _ -> () ] match m.isAdmin with Some x when x -> _checked | _ -> () ]
label [ _for "isAdmin" ] [ locStr s.["This user is a PrayerTracker administrator"] ] label [ _for "isAdmin" ] [ locStr s["This user is a PrayerTracker administrator"] ]
] ]
div [ _class "pt-field-row" ] [ submit [] "save" s.["Save User"] ] div [ _class "pt-field-row" ] [ submit [] "save" s["Save User"] ]
] ]
script [] [ rawText $"PT.onLoad(PT.user.edit.onPageLoad({(string (m.isNew ())).ToLower ()}))" ] script [] [ rawText $"PT.onLoad(PT.user.edit.onPageLoad({(string (m.isNew ())).ToLower ()}))" ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi pageTitle |> Layout.standard vi pageTitle
/// View for the user log on page /// View for the user log on page
let logOn (m : UserLogOn) groups ctx vi = let logOn (m : UserLogOn) groups ctx vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
form [ _action "/web/user/log-on"; _method "post"; _class "pt-center-columns" ] [ form [ _action "/web/user/log-on"; _method "post"; _class "pt-center-columns" ] [
style [ _scoped ] [ rawText "#emailAddress { width: 20rem; }" ] style [ _scoped ] [ rawText "#emailAddress { width: 20rem; }" ]
csrfToken ctx csrfToken ctx
input [ _type "hidden"; _name "redirectUrl"; _value (defaultArg m.redirectUrl "") ] input [ _type "hidden"; _name "redirectUrl"; _value (defaultArg m.redirectUrl "") ]
div [ _class "pt-field-row" ] [ div [ _class "pt-field-row" ] [
div [ _class "pt-field" ] [ div [ _class "pt-field" ] [
label [ _for "emailAddress"] [ locStr s.["E-mail Address"] ] label [ _for "emailAddress"] [ locStr s["E-mail Address"] ]
input [ _type "email"; _name "emailAddress"; _id "emailAddress"; _value m.emailAddress; _required; _autofocus ] input [ _type "email"; _name "emailAddress"; _id "emailAddress"; _value m.emailAddress; _required
_autofocus ]
]
div [ _class "pt-field" ] [
label [ _for "password" ] [ locStr s["Password"] ]
input [ _type "password"; _name "password"; _id "password"; _required;
_placeholder (sprintf "(%s)" (s["Case-Sensitive"].Value.ToLower ())) ]
]
] ]
div [ _class "pt-field" ] [ div [ _class "pt-field-row" ] [
label [ _for "password" ] [ locStr s.["Password"] ] div [ _class "pt-field" ] [
input [ _type "password"; _name "password"; _id "password"; _required; label [ _for "smallGroupId" ] [ locStr s["Group"] ]
_placeholder (sprintf "(%s)" (s.["Case-Sensitive"].Value.ToLower ())) ] seq {
"", selectDefault s["Select Group"].Value
yield! groups
}
|> selectList "smallGroupId" "" [ _required ]
]
] ]
] div [ _class "pt-checkbox-field" ] [
div [ _class "pt-field-row" ] [ input [ _type "checkbox"; _name "rememberMe"; _id "rememberMe"; _value "True" ]
div [ _class "pt-field" ] [ label [ _for "rememberMe" ] [ locStr s["Remember Me"] ]
label [ _for "smallGroupId" ] [ locStr s.["Group"] ] br []
seq { small [] [ em [] [ rawText "("; str (s["Requires Cookies"].Value.ToLower ()); rawText ")" ] ]
"", selectDefault s.["Select Group"].Value
yield! groups
}
|> selectList "smallGroupId" "" [ _required ]
] ]
] div [ _class "pt-field-row" ] [ submit [] "account_circle" s["Log On"] ]
div [ _class "pt-checkbox-field" ] [
input [ _type "checkbox"; _name "rememberMe"; _id "rememberMe"; _value "True" ]
label [ _for "rememberMe" ] [ locStr s.["Remember Me"] ]
br []
small [] [ em [] [ rawText "("; str (s.["Requires Cookies"].Value.ToLower ()); rawText ")" ] ]
]
div [ _class "pt-field-row" ] [ submit [] "account_circle" s.["Log On"] ]
] ]
|> List.singleton |> List.singleton
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "User Log On" |> Layout.standard vi "User Log On"
/// View for the user maintenance page /// View for the user maintenance page
let maintain (users : User list) ctx vi = let maintain (users : User list) ctx vi =
let s = I18N.localizer.Force () let s = I18N.localizer.Force ()
let usrTbl = let usrTbl =
match users with match users with
| [] -> space | [] -> space
| _ -> | _ ->
table [ _class "pt-table pt-action-table" ] [ table [ _class "pt-table pt-action-table" ] [
thead [] [ thead [] [
tr [] [ tr [] [
th [] [ locStr s.["Actions"] ] th [] [ locStr s["Actions"] ]
th [] [ locStr s.["Name"] ] th [] [ locStr s["Name"] ]
th [] [ locStr s.["Admin?"] ] th [] [ locStr s["Admin?"] ]
]
]
users
|> List.map (fun user ->
let userId = flatGuid user.userId
let delAction = $"/web/user/{userId}/delete"
let delPrompt = s["Are you sure you want to delete this {0}? This action cannot be undone.",
$"""{s["User"].Value.ToLower ()} ({user.fullName})"""].Value
tr [] [
td [] [
a [ _href $"/web/user/{userId}/edit"; _title s["Edit This User"].Value ] [ icon "edit" ]
a [ _href $"/web/user/{userId}/small-groups"; _title s["Assign Groups to This User"].Value ]
[ icon "group" ]
a [ _href delAction
_title s["Delete This User"].Value
_onclick $"return PT.confirmDelete('{delAction}','{delPrompt}')" ]
[ icon "delete_forever" ]
]
td [] [ str user.fullName ]
td [ _class "pt-center-text" ] [
if user.isAdmin then strong [] [ locStr s["Yes"] ] else locStr s["No"]
]
])
|> tbody []
] ]
] [ div [ _class "pt-center-text" ] [
users br []
|> List.map (fun user -> a [ _href $"/web/user/{emptyGuid}/edit"; _title s["Add a New User"].Value ]
let userId = flatGuid user.userId [ icon "add_circle"; rawText " &nbsp;"; locStr s["Add a New User"] ]
let delAction = $"/web/user/{userId}/delete" br []
let delPrompt = s.["Are you sure you want to delete this {0}? This action cannot be undone.", br []
$"""{s.["User"].Value.ToLower ()} ({user.fullName})"""].Value
tr [] [
td [] [
a [ _href $"/web/user/{userId}/edit"; _title s.["Edit This User"].Value ] [ icon "edit" ]
a [ _href $"/web/user/{userId}/small-groups"; _title s.["Assign Groups to This User"].Value ]
[ icon "group" ]
a [ _href delAction
_title s.["Delete This User"].Value
_onclick $"return PT.confirmDelete('{delAction}','{delPrompt}')" ]
[ icon "delete_forever" ]
]
td [] [ str user.fullName ]
td [ _class "pt-center-text" ] [
match user.isAdmin with
| true -> strong [] [ locStr s.["Yes"] ]
| false -> locStr s.["No"]
]
])
|> tbody []
]
[ div [ _class "pt-center-text" ] [
br []
a [ _href $"/web/user/{emptyGuid}/edit"; _title s.["Add a New User"].Value ]
[ icon "add_circle"; rawText " &nbsp;"; locStr s.["Add a New User"] ]
br []
br []
] ]
tableSummary users.Length s tableSummary users.Length s
usrTbl usrTbl
form [ _id "DeleteForm"; _action ""; _method "post" ] [ csrfToken ctx ] form [ _id "DeleteForm"; _action ""; _method "post" ] [ csrfToken ctx ]
] ]
|> Layout.Content.standard |> Layout.Content.standard
|> Layout.standard vi "Maintain Users" |> Layout.standard vi "Maintain Users"

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

@ -1,207 +1,219 @@
[<AutoOpen>] [<AutoOpen>]
module PrayerTracker.Utils module PrayerTracker.Utils
open System.Net open System
open System.Security.Cryptography open System.Security.Cryptography
open System.Text open System.Text
open System.Text.RegularExpressions
open System
/// Hash a string with a SHA1 hash /// Hash a string with a SHA1 hash
let sha1Hash (x : string) = let sha1Hash (x : string) =
use alg = SHA1.Create () use alg = SHA1.Create ()
alg.ComputeHash (Encoding.ASCII.GetBytes x) alg.ComputeHash (Encoding.ASCII.GetBytes x)
|> Seq.map (fun chr -> chr.ToString "x2") |> Seq.map (fun chr -> chr.ToString "x2")
|> String.concat "" |> String.concat ""
/// Hash a string using 1,024 rounds of PBKDF2 and a salt /// Hash a string using 1,024 rounds of PBKDF2 and a salt
let pbkdf2Hash (salt : Guid) (x : string) = let pbkdf2Hash (salt : Guid) (x : string) =
use alg = new Rfc2898DeriveBytes (x, Encoding.UTF8.GetBytes (salt.ToString "N"), 1024) use alg = new Rfc2898DeriveBytes (x, Encoding.UTF8.GetBytes (salt.ToString "N"), 1024)
(alg.GetBytes >> Convert.ToBase64String) 64 (alg.GetBytes >> Convert.ToBase64String) 64
/// String helper functions /// String helper functions
module String = module String =
/// string.Trim() /// string.Trim()
let trim (str: string) = str.Trim () let trim (str: string) = str.Trim ()
/// string.Replace() /// string.Replace()
let replace (find : string) repl (str : string) = str.Replace (find, repl) let replace (find : string) repl (str : string) = str.Replace (find, repl)
/// Replace the first occurrence of a string with a second string within a given string /// Replace the first occurrence of a string with a second string within a given string
let replaceFirst (needle : string) replacement (haystack : string) = let replaceFirst (needle : string) replacement (haystack : string) =
match haystack.IndexOf needle with match haystack.IndexOf needle with
| -1 -> haystack | -1 -> haystack
| idx -> | idx ->
[ haystack.[0..idx - 1] [ haystack[0..idx - 1]
replacement replacement
haystack.[idx + needle.Length..] haystack[idx + needle.Length..]
] ]
|> String.concat "" |> String.concat ""
open System.Text.RegularExpressions
/// Strip HTML tags from the given string /// Strip HTML tags from the given string
// Adapted from http://www.dijksterhuis.org/safely-cleaning-html-with-strip_tags-in-csharp/ // Adapted from http://www.dijksterhuis.org/safely-cleaning-html-with-strip_tags-in-csharp/
let stripTags allowedTags input = let stripTags allowedTags input =
let stripHtmlExp = Regex @"(<\/?[^>]+>)" let stripHtmlExp = Regex @"(<\/?[^>]+>)"
let mutable output = input let mutable output = input
for tag in stripHtmlExp.Matches input do for tag in stripHtmlExp.Matches input do
let htmlTag = tag.Value.ToLower () let htmlTag = tag.Value.ToLower ()
let isAllowed = let isAllowed =
allowedTags allowedTags
|> List.fold |> List.fold (fun acc t ->
(fun acc t -> acc
acc
|| htmlTag.IndexOf $"<{t}>" = 0 || htmlTag.IndexOf $"<{t}>" = 0
|| htmlTag.IndexOf $"<{t} " = 0 || htmlTag.IndexOf $"<{t} " = 0
|| htmlTag.IndexOf $"</{t}" = 0) false || htmlTag.IndexOf $"</{t}" = 0) false
match isAllowed with if isAllowed then output <- String.replaceFirst tag.Value "" output
| true -> () output
| false -> output <- String.replaceFirst tag.Value "" output
output
/// Wrap a string at the specified number of characters /// Wrap a string at the specified number of characters
let wordWrap charPerLine (input : string) = let wordWrap charPerLine (input : string) =
match input.Length with match input.Length with
| len when len <= charPerLine -> input | len when len <= charPerLine -> input
| _ -> | _ ->
seq { seq {
for line in input.Replace("\r", "").Split '\n' do for line in input.Replace("\r", "").Split '\n' do
let mutable remaining = line let mutable remaining = line
match remaining.Length with match remaining.Length with
| 0 -> () | 0 -> ()
| _ -> | _ ->
while charPerLine < remaining.Length do while charPerLine < remaining.Length do
match charPerLine + 1 < remaining.Length && remaining.[charPerLine] = ' ' with if charPerLine + 1 < remaining.Length && remaining[charPerLine] = ' ' then
| true -> // Line length is followed by a space; return [charPerLine] as a line
// Line length is followed by a space; return [charPerLine] as a line yield remaining[0..charPerLine - 1]
yield remaining.[0..charPerLine - 1] remaining <- remaining[charPerLine + 1..]
remaining <- remaining.[charPerLine + 1..] else
| false -> match remaining[0..charPerLine - 1].LastIndexOf ' ' with
match remaining.[0..charPerLine - 1].LastIndexOf ' ' with | -1 ->
| -1 -> // No whitespace; just break it at [characters]
// No whitespace; just break it at [characters] yield remaining[0..charPerLine - 1]
yield remaining.[0..charPerLine - 1] remaining <- remaining[charPerLine..]
remaining <- remaining.[charPerLine..] | spaceIdx ->
| spaceIdx -> // Break on the last space in the line
// Break on the last space in the line yield remaining[0..spaceIdx - 1]
yield remaining.[0..spaceIdx - 1] remaining <- remaining[spaceIdx + 1..]
remaining <- remaining.[spaceIdx + 1..] // Leftovers - yum!
// Leftovers - yum! match remaining.Length with 0 -> () | _ -> yield remaining
match remaining.Length with 0 -> () | _ -> yield remaining
} }
|> Seq.fold (fun (acc : StringBuilder) line -> acc.AppendFormat ("{0}\n", line)) (StringBuilder ()) |> Seq.fold (fun (acc : StringBuilder) -> acc.AppendLine) (StringBuilder ())
|> string |> string
/// Modify the text returned by CKEditor into the format we need for request and announcement text /// Modify the text returned by CKEditor into the format we need for request and announcement text
let ckEditorToText (text : string) = let ckEditorToText (text : string) =
let trim (str : string) = str.Trim () [ "\n\t", ""
[ "\n\t", "" "&nbsp;", " "
"&nbsp;", " " " ", "&#xa0; "
" ", "&#xa0; " "</p><p>", "<br><br>"
"</p><p>", "<br><br>" "</p>", ""
"</p>", "" "<p>", ""
"<p>", ""
] ]
|> List.fold (fun (txt : string) (x, y) -> String.replace x y txt) text |> List.fold (fun (txt : string) (x, y) -> String.replace x y txt) text
|> trim |> String.trim
open System.Net
/// Convert an HTML piece of text to plain text /// Convert an HTML piece of text to plain text
let htmlToPlainText html = let htmlToPlainText html =
match html with match html with
| null | "" -> "" | null | "" -> ""
| _ -> | _ ->
html.Trim () html.Trim ()
|> stripTags [ "br" ] |> stripTags [ "br" ]
|> String.replace "<br />" "\n" |> String.replace "<br />" "\n"
|> String.replace "<br>" "\n" |> String.replace "<br>" "\n"
|> WebUtility.HtmlDecode |> WebUtility.HtmlDecode
|> String.replace "\u00a0" " " |> String.replace "\u00a0" " "
/// Get the second portion of a tuple as a string /// Get the second portion of a tuple as a string
let sndAsString x = (snd >> string) x let sndAsString x = (snd >> string) x
/// Make a URL with query string parameters /// Make a URL with query string parameters
let makeUrl (url : string) (qs : (string * string) list) = let makeUrl url qs =
let queryString = if List.isEmpty qs then url
qs else $"""{url}?{String.Join('&', List.map (fun (k, v) -> $"%s{k}={WebUtility.UrlEncode v}") qs)}"""
|> List.fold
(fun (acc : StringBuilder) (key, value) ->
acc.Append(key).Append("=").Append(WebUtility.UrlEncode value).Append "&")
(StringBuilder ())
match queryString.Length with
| 0 -> url
| _ -> queryString.Insert(0, "?").Insert(0, url).Remove(queryString.Length - 1, 1).ToString ()
/// "Magic string" repository /// "Magic string" repository
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module Key = module Key =
/// This contains constants for session-stored objects within PrayerTracker /// This contains constants for session-stored objects within PrayerTracker
module Session = module Session =
/// The currently logged-on small group
let currentGroup = "CurrentGroup" /// The currently logged-on small group
/// The currently logged-on user let currentGroup = "CurrentGroup"
let currentUser = "CurrentUser"
/// User messages to be displayed the next time a page is sent /// The currently logged-on user
let userMessages = "UserMessages" let currentUser = "CurrentUser"
/// The URL to which the user should be redirected once they have logged in
let redirectUrl = "RedirectUrl" /// User messages to be displayed the next time a page is sent
let userMessages = "UserMessages"
/// The URL to which the user should be redirected once they have logged in
let redirectUrl = "RedirectUrl"
/// Names and value names for use with cookies /// Names and value names for use with cookies
module Cookie = module Cookie =
/// The name of the user cookie
let user = "LoggedInUser" /// The name of the user cookie
/// The name of the class cookie let user = "LoggedInUser"
let group = "LoggedInClass"
/// The name of the culture cookie /// The name of the class cookie
let culture = "CurrentCulture" let group = "LoggedInClass"
/// The name of the idle timeout cookie
let timeout = "TimeoutCookie" /// The name of the culture cookie
/// The cookies that should be cleared when a user or group logs off let culture = "CurrentCulture"
let logOffCookies = [ user; group; timeout ]
/// The name of the idle timeout cookie
let timeout = "TimeoutCookie"
/// The cookies that should be cleared when a user or group logs off
let logOffCookies = [ user; group; timeout ]
/// Enumerated values for small group request list visibility (derived from preferences, used in UI) /// Enumerated values for small group request list visibility (derived from preferences, used in UI)
module RequestVisibility = module RequestVisibility =
/// Requests are publicly accessible
[<Literal>] /// Requests are publicly accessible
let ``public`` = 1 [<Literal>]
/// The small group members can enter a password to view the request list let ``public`` = 1
[<Literal>]
let passwordProtected = 2 /// The small group members can enter a password to view the request list
/// No one can see the requests for a small group except its administrators ("User" access level) [<Literal>]
[<Literal>] let passwordProtected = 2
let ``private`` = 3
/// No one can see the requests for a small group except its administrators ("User" access level)
[<Literal>]
let ``private`` = 3
/// Links for help locations /// Links for help locations
module Help = module Help =
/// Help link for small group preference edit page
let groupPreferences = "small-group/preferences" /// Help link for small group preference edit page
/// Help link for send announcement page let groupPreferences = "small-group/preferences"
let sendAnnouncement = "small-group/announcement"
/// Help link for maintain group members page /// Help link for send announcement page
let maintainGroupMembers = "small-group/members" let sendAnnouncement = "small-group/announcement"
/// Help link for request edit page
let editRequest = "requests/edit" /// Help link for maintain group members page
/// Help link for maintain requests page let maintainGroupMembers = "small-group/members"
let maintainRequests = "requests/maintain"
/// Help link for view request list page /// Help link for request edit page
let viewRequestList = "requests/view" let editRequest = "requests/edit"
/// Help link for user and class login pages
let logOn = "user/log-on" /// Help link for maintain requests page
/// Help link for user password change page let maintainRequests = "requests/maintain"
let changePassword = "user/password"
/// Create a full link for a help page /// Help link for view request list page
let fullLink lang url = $"https://docs.prayer.bitbadger.solutions/%s{lang}/%s{url}.html" let viewRequestList = "requests/view"
/// Help link for user and class login pages
let logOn = "user/log-on"
/// Help link for user password change page
let changePassword = "user/password"
/// Create a full link for a help page
let fullLink lang url = $"https://docs.prayer.bitbadger.solutions/%s{lang}/%s{url}.html"
/// This class serves as a common anchor for resources /// This class serves as a common anchor for resources
type Common () = type Common () =
do () do ()

1233
src/PrayerTracker.UI/ViewModels.fs
View File

File diff suppressed because it is too large Load Diff

359
src/PrayerTracker/App.fs
View File

@ -7,195 +7,196 @@ open Microsoft.AspNetCore.Hosting
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module Configure = module Configure =
open Cookies open Cookies
open Giraffe open Giraffe
open Giraffe.EndpointRouting open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Localization open Microsoft.AspNetCore.Localization
open Microsoft.AspNetCore.Server.Kestrel.Core open Microsoft.AspNetCore.Server.Kestrel.Core
open Microsoft.EntityFrameworkCore open Microsoft.EntityFrameworkCore
open Microsoft.Extensions.Configuration open Microsoft.Extensions.Configuration
open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Hosting open Microsoft.Extensions.Hosting
open Microsoft.Extensions.Localization open Microsoft.Extensions.Localization
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
open Microsoft.Extensions.Options open Microsoft.Extensions.Options
open NodaTime open NodaTime
open System.Globalization open System.Globalization
/// Set up the configuration for the app /// Set up the configuration for the app
let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) = let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) =
cfg.SetBasePath(ctx.HostingEnvironment.ContentRootPath) cfg.SetBasePath(ctx.HostingEnvironment.ContentRootPath)
.AddJsonFile("appsettings.json", optional = true, reloadOnChange = true) .AddJsonFile("appsettings.json", optional = true, reloadOnChange = true)
.AddJsonFile($"appsettings.{ctx.HostingEnvironment.EnvironmentName}.json", optional = true) .AddJsonFile($"appsettings.{ctx.HostingEnvironment.EnvironmentName}.json", optional = true)
.AddEnvironmentVariables() .AddEnvironmentVariables()
|> ignore |> ignore
/// Configure Kestrel from appsettings.json /// Configure Kestrel from appsettings.json
let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) = let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
(ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel" (ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
let services (svc : IServiceCollection) = let services (svc : IServiceCollection) =
svc.AddOptions() let _ = svc.AddOptions()
.AddLocalization(fun options -> options.ResourcesPath <- "Resources") let _ = svc.AddLocalization(fun options -> options.ResourcesPath <- "Resources")
.Configure<RequestLocalizationOptions>( let _ =
fun (opts : RequestLocalizationOptions) -> svc.Configure<RequestLocalizationOptions>(fun (opts : RequestLocalizationOptions) ->
let supportedCultures = let supportedCultures =[|
[| CultureInfo "en-US"; CultureInfo "en-GB"; CultureInfo "en-AU"; CultureInfo "en" CultureInfo "en-US"; CultureInfo "en-GB"; CultureInfo "en-AU"; CultureInfo "en"
CultureInfo "es-MX"; CultureInfo "es-ES"; CultureInfo "es" CultureInfo "es-MX"; CultureInfo "es-ES"; CultureInfo "es"
|] |]
opts.DefaultRequestCulture <- RequestCulture ("en-US", "en-US") opts.DefaultRequestCulture <- RequestCulture ("en-US", "en-US")
opts.SupportedCultures <- supportedCultures opts.SupportedCultures <- supportedCultures
opts.SupportedUICultures <- supportedCultures) opts.SupportedUICultures <- supportedCultures)
.AddDistributedMemoryCache() let _ = svc.AddDistributedMemoryCache()
.AddSession() let _ = svc.AddSession()
.AddAntiforgery() let _ = svc.AddAntiforgery()
.AddRouting() let _ = svc.AddRouting()
.AddSingleton<IClock>(SystemClock.Instance) let _ = svc.AddSingleton<IClock>(SystemClock.Instance)
|> ignore
let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration>() let config = svc.BuildServiceProvider().GetRequiredService<IConfiguration>()
let crypto = config.GetSection "CookieCrypto" let crypto = config.GetSection "CookieCrypto"
CookieCrypto (crypto.["Key"], crypto.["IV"]) |> setCrypto CookieCrypto (crypto["Key"], crypto["IV"]) |> setCrypto
svc.AddDbContext<AppDbContext>(
(fun options -> let _ = svc.AddDbContext<AppDbContext>(
options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore), (fun options ->
ServiceLifetime.Scoped, ServiceLifetime.Singleton) options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
|> ignore ServiceLifetime.Scoped, ServiceLifetime.Singleton)
()
/// Routes for PrayerTracker
let routes = /// Routes for PrayerTracker
[ subRoute "/web" [ let routes = [
GET_HEAD [ subRoute "/web" [
subRoute "/church" [ GET_HEAD [
route "es" Handlers.Church.maintain subRoute "/church" [
routef "/%O/edit" Handlers.Church.edit route "es" Handlers.Church.maintain
routef "/%O/edit" Handlers.Church.edit
]
route "/class/logon" (redirectTo true "/web/small-group/log-on")
routef "/error/%s" Handlers.Home.error
routef "/language/%s" Handlers.Home.language
subRoute "/legal" [
route "/privacy-policy" Handlers.Home.privacyPolicy
route "/terms-of-service" Handlers.Home.tos
]
route "/log-off" Handlers.Home.logOff
subRoute "/prayer-request" [
route "s" (Handlers.PrayerRequest.maintain true)
routef "s/email/%s" Handlers.PrayerRequest.email
route "s/inactive" (Handlers.PrayerRequest.maintain false)
route "s/lists" Handlers.PrayerRequest.lists
routef "s/%O/list" Handlers.PrayerRequest.list
route "s/maintain" (redirectTo true "/web/prayer-requests")
routef "s/print/%s" Handlers.PrayerRequest.print
route "s/view" (Handlers.PrayerRequest.view None)
routef "s/view/%s" (Some >> Handlers.PrayerRequest.view)
routef "/%O/edit" Handlers.PrayerRequest.edit
routef "/%O/expire" Handlers.PrayerRequest.expire
routef "/%O/restore" Handlers.PrayerRequest.restore
]
subRoute "/small-group" [
route "" Handlers.SmallGroup.overview
route "s" Handlers.SmallGroup.maintain
route "/announcement" Handlers.SmallGroup.announcement
routef "/%O/edit" Handlers.SmallGroup.edit
route "/log-on" (Handlers.SmallGroup.logOn None)
routef "/log-on/%O" (Some >> Handlers.SmallGroup.logOn)
route "/logon" (redirectTo true "/web/small-group/log-on")
routef "/member/%O/edit" Handlers.SmallGroup.editMember
route "/members" Handlers.SmallGroup.members
route "/preferences" Handlers.SmallGroup.preferences
]
route "/unauthorized" Handlers.Home.unauthorized
subRoute "/user" [
route "s" Handlers.User.maintain
routef "/%O/edit" Handlers.User.edit
routef "/%O/small-groups" Handlers.User.smallGroups
route "/log-on" Handlers.User.logOn
route "/logon" (redirectTo true "/web/user/log-on")
route "/password" Handlers.User.password
]
route "/" Handlers.Home.homePage
] ]
route "/class/logon" (redirectTo true "/web/small-group/log-on") POST [
routef "/error/%s" Handlers.Home.error subRoute "/church" [
routef "/language/%s" Handlers.Home.language routef "/%O/delete" Handlers.Church.delete
subRoute "/legal" [ route "/save" Handlers.Church.save
route "/privacy-policy" Handlers.Home.privacyPolicy ]
route "/terms-of-service" Handlers.Home.tos subRoute "/prayer-request" [
routef "/%O/delete" Handlers.PrayerRequest.delete
route "/save" Handlers.PrayerRequest.save
]
subRoute "/small-group" [
route "/announcement/send" Handlers.SmallGroup.sendAnnouncement
routef "/%O/delete" Handlers.SmallGroup.delete
route "/log-on/submit" Handlers.SmallGroup.logOnSubmit
routef "/member/%O/delete" Handlers.SmallGroup.deleteMember
route "/member/save" Handlers.SmallGroup.saveMember
route "/preferences/save" Handlers.SmallGroup.savePreferences
route "/save" Handlers.SmallGroup.save
]
subRoute "/user" [
routef "/%O/delete" Handlers.User.delete
route "/edit/save" Handlers.User.save
route "/log-on" Handlers.User.doLogOn
route "/password/change" Handlers.User.changePassword
route "/small-groups/save" Handlers.User.saveGroups
]
] ]
route "/log-off" Handlers.Home.logOff
subRoute "/prayer-request" [
route "s" (Handlers.PrayerRequest.maintain true)
routef "s/email/%s" Handlers.PrayerRequest.email
route "s/inactive" (Handlers.PrayerRequest.maintain false)
route "s/lists" Handlers.PrayerRequest.lists
routef "s/%O/list" Handlers.PrayerRequest.list
route "s/maintain" (redirectTo true "/web/prayer-requests")
routef "s/print/%s" Handlers.PrayerRequest.print
route "s/view" (Handlers.PrayerRequest.view None)
routef "s/view/%s" (Some >> Handlers.PrayerRequest.view)
routef "/%O/edit" Handlers.PrayerRequest.edit
routef "/%O/expire" Handlers.PrayerRequest.expire
routef "/%O/restore" Handlers.PrayerRequest.restore
]
subRoute "/small-group" [
route "" Handlers.SmallGroup.overview
route "s" Handlers.SmallGroup.maintain
route "/announcement" Handlers.SmallGroup.announcement
routef "/%O/edit" Handlers.SmallGroup.edit
route "/log-on" (Handlers.SmallGroup.logOn None)
routef "/log-on/%O" (Some >> Handlers.SmallGroup.logOn)
route "/logon" (redirectTo true "/web/small-group/log-on")
routef "/member/%O/edit" Handlers.SmallGroup.editMember
route "/members" Handlers.SmallGroup.members
route "/preferences" Handlers.SmallGroup.preferences
]
route "/unauthorized" Handlers.Home.unauthorized
subRoute "/user" [
route "s" Handlers.User.maintain
routef "/%O/edit" Handlers.User.edit
routef "/%O/small-groups" Handlers.User.smallGroups
route "/log-on" Handlers.User.logOn
route "/logon" (redirectTo true "/web/user/log-on")
route "/password" Handlers.User.password
]
route "/" Handlers.Home.homePage
]
POST [
subRoute "/church" [
routef "/%O/delete" Handlers.Church.delete
route "/save" Handlers.Church.save
]
subRoute "/prayer-request" [
routef "/%O/delete" Handlers.PrayerRequest.delete
route "/save" Handlers.PrayerRequest.save
]
subRoute "/small-group" [
route "/announcement/send" Handlers.SmallGroup.sendAnnouncement
routef "/%O/delete" Handlers.SmallGroup.delete
route "/log-on/submit" Handlers.SmallGroup.logOnSubmit
routef "/member/%O/delete" Handlers.SmallGroup.deleteMember
route "/member/save" Handlers.SmallGroup.saveMember
route "/preferences/save" Handlers.SmallGroup.savePreferences
route "/save" Handlers.SmallGroup.save
]
subRoute "/user" [
routef "/%O/delete" Handlers.User.delete
route "/edit/save" Handlers.User.save
route "/log-on" Handlers.User.doLogOn
route "/password/change" Handlers.User.changePassword
route "/small-groups/save" Handlers.User.saveGroups
]
]
] ]
// Temp redirect to new URLs // Temp redirect to new URLs
route "/" (redirectTo false "/web/") route "/" (redirectTo false "/web/")
] ]
/// Giraffe error handler /// Giraffe error handler
let errorHandler (ex : exn) (logger : ILogger) = let errorHandler (ex : exn) (logger : ILogger) =
logger.LogError(EventId(), ex, "An unhandled exception has occurred while executing the request.") logger.LogError (EventId(), ex, "An unhandled exception has occurred while executing the request.")
clearResponse >=> setStatusCode 500 >=> text ex.Message clearResponse >=> setStatusCode 500 >=> text ex.Message
/// Configure logging /// Configure logging
let logging (log : ILoggingBuilder) = let logging (log : ILoggingBuilder) =
let env = log.Services.BuildServiceProvider().GetService<IWebHostEnvironment> () let env = log.Services.BuildServiceProvider().GetService<IWebHostEnvironment> ()
match env.IsDevelopment () with if env.IsDevelopment () then log else log.AddFilter (fun l -> l > LogLevel.Information)
| true -> log |> function l -> l.AddConsole().AddDebug()
| false -> log.AddFilter (fun l -> l > LogLevel.Information) |> ignore
|> function l -> l.AddConsole().AddDebug()
|> ignore let app (app : IApplicationBuilder) =
let env = app.ApplicationServices.GetRequiredService<IWebHostEnvironment>()
let app (app : IApplicationBuilder) = if env.IsDevelopment () then
let env = app.ApplicationServices.GetRequiredService<IWebHostEnvironment>() let _ = app.UseDeveloperExceptionPage ()
(match env.IsDevelopment () with ()
| true -> else
app.UseDeveloperExceptionPage () try
| false -> use scope = app.ApplicationServices.GetRequiredService<IServiceScopeFactory>().CreateScope ()
try scope.ServiceProvider.GetService<AppDbContext>().Database.Migrate ()
use scope = app.ApplicationServices.GetRequiredService<IServiceScopeFactory>().CreateScope () with _ -> () // om nom nom
scope.ServiceProvider.GetService<AppDbContext>().Database.Migrate () let _ = app.UseGiraffeErrorHandler errorHandler
with _ -> () // om nom nom ()
app.UseGiraffeErrorHandler errorHandler)
.UseStatusCodePagesWithReExecute("/error/{0}") let _ = app.UseStatusCodePagesWithReExecute "/error/{0}"
.UseStaticFiles() let _ = app.UseStaticFiles ()
.UseRouting() let _ = app.UseRouting ()
.UseSession() let _ = app.UseSession ()
.UseRequestLocalization(app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value) let _ = app.UseRequestLocalization
.UseEndpoints (fun e -> e.MapGiraffeEndpoints routes) (app.ApplicationServices.GetService<IOptions<RequestLocalizationOptions>>().Value)
|> ignore let _ = app.UseEndpoints (fun e -> e.MapGiraffeEndpoints routes)
Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService<IStringLocalizerFactory> () Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService<IStringLocalizerFactory> ()
/// The web application /// The web application
module App = module App =
open System.IO open System.IO
[<EntryPoint>] [<EntryPoint>]
let main _ = let main _ =
let contentRoot = Directory.GetCurrentDirectory () let contentRoot = Directory.GetCurrentDirectory ()
WebHostBuilder() WebHostBuilder()
.UseContentRoot(contentRoot) .UseContentRoot(contentRoot)
.ConfigureAppConfiguration(Configure.configuration) .ConfigureAppConfiguration(Configure.configuration)
.UseKestrel(Configure.kestrel) .UseKestrel(Configure.kestrel)
.UseWebRoot(Path.Combine (contentRoot, "wwwroot")) .UseWebRoot(Path.Combine (contentRoot, "wwwroot"))
.ConfigureServices(Configure.services) .ConfigureServices(Configure.services)
.ConfigureLogging(Configure.logging) .ConfigureLogging(Configure.logging)
.Configure(System.Action<IApplicationBuilder> Configure.app) .Configure(System.Action<IApplicationBuilder> Configure.app)
.Build() .Build()
.Run () .Run ()
0 0

76
src/PrayerTracker/Church.fs
View File

@ -1,27 +1,24 @@
module PrayerTracker.Handlers.Church module PrayerTracker.Handlers.Church
open System
open System.Threading.Tasks
open Giraffe open Giraffe
open PrayerTracker open PrayerTracker
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open PrayerTracker.Views.CommonFunctions open PrayerTracker.Views.CommonFunctions
open System
open System.Threading.Tasks
/// Find statistics for the given church /// Find statistics for the given church
let private findStats (db : AppDbContext) churchId = task { let private findStats (db : AppDbContext) churchId = task {
let! grps = db.CountGroupsByChurch churchId let! grps = db.CountGroupsByChurch churchId
let! reqs = db.CountRequestsByChurch churchId let! reqs = db.CountRequestsByChurch churchId
let! usrs = db.CountUsersByChurch churchId let! usrs = db.CountUsersByChurch churchId
return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs } return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs }
} }
/// POST /church/[church-id]/delete /// POST /church/[church-id]/delete
let delete churchId : HttpHandler = let delete churchId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.db.TryChurchById churchId with match! ctx.db.TryChurchById churchId with
| Some church -> | Some church ->
let! _, stats = findStats ctx.db churchId let! _, stats = findStats ctx.db churchId
@ -29,70 +26,61 @@ let delete churchId : HttpHandler =
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addInfo ctx addInfo ctx
s.["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)", s["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)",
church.name, stats.smallGroups, stats.prayerRequests, stats.users] church.name, stats.smallGroups, stats.prayerRequests, stats.users]
return! redirectTo false "/web/churches" next ctx return! redirectTo false "/web/churches" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }
/// GET /church/[church-id]/edit /// GET /church/[church-id]/edit
let edit churchId : HttpHandler = let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
match churchId with if churchId = Guid.Empty then
| x when x = Guid.Empty ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.Church.edit EditChurch.empty ctx |> Views.Church.edit EditChurch.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
| _ -> else
match! ctx.db.TryChurchById churchId with match! ctx.db.TryChurchById churchId with
| Some church -> | Some church ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.Church.edit (EditChurch.fromChurch church) ctx |> Views.Church.edit (EditChurch.fromChurch church) ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }
/// GET /churches /// GET /churches
let maintain : HttpHandler = let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let await = Async.AwaitTask >> Async.RunSynchronously let await = Async.AwaitTask >> Async.RunSynchronously
let! churches = ctx.db.AllChurches () let! churches = ctx.db.AllChurches ()
let stats = churches |> List.map (fun c -> await (findStats ctx.db c.churchId)) let stats = churches |> List.map (fun c -> await (findStats ctx.db c.churchId))
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.Church.maintain churches (stats |> Map.ofList) ctx |> Views.Church.maintain churches (stats |> Map.ofList) ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// POST /church/save /// POST /church/save
let save : HttpHandler = let save : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditChurch> () with match! ctx.TryBindFormAsync<EditChurch> () with
| Ok m -> | Ok m ->
let! church = let! church =
match m.isNew () with if m.isNew () then Task.FromResult (Some { Church.empty with churchId = Guid.NewGuid () })
| true -> Task.FromResult<Church option>(Some { Church.empty with churchId = Guid.NewGuid () }) else ctx.db.TryChurchById m.churchId
| false -> ctx.db.TryChurchById m.churchId
match church with match church with
| Some ch -> | Some ch ->
m.populateChurch ch m.populateChurch ch
|> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry) |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let act = s.[match m.isNew () with true -> "Added" | _ -> "Updated"].Value.ToLower () let act = s[if m.isNew () then "Added" else "Updated"].Value.ToLower ()
addInfo ctx s.["Successfully {0} church “{1}”", act, m.name] addInfo ctx s["Successfully {0} church “{1}”", act, m.name]
return! redirectTo false "/web/churches" next ctx return! redirectTo false "/web/churches" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }

307
src/PrayerTracker/CommonFunctions.fs
View File

@ -2,6 +2,10 @@
[<AutoOpen>] [<AutoOpen>]
module PrayerTracker.Handlers.CommonFunctions module PrayerTracker.Handlers.CommonFunctions
open System
open System.Net
open System.Reflection
open System.Threading.Tasks
open Giraffe open Giraffe
open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Antiforgery
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
@ -12,244 +16,235 @@ open Microsoft.Extensions.Localization
open PrayerTracker open PrayerTracker
open PrayerTracker.Cookies open PrayerTracker.Cookies
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open System
open System.Net
open System.Reflection
open System.Threading.Tasks
/// Create a select list from an enumeration /// Create a select list from an enumeration
let toSelectList<'T> valFunc textFunc withDefault emptyText (items : 'T seq) = let toSelectList<'T> valFunc textFunc withDefault emptyText (items : 'T seq) =
match items with null -> nullArg "items" | _ -> () match items with null -> nullArg "items" | _ -> ()
[ match withDefault with [ match withDefault with
| true -> | true ->
let s = PrayerTracker.Views.I18N.localizer.Force () let s = PrayerTracker.Views.I18N.localizer.Force ()
yield SelectListItem ($"""&mdash; %A{s.[emptyText]} &mdash;""", "") yield SelectListItem ($"""&mdash; %A{s[emptyText]} &mdash;""", "")
| _ -> () | _ -> ()
yield! items |> Seq.map (fun x -> SelectListItem (textFunc x, valFunc x)) yield! items |> Seq.map (fun x -> SelectListItem (textFunc x, valFunc x))
] ]
/// Create a select list from an enumeration /// Create a select list from an enumeration
let toSelectListWithEmpty<'T> valFunc textFunc emptyText (items : 'T seq) = let toSelectListWithEmpty<'T> valFunc textFunc emptyText (items : 'T seq) =
toSelectList valFunc textFunc true emptyText items toSelectList valFunc textFunc true emptyText items
/// Create a select list from an enumeration /// Create a select list from an enumeration
let toSelectListWithDefault<'T> valFunc textFunc (items : 'T seq) = let toSelectListWithDefault<'T> valFunc textFunc (items : 'T seq) =
toSelectList valFunc textFunc true "Select" items toSelectList valFunc textFunc true "Select" items
/// The version of PrayerTracker /// The version of PrayerTracker
let appVersion = let appVersion =
let v = Assembly.GetExecutingAssembly().GetName().Version let v = Assembly.GetExecutingAssembly().GetName().Version
#if (DEBUG) #if (DEBUG)
$"v{v}" $"v{v}"
#else #else
seq { seq {
$"v%d{v.Major}" $"v%d{v.Major}"
match v.Minor with match v.Minor with
| 0 -> match v.Build with 0 -> () | _ -> $".0.%d{v.Build}" | 0 -> match v.Build with 0 -> () | _ -> $".0.%d{v.Build}"
| _ -> | _ ->
$".%d{v.Minor}" $".%d{v.Minor}"
match v.Build with 0 -> () | _ -> $".%d{v.Build}" match v.Build with 0 -> () | _ -> $".%d{v.Build}"
} }
|> String.concat "" |> String.concat ""
#endif #endif
/// The currently signed-in user (will raise if none exists) /// The currently signed-in user (will raise if none exists)
let currentUser (ctx : HttpContext) = let currentUser (ctx : HttpContext) =
match ctx.Session.user with Some u -> u | None -> nullArg "User" match ctx.Session.user with Some u -> u | None -> nullArg "User"
/// The currently signed-in small group (will raise if none exists) /// The currently signed-in small group (will raise if none exists)
let currentGroup (ctx : HttpContext) = let currentGroup (ctx : HttpContext) =
match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup" match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup"
/// Create the common view information heading /// Create the common view information heading
let viewInfo (ctx : HttpContext) startTicks = let viewInfo (ctx : HttpContext) startTicks =
let msg = let msg =
match ctx.Session.messages with match ctx.Session.messages with
| [] -> [] | [] -> []
| x -> | x ->
ctx.Session.messages <- [] ctx.Session.messages <- []
x x
match ctx.Session.user with match ctx.Session.user with
| Some u -> | Some u ->
// The idle timeout is 2 hours; if the app pool is recycled or the actual session goes away, we will log the // 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. // user back in transparently using this cookie. Every request resets the timer.
let timeout = let timeout =
{ Id = u.userId { Id = u.userId
GroupId = (currentGroup ctx).smallGroupId GroupId = (currentGroup ctx).smallGroupId
Until = DateTime.UtcNow.AddHours(2.).Ticks Until = DateTime.UtcNow.AddHours(2.).Ticks
Password = "" Password = ""
} }
ctx.Response.Cookies.Append ctx.Response.Cookies.Append
(Key.Cookie.timeout, { timeout with Password = saltedTimeoutHash timeout }.toPayload (), (Key.Cookie.timeout, { timeout with Password = saltedTimeoutHash timeout }.toPayload (),
CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime timeout.Until)), HttpOnly = true)) CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime timeout.Until)),
| None -> () HttpOnly = true))
{ AppViewInfo.fresh with | None -> ()
version = appVersion { AppViewInfo.fresh with
messages = msg version = appVersion
requestStart = startTicks messages = msg
user = ctx.Session.user requestStart = startTicks
group = ctx.Session.smallGroup user = ctx.Session.user
} group = ctx.Session.smallGroup
}
/// The view is the last parameter, so it can be composed /// The view is the last parameter, so it can be composed
let renderHtml next ctx view = let renderHtml next ctx view =
htmlView view next ctx htmlView view next ctx
/// Display an error regarding form submission /// Display an error regarding form submission
let bindError (msg : string) next (ctx : HttpContext) = let bindError (msg : string) next (ctx : HttpContext) =
System.Console.WriteLine msg Console.WriteLine msg
ctx.SetStatusCode 400 ctx.SetStatusCode 400
text msg next ctx text msg next ctx
/// Handler that will return a status code 404 and the text "Not Found" /// Handler that will return a status code 404 and the text "Not Found"
let fourOhFour next (ctx : HttpContext) = let fourOhFour next (ctx : HttpContext) =
ctx.SetStatusCode 404 ctx.SetStatusCode 404
text "Not Found" next ctx text "Not Found" next ctx
/// Handler to validate CSRF prevention token /// Handler to validate CSRF prevention token
let validateCSRF : HttpHandler = let validateCSRF : HttpHandler = fun next ctx -> task {
fun next ctx -> task {
match! (ctx.GetService<IAntiforgery> ()).IsRequestValidAsync ctx with match! (ctx.GetService<IAntiforgery> ()).IsRequestValidAsync ctx with
| true -> return! next ctx | true -> return! next ctx
| false -> | false ->
return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx
} }
/// Add a message to the session /// Add a message to the session
let addUserMessage (ctx : HttpContext) msg = let addUserMessage (ctx : HttpContext) msg =
ctx.Session.messages <- msg :: ctx.Session.messages ctx.Session.messages <- msg :: ctx.Session.messages
/// Convert a localized string to an HTML string /// Convert a localized string to an HTML string
let htmlLocString (x : LocalizedString) = let htmlLocString (x : LocalizedString) =
(WebUtility.HtmlEncode >> HtmlString) x.Value (WebUtility.HtmlEncode >> HtmlString) x.Value
let htmlString (x : LocalizedString) = let htmlString (x : LocalizedString) =
HtmlString x.Value HtmlString x.Value
/// Add an error message to the session /// Add an error message to the session
let addError ctx msg = let addError ctx msg =
addUserMessage ctx { UserMessage.error with text = htmlLocString msg } addUserMessage ctx { UserMessage.error with text = htmlLocString msg }
/// Add an informational message to the session /// Add an informational message to the session
let addInfo ctx msg = let addInfo ctx msg =
addUserMessage ctx { UserMessage.info with text = htmlLocString msg } addUserMessage ctx { UserMessage.info with text = htmlLocString msg }
/// Add an informational HTML message to the session /// Add an informational HTML message to the session
let addHtmlInfo ctx msg = let addHtmlInfo ctx msg =
addUserMessage ctx { UserMessage.info with text = htmlString msg } addUserMessage ctx { UserMessage.info with text = htmlString msg }
/// Add a warning message to the session /// Add a warning message to the session
let addWarning ctx msg = let addWarning ctx msg =
addUserMessage ctx { UserMessage.warning with text = htmlLocString msg } addUserMessage ctx { UserMessage.warning with text = htmlLocString msg }
/// A level of required access /// A level of required access
type AccessLevel = type AccessLevel =
/// Administrative access /// Administrative access
| Admin | Admin
/// Small group administrative access /// Small group administrative access
| User | User
/// Small group member access /// Small group member access
| Group | Group
/// Errbody /// Errbody
| Public | Public
/// Require the given access role (also refreshes "Remember Me" user and group logons) /// Require the given access role (also refreshes "Remember Me" user and group logons)
let requireAccess level : HttpHandler = let requireAccess level : HttpHandler =
/// Is there currently a user logged on? /// Is there currently a user logged on?
let isUserLoggedOn (ctx : HttpContext) = let isUserLoggedOn (ctx : HttpContext) =
ctx.Session.user |> Option.isSome ctx.Session.user |> Option.isSome
/// Log a user on from the timeout cookie /// Log a user on from the timeout cookie
let logOnUserFromTimeoutCookie (ctx : HttpContext) = task { let logOnUserFromTimeoutCookie (ctx : HttpContext) = task {
// Make sure the cookie hasn't been tampered with // Make sure the cookie hasn't been tampered with
try try
match TimeoutCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.timeout] with match TimeoutCookie.fromPayload ctx.Request.Cookies[Key.Cookie.timeout] with
| Some c when c.Password = saltedTimeoutHash c -> | Some c when c.Password = saltedTimeoutHash c ->
let! user = ctx.db.TryUserById c.Id let! user = ctx.db.TryUserById c.Id
match user with match user with
| Some _ -> | Some _ ->
ctx.Session.user <- user ctx.Session.user <- user
let! grp = ctx.db.TryGroupById c.GroupId let! grp = ctx.db.TryGroupById c.GroupId
ctx.Session.smallGroup <- grp ctx.Session.smallGroup <- grp
| _ -> () | _ -> ()
| _ -> () | _ -> ()
// If something above doesn't work, the user doesn't get logged in // If something above doesn't work, the user doesn't get logged in
with _ -> () with _ -> ()
} }
/// Attempt to log the user on from their stored cookie /// Attempt to log the user on from their stored cookie
let logOnUserFromCookie (ctx : HttpContext) = task { let logOnUserFromCookie (ctx : HttpContext) = task {
match UserCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.user] with match UserCookie.fromPayload ctx.Request.Cookies[Key.Cookie.user] with
| Some c -> | Some c ->
let! user = ctx.db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash let! user = ctx.db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash
match user with match user with
| Some _ -> | Some _ ->
ctx.Session.user <- user ctx.Session.user <- user
let! grp = ctx.db.TryGroupById c.GroupId let! grp = ctx.db.TryGroupById c.GroupId
ctx.Session.smallGroup <- grp ctx.Session.smallGroup <- grp
// Rewrite the cookie to extend the expiration // Rewrite the cookie to extend the expiration
ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh) ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh)
| _ -> ()
| _ -> () | _ -> ()
| _ -> ()
} }
/// Is there currently a small group (or member thereof) logged on? /// Is there currently a small group (or member thereof) logged on?
let isGroupLoggedOn (ctx : HttpContext) = let isGroupLoggedOn (ctx : HttpContext) =
ctx.Session.smallGroup |> Option.isSome ctx.Session.smallGroup |> Option.isSome
/// Attempt to log the small group on from their stored cookie /// Attempt to log the small group on from their stored cookie
let logOnGroupFromCookie (ctx : HttpContext) = let logOnGroupFromCookie (ctx : HttpContext) = task {
task { match GroupCookie.fromPayload ctx.Request.Cookies[Key.Cookie.group] with
match GroupCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.group] with | Some c ->
| Some c -> let! grp = ctx.db.TryGroupLogOnByCookie c.GroupId c.PasswordHash sha1Hash
let! grp = ctx.db.TryGroupLogOnByCookie c.GroupId c.PasswordHash sha1Hash match grp with
match grp with | Some _ ->
| Some _ -> ctx.Session.smallGroup <- grp
ctx.Session.smallGroup <- grp // Rewrite the cookie to extend the expiration
// Rewrite the cookie to extend the expiration ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh)
ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh) | None -> ()
| None -> () | None -> ()
| None -> ()
} }
fun next ctx -> FSharp.Control.Tasks.Affine.task { fun next ctx -> task {
// Auto-logon user or class, if required // Auto-logon user or class, if required
match isUserLoggedOn ctx with if not (isUserLoggedOn ctx) then
| true -> () do! logOnUserFromTimeoutCookie ctx
| false -> if not (isUserLoggedOn ctx) then
do! logOnUserFromTimeoutCookie ctx do! logOnUserFromCookie ctx
match isUserLoggedOn ctx with if not (isGroupLoggedOn ctx) then do! logOnGroupFromCookie ctx
| true -> ()
| false ->
do! logOnUserFromCookie ctx
match isGroupLoggedOn ctx with true -> () | false -> do! logOnGroupFromCookie ctx
match true with match true with
| _ when level |> List.contains Public -> return! next ctx | _ when level |> List.contains Public -> return! next ctx
| _ when level |> List.contains User && isUserLoggedOn ctx -> 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 Group && isGroupLoggedOn ctx -> return! next ctx
| _ when level |> List.contains Admin && isUserLoggedOn ctx -> | _ when level |> List.contains Admin && isUserLoggedOn ctx ->
match (currentUser ctx).isAdmin with match (currentUser ctx).isAdmin with
| true -> return! next ctx | true -> return! next ctx
| false -> | false ->
let s = Views.I18N.localizer.Force ()
addError ctx s["You are not authorized to view the requested page."]
return! redirectTo false "/web/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 "/web/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 "/web/small-group/log-on" next ctx
| _ ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s.["You are not authorized to view the requested page."] addError ctx s["You are not authorized to view the requested page."]
return! redirectTo false "/web/unauthorized" next ctx return! redirectTo false "/web/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 "/web/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 "/web/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 "/web/unauthorized" next ctx
} }

154
src/PrayerTracker/Cookies.fs
View File

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

99
src/PrayerTracker/Email.fs
View File

@ -14,64 +14,67 @@ let private fromAddress = "prayer@bitbadger.solutions"
/// Get an SMTP client connection /// Get an SMTP client connection
// FIXME: make host configurable // FIXME: make host configurable
let getConnection () = task { let getConnection () = task {
let client = new SmtpClient () let client = new SmtpClient ()
do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None) do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None)
return client return client
} }
/// Create a mail message object, filled with everything but the body content /// Create a mail message object, filled with everything but the body content
let createMessage (grp : SmallGroup) subj = let createMessage (grp : SmallGroup) subj =
let msg = MimeMessage () let msg = MimeMessage ()
msg.From.Add (MailboxAddress (grp.preferences.emailFromName, fromAddress)) msg.From.Add (MailboxAddress (grp.preferences.emailFromName, fromAddress))
msg.Subject <- subj msg.Subject <- subj
msg.ReplyTo.Add (MailboxAddress (grp.preferences.emailFromName, grp.preferences.emailFromAddress)) msg.ReplyTo.Add (MailboxAddress (grp.preferences.emailFromName, grp.preferences.emailFromAddress))
msg msg
/// Create an HTML-format e-mail message /// Create an HTML-format e-mail message
let createHtmlMessage grp subj body (s : IStringLocalizer) = let createHtmlMessage grp subj body (s : IStringLocalizer) =
let bodyText = let bodyText =
[ """<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml"><head><title></title></head><body>""" [ """<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml"><head><title></title></head><body>"""
body body
"""<hr><div style="text-align:right;font-family:Arial,Helvetica,sans-serif;font-size:8pt;padding-right:10px;">""" """<hr><div style="text-align:right;font-family:Arial,Helvetica,sans-serif;font-size:8pt;padding-right:10px;">"""
s.["Generated by P R A Y E R T R A C K E R"].Value s["Generated by P R A Y E R T R A C K E R"].Value
"<br><small>" "<br><small>"
s.["from Bit Badger Solutions"].Value s["from Bit Badger Solutions"].Value
"</small></div></body></html>" "</small></div></body></html>"
] ]
|> String.concat "" |> String.concat ""
let msg = createMessage grp subj let msg = createMessage grp subj
msg.Body <- TextPart (TextFormat.Html, Text = bodyText) msg.Body <- TextPart (TextFormat.Html, Text = bodyText)
msg msg
/// Create a plain-text-format e-mail message /// Create a plain-text-format e-mail message
let createTextMessage grp subj body (s : IStringLocalizer) = let createTextMessage grp subj body (s : IStringLocalizer) =
let bodyText = let bodyText =
[ body [ body
"\n\n--\n" "\n\n--\n"
s.["Generated by P R A Y E R T R A C K E R"].Value s["Generated by P R A Y E R T R A C K E R"].Value
"\n" "\n"
s.["from Bit Badger Solutions"].Value s["from Bit Badger Solutions"].Value
] ]
|> String.concat "" |> String.concat ""
let msg = createMessage grp subj let msg = createMessage grp subj
msg.Body <- TextPart (TextFormat.Plain, Text = bodyText) msg.Body <- TextPart (TextFormat.Plain, Text = bodyText)
msg msg
/// Send e-mails to a class /// Send e-mails to a class
let sendEmails (client : SmtpClient) (recipients : Member list) grp subj html text s = task { let sendEmails (client : SmtpClient) (recipients : Member list) grp subj html text s = task {
let htmlMsg = createHtmlMessage grp subj html s let htmlMsg = createHtmlMessage grp subj html s
let plainTextMsg = createTextMessage grp subj text s let plainTextMsg = createTextMessage grp subj text s
for mbr in recipients do for mbr in recipients do
let emailType = match mbr.format with Some f -> EmailFormat.fromCode f | None -> grp.preferences.defaultEmailType let emailType =
let emailTo = MailboxAddress (mbr.memberName, mbr.email) match mbr.format with
match emailType with | Some f -> EmailFormat.fromCode f
| HtmlFormat -> | None -> grp.preferences.defaultEmailType
htmlMsg.To.Add emailTo let emailTo = MailboxAddress (mbr.memberName, mbr.email)
do! client.SendAsync htmlMsg match emailType with
htmlMsg.To.Clear () | HtmlFormat ->
| PlainTextFormat -> htmlMsg.To.Add emailTo
plainTextMsg.To.Add emailTo do! client.SendAsync htmlMsg
do! client.SendAsync plainTextMsg htmlMsg.To.Clear ()
plainTextMsg.To.Clear () | PlainTextFormat ->
} plainTextMsg.To.Add emailTo
do! client.SendAsync plainTextMsg
plainTextMsg.To.Clear ()
}

64
src/PrayerTracker/Extensions.fs
View File

@ -11,42 +11,42 @@ open PrayerTracker.ViewModels
// fsharplint:disable MemberNames // fsharplint:disable MemberNames
type ISession with type ISession with
/// Set an object in the session /// Set an object in the session
member this.SetObject key value = member this.SetObject key value =
this.SetString (key, JsonConvert.SerializeObject value) this.SetString (key, JsonConvert.SerializeObject value)
/// Get an object from the session /// Get an object from the session
member this.GetObject<'T> key = member this.GetObject<'T> key =
match this.GetString key with match this.GetString key with
| null -> Unchecked.defaultof<'T> | null -> Unchecked.defaultof<'T>
| v -> JsonConvert.DeserializeObject<'T> v | v -> JsonConvert.DeserializeObject<'T> v
/// The current small group for the session /// The current small group for the session
member this.smallGroup member this.smallGroup
with get () = this.GetObject<SmallGroup> Key.Session.currentGroup |> Option.fromObject with get () = this.GetObject<SmallGroup> Key.Session.currentGroup |> Option.fromObject
and set (v : SmallGroup option) = and set (v : SmallGroup option) =
match v with match v with
| Some group -> this.SetObject Key.Session.currentGroup group | Some group -> this.SetObject Key.Session.currentGroup group
| None -> this.Remove Key.Session.currentGroup | None -> this.Remove Key.Session.currentGroup
/// The current user for the session /// The current user for the session
member this.user member this.user
with get () = this.GetObject<User> Key.Session.currentUser |> Option.fromObject with get () = this.GetObject<User> Key.Session.currentUser |> Option.fromObject
and set (v : User option) = and set (v : User option) =
match v with match v with
| Some user -> this.SetObject Key.Session.currentUser user | Some user -> this.SetObject Key.Session.currentUser user
| None -> this.Remove Key.Session.currentUser | None -> this.Remove Key.Session.currentUser
/// Current messages for the session /// Current messages for the session
member this.messages member this.messages
with get () = with get () =
match box (this.GetObject<UserMessage list> Key.Session.userMessages) with match box (this.GetObject<UserMessage list> Key.Session.userMessages) with
| null -> List.empty<UserMessage> | null -> List.empty<UserMessage>
| msgs -> unbox msgs | msgs -> unbox msgs
and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v
type HttpContext with type HttpContext with
/// The EF Core database context (via DI) /// The EF Core database context (via DI)
member this.db member this.db
with get () = this.RequestServices.GetRequiredService<AppDbContext> () with get () = this.RequestServices.GetRequiredService<AppDbContext> ()

56
src/PrayerTracker/Home.fs
View File

@ -1,90 +1,76 @@
module PrayerTracker.Handlers.Home module PrayerTracker.Handlers.Home
open System
open System.Globalization
open Giraffe open Giraffe
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Localization open Microsoft.AspNetCore.Localization
open PrayerTracker open PrayerTracker
open System
open System.Globalization
/// GET /error/[error-code] /// GET /error/[error-code]
let error code : HttpHandler = let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.error code |> Views.Home.error code
|> renderHtml next ctx |> renderHtml next ctx
/// GET / /// GET /
let homePage : HttpHandler = let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.index |> Views.Home.index
|> renderHtml next ctx |> renderHtml next ctx
/// GET /language/[culture] /// GET /language/[culture]
let language culture : HttpHandler = let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
try try
match culture with match culture with
| null | null
| "" | ""
| "en" -> "en-US" | "en" -> "en-US"
| "es" -> "es-MX" | "es" -> "es-MX"
| _ -> $"{culture}-{culture.ToUpper ()}" | _ -> $"{culture}-{culture.ToUpper ()}"
|> (CultureInfo >> Option.ofObj) |> (CultureInfo >> Option.ofObj)
with with
| :? CultureNotFoundException | :? CultureNotFoundException
| :? ArgumentException -> None | :? ArgumentException -> None
|> function |> function
| Some c -> | Some c ->
ctx.Response.Cookies.Append ( ctx.Response.Cookies.Append (
CookieRequestCultureProvider.DefaultCookieName, CookieRequestCultureProvider.DefaultCookieName,
CookieRequestCultureProvider.MakeCookieValue (RequestCulture c), CookieRequestCultureProvider.MakeCookieValue (RequestCulture c),
CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime.Now.AddYears 1)))) CookieOptions (Expires = Nullable<DateTimeOffset> (DateTimeOffset (DateTime.Now.AddYears 1))))
| _ -> () | _ -> ()
let url = match string ctx.Request.Headers.["Referer"] with null | "" -> "/web/" | r -> r let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/web/" | r -> r
redirectTo false url next ctx redirectTo false url next ctx
/// GET /legal/privacy-policy /// GET /legal/privacy-policy
let privacyPolicy : HttpHandler = let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.privacyPolicy |> Views.Home.privacyPolicy
|> renderHtml next ctx |> renderHtml next ctx
/// GET /legal/terms-of-service /// GET /legal/terms-of-service
let tos : HttpHandler = let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.termsOfService |> Views.Home.termsOfService
|> renderHtml next ctx |> renderHtml next ctx
/// GET /log-off /// GET /log-off
let logOff : HttpHandler = let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
ctx.Session.Clear () ctx.Session.Clear ()
// Remove cookies if they exist // Remove cookies if they exist
Key.Cookie.logOffCookies |> List.iter ctx.Response.Cookies.Delete Key.Cookie.logOffCookies |> List.iter ctx.Response.Cookies.Delete
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addHtmlInfo ctx s.["Log Off Successful • Have a nice day!"] addHtmlInfo ctx s["Log Off Successful • Have a nice day!"]
redirectTo false "/web/" next ctx redirectTo false "/web/" next ctx
/// GET /unauthorized /// GET /unauthorized
let unauthorized : HttpHandler = let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks viewInfo ctx DateTime.Now.Ticks
|> Views.Home.unauthorized |> Views.Home.unauthorized
|> renderHtml next ctx |> renderHtml next ctx

281
src/PrayerTracker/PrayerRequest.fs
View File

@ -1,253 +1,234 @@
module PrayerTracker.Handlers.PrayerRequest module PrayerTracker.Handlers.PrayerRequest
open System
open System.Threading.Tasks
open Giraffe open Giraffe
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open NodaTime open NodaTime
open PrayerTracker open PrayerTracker
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open System
open System.Threading.Tasks
/// Retrieve a prayer request, and ensure that it belongs to the current class /// Retrieve a prayer request, and ensure that it belongs to the current class
let private findRequest (ctx : HttpContext) reqId = task { let private findRequest (ctx : HttpContext) reqId = task {
match! ctx.db.TryRequestById reqId with match! ctx.db.TryRequestById reqId with
| Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> return Ok req | Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> return Ok req
| Some _ -> | Some _ ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s.["The prayer request you tried to access is not assigned to your group"] addError ctx s["The prayer request you tried to access is not assigned to your group"]
return Error (redirectTo false "/web/unauthorized") return Error (redirectTo false "/web/unauthorized")
| None -> return Error fourOhFour | None -> return Error fourOhFour
} }
/// Generate a list of requests for the given date /// Generate a list of requests for the given date
let private generateRequestList ctx date = let private generateRequestList ctx date = task {
let grp = currentGroup ctx let grp = currentGroup ctx
let clock = ctx.GetService<IClock> () let clock = ctx.GetService<IClock> ()
let listDate = let listDate = match date with Some d -> d | None -> grp.localDateNow clock
match date with let! reqs = ctx.db.AllRequestsForSmallGroup grp clock (Some listDate) true 0
| Some d -> d return
| None -> grp.localDateNow clock { requests = reqs |> List.ofSeq
let reqs = ctx.db.AllRequestsForSmallGroup grp clock (Some listDate) true 0 date = listDate
{ requests = reqs |> List.ofSeq listGroup = grp
date = listDate showHeader = true
listGroup = grp canEmail = ctx.Session.user |> Option.isSome
showHeader = true recipients = []
canEmail = ctx.Session.user |> Option.isSome }
recipients = [] }
}
/// Parse a string into a date (optionally, of course) /// Parse a string into a date (optionally, of course)
let private parseListDate (date : string option) = let private parseListDate (date : string option) =
match date with match date with
| Some dt -> match DateTime.TryParse dt with true, d -> Some d | false, _ -> None | Some dt -> match DateTime.TryParse dt with true, d -> Some d | false, _ -> None
| None -> None | None -> None
/// GET /prayer-request/[request-id]/edit /// GET /prayer-request/[request-id]/edit
let edit (reqId : PrayerRequestId) : HttpHandler = let edit (reqId : PrayerRequestId) : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx let grp = currentGroup ctx
let now = grp.localDateNow (ctx.GetService<IClock> ()) let now = grp.localDateNow (ctx.GetService<IClock> ())
match reqId = Guid.Empty with if reqId = Guid.Empty then
| true ->
return! return!
{ viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
|> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx
|> renderHtml next ctx |> renderHtml next ctx
| false -> else
match! findRequest ctx reqId with match! findRequest ctx reqId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match req.isExpired now grp.preferences.daysToExpire with if req.isExpired now grp.preferences.daysToExpire then
| true ->
{ UserMessage.warning with { UserMessage.warning with
text = htmlLocString s.["This request is expired."] text = htmlLocString s["This request is expired."]
description = description =
s.["To make it active again, update it as necessary, leave “{0}” and “{1}” unchecked, and it will return as an active request.", s["To make it active again, update it as necessary, leave “{0}” and “{1}” unchecked, and it will return as an active request.",
s.["Expire Immediately"], s.["Check to not update the date"]] s["Expire Immediately"], s["Check to not update the date"]]
|> (htmlLocString >> Some) |> (htmlLocString >> Some)
} }
|> addUserMessage ctx |> addUserMessage ctx
| false -> ()
return! return!
{ viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest } { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
|> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx
|> renderHtml next ctx |> renderHtml next ctx
| Error e -> return! e next ctx | Error e -> return! e next ctx
} }
/// GET /prayer-requests/email/[date] /// GET /prayer-requests/email/[date]
let email date : HttpHandler = let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let listDate = parseListDate (Some date) let listDate = parseListDate (Some date)
let grp = currentGroup ctx let grp = currentGroup ctx
let list = generateRequestList ctx listDate let! list = generateRequestList ctx listDate
let! recipients = ctx.db.AllMembersForSmallGroup grp.smallGroupId let! recipients = ctx.db.AllMembersForSmallGroup grp.smallGroupId
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails client recipients do! Email.sendEmails client recipients
grp s.["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value grp s["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value
(list.asHtml s) (list.asText s) s (list.asHtml s) (list.asText s) s
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.PrayerRequest.email { list with recipients = recipients } |> Views.PrayerRequest.email { list with recipients = recipients }
|> renderHtml next ctx |> renderHtml next ctx
} }
/// POST /prayer-request/[request-id]/delete /// POST /prayer-request/[request-id]/delete
let delete reqId : HttpHandler = let delete reqId : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx -> task {
match! findRequest ctx reqId with match! findRequest ctx reqId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
ctx.db.PrayerRequests.Remove req |> ignore ctx.db.PrayerRequests.Remove req |> ignore
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
addInfo ctx s.["The prayer request was deleted successfully"] addInfo ctx s["The prayer request was deleted successfully"]
return! redirectTo false "/web/prayer-requests" next ctx return! redirectTo false "/web/prayer-requests" next ctx
| Error e -> return! e next ctx | Error e -> return! e next ctx
} }
/// GET /prayer-request/[request-id]/expire /// GET /prayer-request/[request-id]/expire
let expire reqId : HttpHandler = let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ]
>=> fun next ctx -> task {
match! findRequest ctx reqId with match! findRequest ctx reqId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with expiration = Forced } ctx.db.UpdateEntry { req with expiration = Forced }
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
addInfo ctx s.["Successfully {0} prayer request", s.["Expired"].Value.ToLower ()] addInfo ctx s["Successfully {0} prayer request", s["Expired"].Value.ToLower ()]
return! redirectTo false "/web/prayer-requests" next ctx return! redirectTo false "/web/prayer-requests" next ctx
| Error e -> return! e next ctx | Error e -> return! e next ctx
} }
/// GET /prayer-requests/[group-id]/list /// GET /prayer-requests/[group-id]/list
let list groupId : HttpHandler = let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
requireAccess [ AccessLevel.Public ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
match! ctx.db.TryGroupById groupId with match! ctx.db.TryGroupById groupId with
| Some grp when grp.preferences.isPublic -> | Some grp when grp.preferences.isPublic ->
let clock = ctx.GetService<IClock> () let clock = ctx.GetService<IClock> ()
let reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0 let! reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.PrayerRequest.list |> Views.PrayerRequest.list
{ requests = List.ofSeq reqs { requests = reqs
date = grp.localDateNow clock date = grp.localDateNow clock
listGroup = grp listGroup = grp
showHeader = true showHeader = true
canEmail = ctx.Session.user |> Option.isSome canEmail = ctx.Session.user |> Option.isSome
recipients = [] recipients = []
} }
|> renderHtml next ctx |> renderHtml next ctx
| Some _ -> | Some _ ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addError ctx s.["The request list for the group you tried to view is not public."] addError ctx s["The request list for the group you tried to view is not public."]
return! redirectTo false "/web/unauthorized" next ctx return! redirectTo false "/web/unauthorized" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }
/// GET /prayer-requests/lists /// GET /prayer-requests/lists
let lists : HttpHandler = let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
requireAccess [ AccessLevel.Public ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! grps = ctx.db.PublicAndProtectedGroups () let! groups = ctx.db.PublicAndProtectedGroups ()
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.PrayerRequest.lists grps |> Views.PrayerRequest.lists groups
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /prayer-requests[/inactive?] /// GET /prayer-requests[/inactive?]
/// - OR - /// - OR -
/// GET /prayer-requests?search=[search-query] /// GET /prayer-requests?search=[search-query]
let maintain onlyActive : HttpHandler = let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ]
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx let grp = currentGroup ctx
let pageNbr = let pageNbr =
match ctx.GetQueryStringValue "page" with match ctx.GetQueryStringValue "page" with
| Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1 | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1
| Error _ -> 1 | Error _ -> 1
let m = let! m = backgroundTask {
match ctx.GetQueryStringValue "search" with match ctx.GetQueryStringValue "search" with
| Ok srch -> | Ok search ->
{ MaintainRequests.empty with let! reqs = ctx.db.SearchRequestsForSmallGroup grp search pageNbr
requests = ctx.db.SearchRequestsForSmallGroup grp srch pageNbr return
searchTerm = Some srch { MaintainRequests.empty with
pageNbr = Some pageNbr requests = reqs
} searchTerm = Some search
| Error _ -> pageNbr = Some pageNbr
{ MaintainRequests.empty with }
requests = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr | Error _ ->
onlyActive = Some onlyActive let! reqs = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService<IClock> ()) None onlyActive pageNbr
pageNbr = match onlyActive with true -> None | false -> Some pageNbr return
} { MaintainRequests.empty with
{ viewInfo ctx startTicks with helpLink = Some Help.maintainRequests } requests = reqs
|> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx onlyActive = Some onlyActive
|> renderHtml next ctx pageNbr = match onlyActive with true -> None | false -> Some pageNbr
}
}
return!
{ viewInfo ctx startTicks with helpLink = Some Help.maintainRequests }
|> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx
|> renderHtml next ctx
}
/// GET /prayer-request/print/[date] /// GET /prayer-request/print/[date]
let print date : HttpHandler = let print date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task {
requireAccess [ User; Group ] let! list = generateRequestList ctx (parseListDate (Some date))
>=> fun next ctx -> return!
let list = parseListDate (Some date) |> generateRequestList ctx Views.PrayerRequest.print list appVersion
Views.PrayerRequest.print list appVersion |> renderHtml next ctx
|> renderHtml next ctx }
/// GET /prayer-request/[request-id]/restore /// GET /prayer-request/[request-id]/restore
let restore reqId : HttpHandler = let restore reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ]
>=> fun next ctx -> task {
match! findRequest ctx reqId with match! findRequest ctx reqId with
| Ok req -> | Ok req ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with expiration = Automatic; updatedDate = DateTime.Now } ctx.db.UpdateEntry { req with expiration = Automatic; updatedDate = DateTime.Now }
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
addInfo ctx s.["Successfully {0} prayer request", s.["Restored"].Value.ToLower ()] addInfo ctx s["Successfully {0} prayer request", s["Restored"].Value.ToLower ()]
return! redirectTo false "/web/prayer-requests" next ctx return! redirectTo false "/web/prayer-requests" next ctx
| Error e -> return! e next ctx | Error e -> return! e next ctx
} }
/// POST /prayer-request/save /// POST /prayer-request/save
let save : HttpHandler = let save : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditRequest> () with match! ctx.TryBindFormAsync<EditRequest> () with
| Ok m -> | Ok m ->
let! req = let! req =
match m.isNew () with if m.isNew () then Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () })
| true -> Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () }) else ctx.db.TryRequestById m.requestId
| false -> ctx.db.TryRequestById m.requestId
match req with match req with
| Some pr -> | Some pr ->
let upd8 = let upd8 =
{ pr with { pr with
requestType = PrayerRequestType.fromCode m.requestType requestType = PrayerRequestType.fromCode m.requestType
requestor = match m.requestor with Some x when x.Trim () = "" -> None | x -> x requestor = match m.requestor with Some x when x.Trim () = "" -> None | x -> x
text = ckEditorToText m.text text = ckEditorToText m.text
expiration = Expiration.fromCode m.expiration expiration = Expiration.fromCode m.expiration
} }
let grp = currentGroup ctx let grp = currentGroup ctx
let now = grp.localDateNow (ctx.GetService<IClock> ()) let now = grp.localDateNow (ctx.GetService<IClock> ())
@ -262,23 +243,23 @@ let save : HttpHandler =
} }
| false when Option.isSome m.skipDateUpdate && Option.get m.skipDateUpdate -> upd8 | false when Option.isSome m.skipDateUpdate && Option.get m.skipDateUpdate -> upd8
| false -> { upd8 with updatedDate = now } | false -> { upd8 with updatedDate = now }
|> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry) |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let act = match m.isNew () with true -> "Added" | false -> "Updated" let act = if m.isNew () then "Added" else "Updated"
addInfo ctx s.["Successfully {0} prayer request", s.[act].Value.ToLower ()] addInfo ctx s["Successfully {0} prayer request", s.[act].Value.ToLower ()]
return! redirectTo false "/web/prayer-requests" next ctx return! redirectTo false "/web/prayer-requests" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }
/// GET /prayer-request/view/[date?] /// GET /prayer-request/view/[date?]
let view date : HttpHandler = let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task {
requireAccess [ User; Group ] let startTicks = DateTime.Now.Ticks
>=> fun next ctx -> let! list = generateRequestList ctx (parseListDate date)
let startTicks = DateTime.Now.Ticks return!
let list = parseListDate date |> generateRequestList ctx viewInfo ctx startTicks
viewInfo ctx startTicks |> Views.PrayerRequest.view { list with showHeader = false }
|> Views.PrayerRequest.view { list with showHeader = false } |> renderHtml next ctx
|> renderHtml next ctx }

423
src/PrayerTracker/SmallGroup.fs
View File

@ -14,25 +14,20 @@ open System.Threading.Tasks
/// Set a small group "Remember Me" cookie /// Set a small group "Remember Me" cookie
let private setGroupCookie (ctx : HttpContext) pwHash = let private setGroupCookie (ctx : HttpContext) pwHash =
ctx.Response.Cookies.Append ctx.Response.Cookies.Append
(Key.Cookie.group, { GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (), autoRefresh) (Key.Cookie.group, { GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (),
autoRefresh)
/// GET /small-group/announcement /// GET /small-group/announcement
let announcement : HttpHandler = let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
requireAccess [ User ] { viewInfo ctx DateTime.Now.Ticks with helpLink = Some Help.sendAnnouncement; script = [ "ckeditor/ckeditor" ] }
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks
{ viewInfo ctx startTicks with helpLink = Some Help.sendAnnouncement; script = [ "ckeditor/ckeditor" ] }
|> Views.SmallGroup.announcement (currentUser ctx).isAdmin ctx |> Views.SmallGroup.announcement (currentUser ctx).isAdmin ctx
|> renderHtml next ctx |> renderHtml next ctx
/// POST /small-group/[group-id]/delete /// POST /small-group/[group-id]/delete
let delete groupId : HttpHandler = let delete groupId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx -> task {
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match! ctx.db.TryGroupById groupId with match! ctx.db.TryGroupById groupId with
| Some grp -> | Some grp ->
@ -41,103 +36,86 @@ let delete groupId : HttpHandler =
ctx.db.RemoveEntry grp ctx.db.RemoveEntry grp
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
addInfo ctx addInfo ctx
s.["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)", s["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)",
grp.name, reqs, usrs] grp.name, reqs, usrs]
return! redirectTo false "/web/small-groups" next ctx return! redirectTo false "/web/small-groups" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }
/// POST /small-group/member/[member-id]/delete /// POST /small-group/member/[member-id]/delete
let deleteMember memberId : HttpHandler = let deleteMember memberId : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx -> task {
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match! ctx.db.TryMemberById memberId with match! ctx.db.TryMemberById memberId with
| Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId -> | Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId ->
ctx.db.RemoveEntry mbr ctx.db.RemoveEntry mbr
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
addHtmlInfo ctx s.["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.memberName] addHtmlInfo ctx s["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.memberName]
return! redirectTo false "/web/small-group/members" next ctx return! redirectTo false "/web/small-group/members" next ctx
| Some _ | Some _
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }
/// GET /small-group/[group-id]/edit /// GET /small-group/[group-id]/edit
let edit (groupId : SmallGroupId) : HttpHandler = let edit (groupId : SmallGroupId) : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! churches = ctx.db.AllChurches () let! churches = ctx.db.AllChurches ()
match groupId = Guid.Empty with if groupId = Guid.Empty then
| true ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.edit EditSmallGroup.empty churches ctx |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
|> renderHtml next ctx |> renderHtml next ctx
| false -> else
match! ctx.db.TryGroupById groupId with match! ctx.db.TryGroupById groupId with
| Some grp -> | Some grp ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }
/// GET /small-group/member/[member-id]/edit /// GET /small-group/member/[member-id]/edit
let editMember (memberId : MemberId) : HttpHandler = let editMember (memberId : MemberId) : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ]
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let grp = currentGroup ctx let grp = currentGroup ctx
let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s
task { if memberId = Guid.Empty then
match memberId = Guid.Empty with return!
| true ->
return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.editMember EditMember.empty typs ctx |> Views.SmallGroup.editMember EditMember.empty typs ctx
|> renderHtml next ctx |> renderHtml next ctx
| false -> else
match! ctx.db.TryMemberById memberId with match! ctx.db.TryMemberById memberId with
| Some mbr when mbr.smallGroupId = grp.smallGroupId -> | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.editMember (EditMember.fromMember mbr) typs ctx |> Views.SmallGroup.editMember (EditMember.fromMember mbr) typs ctx
|> renderHtml next ctx |> renderHtml next ctx
| Some _ | Some _
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }
/// GET /small-group/log-on/[group-id?] /// GET /small-group/log-on/[group-id?]
let logOn (groupId : SmallGroupId option) : HttpHandler = let logOn (groupId : SmallGroupId option) : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
requireAccess [ AccessLevel.Public ]
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { let! grps = ctx.db.ProtectedGroups ()
let! grps = ctx.db.ProtectedGroups () let grpId = match groupId with Some gid -> flatGuid gid | None -> ""
let grpId = match groupId with Some gid -> flatGuid gid | None -> "" return!
return!
{ viewInfo ctx startTicks with helpLink = Some Help.logOn } { viewInfo ctx startTicks with helpLink = Some Help.logOn }
|> Views.SmallGroup.logOn grps grpId ctx |> Views.SmallGroup.logOn grps grpId ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// POST /small-group/log-on/submit /// POST /small-group/log-on/submit
let logOnSubmit : HttpHandler = let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ AccessLevel.Public ] match! ctx.TryBindFormAsync<GroupLogOn> () with
>=> validateCSRF | Ok m ->
>=> fun next ctx ->
task {
match! ctx.TryBindFormAsync<GroupLogOn> () with
| Ok m ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match! ctx.db.TryGroupLogOnByPassword m.smallGroupId m.password with match! ctx.db.TryGroupLogOnByPassword m.smallGroupId m.password with
| Some grp -> | Some grp ->
@ -145,241 +123,206 @@ let logOnSubmit : HttpHandler =
match m.rememberMe with match m.rememberMe with
| Some x when x -> (setGroupCookie ctx << sha1Hash) m.password | Some x when x -> (setGroupCookie ctx << sha1Hash) m.password
| _ -> () | _ -> ()
addInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]] addInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
return! redirectTo false "/web/prayer-requests/view" next ctx return! redirectTo false "/web/prayer-requests/view" next ctx
| None -> | None ->
addError ctx s.["Password incorrect - login unsuccessful"] addError ctx s["Password incorrect - login unsuccessful"]
return! redirectTo false $"/web/small-group/log-on/{flatGuid m.smallGroupId}" next ctx return! redirectTo false $"/web/small-group/log-on/{flatGuid m.smallGroupId}" next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }
/// GET /small-groups /// GET /small-groups
let maintain : HttpHandler = let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { let! grps = ctx.db.AllGroups ()
let! grps = ctx.db.AllGroups () return!
return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.maintain grps ctx |> Views.SmallGroup.maintain grps ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group/members /// GET /small-group/members
let members : HttpHandler = let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ]
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx let grp = currentGroup ctx
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
task { let! mbrs = ctx.db.AllMembersForSmallGroup grp.smallGroupId
let! mbrs = ctx.db.AllMembersForSmallGroup grp.smallGroupId let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s |> Map.ofSeq
let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s |> Map.ofSeq return!
return!
{ viewInfo ctx startTicks with helpLink = Some Help.maintainGroupMembers } { viewInfo ctx startTicks with helpLink = Some Help.maintainGroupMembers }
|> Views.SmallGroup.members mbrs typs ctx |> Views.SmallGroup.members mbrs typs ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group /// GET /small-group
let overview : HttpHandler = let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ] let startTicks = DateTime.Now.Ticks
>=> fun next ctx -> let clock = ctx.GetService<IClock> ()
let startTicks = DateTime.Now.Ticks let! reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0
let clock = ctx.GetService<IClock> () let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId
task { let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId
let reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 |> List.ofSeq let m =
let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId
let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId
let m =
{ totalActiveReqs = List.length reqs { totalActiveReqs = List.length reqs
allReqs = reqCount allReqs = reqCount
totalMbrs = mbrCount totalMbrs = mbrCount
activeReqsByCat = activeReqsByCat =
(reqs (reqs
|> Seq.ofList |> Seq.ofList
|> Seq.map (fun req -> req.requestType) |> Seq.map (fun req -> req.requestType)
|> Seq.distinct |> Seq.distinct
|> Seq.map (fun reqType -> reqType, reqs |> List.filter (fun r -> r.requestType = reqType) |> List.length) |> Seq.map (fun reqType -> reqType, reqs |> List.filter (fun r -> r.requestType = reqType) |> List.length)
|> Map.ofSeq) |> Map.ofSeq)
} }
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.overview m |> Views.SmallGroup.overview m
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group/preferences /// GET /small-group/preferences
let preferences : HttpHandler = let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
requireAccess [ User ] let startTicks = DateTime.Now.Ticks
>=> fun next ctx -> let! tzs = ctx.db.AllTimeZones ()
let startTicks = DateTime.Now.Ticks return!
task {
let! tzs = ctx.db.AllTimeZones ()
return!
{ viewInfo ctx startTicks with helpLink = Some Help.groupPreferences } { viewInfo ctx startTicks with helpLink = Some Help.groupPreferences }
|> Views.SmallGroup.preferences (EditPreferences.fromPreferences (currentGroup ctx).preferences) tzs ctx |> Views.SmallGroup.preferences (EditPreferences.fromPreferences (currentGroup ctx).preferences) tzs ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// POST /small-group/save /// POST /small-group/save
let save : HttpHandler = let save : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ Admin ] match! ctx.TryBindFormAsync<EditSmallGroup> () with
>=> validateCSRF | Ok m ->
>=> fun next ctx -> let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () let! group =
task { if m.isNew () then Task.FromResult (Some { SmallGroup.empty with smallGroupId = Guid.NewGuid () })
match! ctx.TryBindFormAsync<EditSmallGroup> () with else ctx.db.TryGroupById m.smallGroupId
| Ok m -> match group with
let! group = | Some grp ->
match m.isNew () with m.populateGroup grp
| true -> Task.FromResult<SmallGroup option>(Some { SmallGroup.empty with smallGroupId = Guid.NewGuid () }) |> function
| false -> ctx.db.TryGroupById m.smallGroupId | grp when m.isNew () ->
match group with ctx.db.AddEntry grp
| Some grp -> ctx.db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId }
m.populateGroup grp | grp -> ctx.db.UpdateEntry grp
|> function let! _ = ctx.db.SaveChangesAsync ()
| grp when m.isNew () -> let act = s[if m.isNew () then "Added" else "Updated"].Value.ToLower ()
ctx.db.AddEntry grp addHtmlInfo ctx s["Successfully {0} group “{1}”", act, m.name]
ctx.db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId } return! redirectTo false "/web/small-groups" next ctx
| grp -> ctx.db.UpdateEntry grp | None -> return! fourOhFour next ctx
let! _ = ctx.db.SaveChangesAsync () | Error e -> return! bindError e next ctx
let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower () }
addHtmlInfo ctx s.["Successfully {0} group “{1}”", act, m.name]
return! redirectTo false "/web/small-groups" next ctx
| None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx
}
/// POST /small-group/member/save /// POST /small-group/member/save
let saveMember : HttpHandler = let saveMember : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ User ] match! ctx.TryBindFormAsync<EditMember> () with
>=> validateCSRF | Ok m ->
>=> fun next ctx -> let grp = currentGroup ctx
task { let! mMbr =
match! ctx.TryBindFormAsync<EditMember> () with if m.isNew () then
| Ok m -> Task.FromResult (Some { Member.empty with memberId = Guid.NewGuid (); smallGroupId = grp.smallGroupId })
let grp = currentGroup ctx else ctx.db.TryMemberById m.memberId
let! mMbr = match mMbr with
match m.isNew () with | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
| true -> { mbr with
Task.FromResult<Member option> memberName = m.memberName
(Some email = m.emailAddress
{ Member.empty with format = match m.emailType with "" | null -> None | _ -> Some m.emailType
memberId = Guid.NewGuid () }
smallGroupId = grp.smallGroupId |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
}) let! _ = ctx.db.SaveChangesAsync ()
| false -> ctx.db.TryMemberById m.memberId let s = Views.I18N.localizer.Force ()
match mMbr with let act = s[if m.isNew () then "Added" else "Updated"].Value.ToLower ()
| Some mbr when mbr.smallGroupId = grp.smallGroupId -> addInfo ctx s["Successfully {0} group member", act]
{ mbr with return! redirectTo false "/web/small-group/members" next ctx
memberName = m.memberName | Some _
email = m.emailAddress | None -> return! fourOhFour next ctx
format = match m.emailType with "" | null -> None | _ -> Some m.emailType | Error e -> return! bindError e next ctx
} }
|> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower ()
addInfo ctx s.["Successfully {0} group member", act]
return! redirectTo false "/web/small-group/members" next ctx
| Some _
| None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx
}
/// POST /small-group/preferences/save /// POST /small-group/preferences/save
let savePreferences : HttpHandler = let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ User ] match! ctx.TryBindFormAsync<EditPreferences> () with
>=> validateCSRF | Ok m ->
>=> fun next ctx -> // Since the class is stored in the session, we'll use an intermediate instance to persist it; once that works,
task { // we can repopulate the session instance. That way, if the update fails, the page should still show the
match! ctx.TryBindFormAsync<EditPreferences> () with // database values, not the then out-of-sync session ones.
| Ok m -> match! ctx.db.TryGroupById (currentGroup ctx).smallGroupId with
// Since the class is stored in the session, we'll use an intermediate instance to persist it; once that | Some grp ->
// works, we can repopulate the session instance. That way, if the update fails, the page should still show let prefs = m.populatePreferences grp.preferences
// the database values, not the then out-of-sync session ones. ctx.db.UpdateEntry prefs
match! ctx.db.TryGroupById (currentGroup ctx).smallGroupId with let! _ = ctx.db.SaveChangesAsync ()
| Some grp -> // Refresh session instance
let prefs = m.populatePreferences grp.preferences ctx.Session.smallGroup <- Some { grp with preferences = prefs }
ctx.db.UpdateEntry prefs let s = Views.I18N.localizer.Force ()
let! _ = ctx.db.SaveChangesAsync () addInfo ctx s["Group preferences updated successfully"]
// Refresh session instance return! redirectTo false "/web/small-group/preferences" next ctx
ctx.Session.smallGroup <- Some { grp with preferences = prefs } | None -> return! fourOhFour next ctx
let s = Views.I18N.localizer.Force () | Error e -> return! bindError e next ctx
addInfo ctx s.["Group preferences updated successfully"] }
return! redirectTo false "/web/small-group/preferences" next ctx
| None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx
}
/// POST /small-group/announcement/send /// POST /small-group/announcement/send
let sendAnnouncement : HttpHandler = let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx ->
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
task { match! ctx.TryBindFormAsync<Announcement> () with
match! ctx.TryBindFormAsync<Announcement> () with | Ok m ->
| Ok m -> let grp = currentGroup ctx
let grp = currentGroup ctx let usr = currentUser ctx
let usr = currentUser ctx let now = grp.localTimeNow (ctx.GetService<IClock> ())
let now = grp.localTimeNow (ctx.GetService<IClock> ()) let s = Views.I18N.localizer.Force ()
let s = Views.I18N.localizer.Force () // Reformat the text to use the class's font stylings
// Reformat the text to use the class's font stylings let requestText = ckEditorToText m.text
let requestText = ckEditorToText m.text let htmlText =
let htmlText =
p [ _style $"font-family:{grp.preferences.listFonts};font-size:%d{grp.preferences.textFontSize}pt;" ] p [ _style $"font-family:{grp.preferences.listFonts};font-size:%d{grp.preferences.textFontSize}pt;" ]
[ rawText requestText ] [ rawText requestText ]
|> renderHtmlNode |> renderHtmlNode
let plainText = (htmlToPlainText >> wordWrap 74) htmlText let plainText = (htmlToPlainText >> wordWrap 74) htmlText
// Send the e-mails // Send the e-mails
let! recipients = let! recipients =
match m.sendToClass with match m.sendToClass with
| "N" when usr.isAdmin -> ctx.db.AllUsersAsMembers () | "N" when usr.isAdmin -> ctx.db.AllUsersAsMembers ()
| _ -> ctx.db.AllMembersForSmallGroup grp.smallGroupId | _ -> ctx.db.AllMembersForSmallGroup grp.smallGroupId
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails client recipients grp do! Email.sendEmails client recipients grp
s.["Announcement for {0} - {1:MMMM d, yyyy} {2}", s["Announcement for {0} - {1:MMMM d, yyyy} {2}", grp.name, now.Date,
grp.name, now.Date, (now.ToString "h:mm tt").ToLower ()].Value (now.ToString "h:mm tt").ToLower ()].Value
htmlText plainText s htmlText plainText s
// Add to the request list if desired // Add to the request list if desired
match m.sendToClass, m.addToRequestList with match m.sendToClass, m.addToRequestList with
| "N", _ | "N", _
| _, None -> () | _, None -> ()
| _, Some x when not x -> () | _, Some x when not x -> ()
| _, _ -> | _, _ ->
{ PrayerRequest.empty with { PrayerRequest.empty with
prayerRequestId = Guid.NewGuid () prayerRequestId = Guid.NewGuid ()
smallGroupId = grp.smallGroupId smallGroupId = grp.smallGroupId
userId = usr.userId userId = usr.userId
requestType = (Option.get >> PrayerRequestType.fromCode) m.requestType requestType = (Option.get >> PrayerRequestType.fromCode) m.requestType
text = requestText text = requestText
enteredDate = now enteredDate = now
updatedDate = now updatedDate = now
} }
|> ctx.db.AddEntry |> ctx.db.AddEntry
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
() ()
// Tell 'em what they've won, Johnny! // Tell 'em what they've won, Johnny!
let toWhom = let toWhom =
match m.sendToClass with match m.sendToClass with
| "N" -> s.["{0} users", s.["PrayerTracker"]].Value | "N" -> s["{0} users", s["PrayerTracker"]].Value
| _ -> s.["Group Members"].Value.ToLower () | _ -> s["Group Members"].Value.ToLower ()
let andAdded = match m.addToRequestList with Some x when x -> "and added it to the request list" | _ -> "" let andAdded = match m.addToRequestList with Some x when x -> "and added it to the request list" | _ -> ""
addInfo ctx s.["Successfully sent announcement to all {0} {1}", toWhom, s.[andAdded]] addInfo ctx s["Successfully sent announcement to all {0} {1}", toWhom, s[andAdded]]
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.SmallGroup.announcementSent { m with text = htmlText } |> Views.SmallGroup.announcementSent { m with text = htmlText }
|> renderHtml next ctx |> renderHtml next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }

299
src/PrayerTracker/User.fs
View File

@ -1,5 +1,9 @@
module PrayerTracker.Handlers.User module PrayerTracker.Handlers.User
open System
open System.Collections.Generic
open System.Net
open System.Threading.Tasks
open Giraffe open Giraffe
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
@ -8,275 +12,244 @@ open PrayerTracker.Cookies
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
open PrayerTracker.Views.CommonFunctions open PrayerTracker.Views.CommonFunctions
open System
open System.Collections.Generic
open System.Net
open System.Threading.Tasks
/// Set the user's "remember me" cookie /// Set the user's "remember me" cookie
let private setUserCookie (ctx : HttpContext) pwHash = let private setUserCookie (ctx : HttpContext) pwHash =
ctx.Response.Cookies.Append ( ctx.Response.Cookies.Append (
Key.Cookie.user, Key.Cookie.user,
{ Id = (currentUser ctx).userId; GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (), { Id = (currentUser ctx).userId; GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (),
autoRefresh) autoRefresh)
/// Retrieve a user from the database by password /// Retrieve a user from the database by password
// If the hashes do not match, determine if it matches a previous scheme, and upgrade them if it does // If the hashes do not match, determine if it matches a previous scheme, and upgrade them if it does
let private findUserByPassword m (db : AppDbContext) = task { let private findUserByPassword m (db : AppDbContext) = task {
match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with
| Some u when Option.isSome u.salt -> | Some u when Option.isSome u.salt ->
// Already upgraded; match = success // Already upgraded; match = success
let pwHash = pbkdf2Hash (Option.get u.salt) m.password let pwHash = pbkdf2Hash (Option.get u.salt) m.password
match u.passwordHash = pwHash with if u.passwordHash = pwHash then
| true -> return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash
| _ -> return None, "" else return None, ""
| Some u when u.passwordHash = sha1Hash m.password -> | Some u when u.passwordHash = sha1Hash m.password ->
// Not upgraded, but password is good; upgrade 'em! // Not upgraded, but password is good; upgrade 'em!
// Upgrade 'em! // Upgrade 'em!
let salt = Guid.NewGuid () let salt = Guid.NewGuid ()
let pwHash = pbkdf2Hash salt m.password let pwHash = pbkdf2Hash salt m.password
let upgraded = { u with salt = Some salt; passwordHash = pwHash } let upgraded = { u with salt = Some salt; passwordHash = pwHash }
db.UpdateEntry upgraded db.UpdateEntry upgraded
let! _ = db.SaveChangesAsync () let! _ = db.SaveChangesAsync ()
return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash return Some { u with passwordHash = ""; salt = None; smallGroups = List<UserSmallGroup>() }, pwHash
| _ -> return None, "" | _ -> return None, ""
} }
/// POST /user/password/change /// POST /user/password/change
let changePassword : HttpHandler = let changePassword : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ User ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<ChangePassword> () with match! ctx.TryBindFormAsync<ChangePassword> () with
| Ok m -> | Ok m ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let curUsr = currentUser ctx let curUsr = currentUser ctx
let! dbUsr = ctx.db.TryUserById curUsr.userId let! dbUsr = ctx.db.TryUserById curUsr.userId
let! user = let! user =
match dbUsr with match dbUsr with
| Some usr -> | Some usr ->
// Check the old password against a possibly non-salted hash // Check the old password against a possibly non-salted hash
(match usr.salt with | Some salt -> pbkdf2Hash salt | _ -> sha1Hash) m.oldPassword (match usr.salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) m.oldPassword
|> ctx.db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId |> ctx.db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId
| _ -> Task.FromResult None | _ -> Task.FromResult None
match user with match user with
| Some _ when m.newPassword = m.newPasswordConfirm -> | Some _ when m.newPassword = m.newPasswordConfirm ->
match dbUsr with match dbUsr with
| Some usr -> | Some usr ->
// Generate salt if it has not been already // Generate new salt whenever the password is changed
let salt = match usr.salt with Some s -> s | _ -> Guid.NewGuid () let salt = Guid.NewGuid ()
ctx.db.UpdateEntry { usr with passwordHash = pbkdf2Hash salt m.newPassword; salt = Some salt } ctx.db.UpdateEntry { usr with passwordHash = pbkdf2Hash salt m.newPassword; salt = Some salt }
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
// If the user is remembered, update the cookie with the new hash // If the user is remembered, update the cookie with the new hash
match ctx.Request.Cookies.Keys.Contains Key.Cookie.user with if ctx.Request.Cookies.Keys.Contains Key.Cookie.user then setUserCookie ctx usr.passwordHash
| true -> setUserCookie ctx usr.passwordHash addInfo ctx s["Your password was changed successfully"]
| _ -> () | None -> addError ctx s["Unable to change password"]
addInfo ctx s.["Your password was changed successfully"]
| None -> addError ctx s.["Unable to change password"]
return! redirectTo false "/web/" next ctx return! redirectTo false "/web/" next ctx
| Some _ -> | Some _ ->
addError ctx s.["The new passwords did not match - your password was NOT changed"] addError ctx s["The new passwords did not match - your password was NOT changed"]
return! redirectTo false "/web/user/password" next ctx return! redirectTo false "/web/user/password" next ctx
| None -> | None ->
addError ctx s.["The old password was incorrect - your password was NOT changed"] addError ctx s["The old password was incorrect - your password was NOT changed"]
return! redirectTo false "/web/user/password" next ctx return! redirectTo false "/web/user/password" next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }
/// POST /user/[user-id]/delete /// POST /user/[user-id]/delete
let delete userId : HttpHandler = let delete userId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.db.TryUserById userId with match! ctx.db.TryUserById userId with
| Some user -> | Some user ->
ctx.db.RemoveEntry user ctx.db.RemoveEntry user
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
addInfo ctx s.["Successfully deleted user {0}", user.fullName] addInfo ctx s["Successfully deleted user {0}", user.fullName]
return! redirectTo false "/web/users" next ctx return! redirectTo false "/web/users" next ctx
| _ -> return! fourOhFour next ctx | _ -> return! fourOhFour next ctx
} }
/// POST /user/log-on /// POST /user/log-on
let doLogOn : HttpHandler = let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ AccessLevel.Public ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<UserLogOn> () with match! ctx.TryBindFormAsync<UserLogOn> () with
| Ok m -> | Ok m ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
let! usr, pwHash = findUserByPassword m ctx.db let! usr, pwHash = findUserByPassword m ctx.db
let! grp = ctx.db.TryGroupById m.smallGroupId let! grp = ctx.db.TryGroupById m.smallGroupId
let nextUrl = let nextUrl =
match usr with match usr with
| Some _ -> | Some _ ->
ctx.Session.user <- usr ctx.Session.user <- usr
ctx.Session.smallGroup <- grp ctx.Session.smallGroup <- grp
match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> () match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> ()
addHtmlInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]] addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
match m.redirectUrl with match m.redirectUrl with
| None -> "/web/small-group" | None -> "/web/small-group"
| Some x when x = "" -> "/web/small-group" | Some x when x = "" -> "/web/small-group"
| Some x -> x | Some x -> x
| _ -> | _ ->
let grpName = match grp with Some g -> g.name | _ -> "N/A" let grpName = match grp with Some g -> g.name | _ -> "N/A"
{ UserMessage.error with { UserMessage.error with
text = htmlLocString s.["Invalid credentials - log on unsuccessful"] text = htmlLocString s["Invalid credentials - log on unsuccessful"]
description = description =
[ s.["This is likely due to one of the following reasons"].Value [ s["This is likely due to one of the following reasons"].Value
":<ul><li>" ":<ul><li>"
s.["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode m.emailAddress].Value s["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode m.emailAddress].Value
"</li><li>" "</li><li>"
s.["The password entered does not match the password for the given e-mail address."].Value s["The password entered does not match the password for the given e-mail address."].Value
"</li><li>" "</li><li>"
s.["You are not authorized to administer the group “{0}”.", WebUtility.HtmlEncode grpName].Value s["You are not authorized to administer the group “{0}”.",
"</li></ul>" WebUtility.HtmlEncode grpName].Value
] "</li></ul>"
|> String.concat "" ]
|> (HtmlString >> Some) |> String.concat ""
|> (HtmlString >> Some)
} }
|> addUserMessage ctx |> addUserMessage ctx
"/web/user/log-on" "/web/user/log-on"
return! redirectTo false nextUrl next ctx return! redirectTo false nextUrl next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }
/// GET /user/[user-id]/edit /// GET /user/[user-id]/edit
let edit (userId : UserId) : HttpHandler = let edit (userId : UserId) : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
match userId = Guid.Empty with if userId = Guid.Empty then
| true ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.User.edit EditUser.empty ctx |> Views.User.edit EditUser.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
| false -> else
match! ctx.db.TryUserById userId with match! ctx.db.TryUserById userId with
| Some user -> | Some user ->
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.User.edit (EditUser.fromUser user) ctx |> Views.User.edit (EditUser.fromUser user) ctx
|> renderHtml next ctx |> renderHtml next ctx
| _ -> return! fourOhFour next ctx | _ -> return! fourOhFour next ctx
} }
/// GET /user/log-on /// GET /user/log-on
let logOn : HttpHandler = let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
requireAccess [ AccessLevel.Public ] let startTicks = DateTime.Now.Ticks
>=> fun next ctx -> task { let s = Views.I18N.localizer.Force ()
let startTicks = DateTime.Now.Ticks let! groups = ctx.db.GroupList ()
let s = Views.I18N.localizer.Force () let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
let! groups = ctx.db.GroupList ()
let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
match url with match url with
| Some _ -> | Some _ ->
ctx.Session.Remove Key.Session.redirectUrl ctx.Session.Remove Key.Session.redirectUrl
addWarning ctx s.["The page you requested requires authentication; please log on below."] addWarning ctx s["The page you requested requires authentication; please log on below."]
| None -> () | None -> ()
return! return!
{ viewInfo ctx startTicks with helpLink = Some Help.logOn } { viewInfo ctx startTicks with helpLink = Some Help.logOn }
|> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx |> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /users /// GET /users
let maintain : HttpHandler = let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
let! users = ctx.db.AllUsers () let! users = ctx.db.AllUsers ()
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.User.maintain users ctx |> Views.User.maintain users ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /user/password /// GET /user/password
let password : HttpHandler = let password : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
requireAccess [ User ]
>=> fun next ctx ->
{ viewInfo ctx DateTime.Now.Ticks with helpLink = Some Help.changePassword } { viewInfo ctx DateTime.Now.Ticks with helpLink = Some Help.changePassword }
|> Views.User.changePassword ctx |> Views.User.changePassword ctx
|> renderHtml next ctx |> renderHtml next ctx
/// POST /user/save /// POST /user/save
let save : HttpHandler = let save : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditUser> () with match! ctx.TryBindFormAsync<EditUser> () with
| Ok m -> | Ok m ->
let! user = let! user =
match m.isNew () with if m.isNew () then Task.FromResult (Some { User.empty with userId = Guid.NewGuid () })
| true -> Task.FromResult (Some { User.empty with userId = Guid.NewGuid () }) else ctx.db.TryUserById m.userId
| false -> ctx.db.TryUserById m.userId
let saltedUser = let saltedUser =
match user with match user with
| Some u -> | Some u ->
match u.salt with match u.salt with
| None when m.password <> "" -> | None when m.password <> "" ->
// Generate salt so that a new password hash can be generated // Generate salt so that a new password hash can be generated
Some { u with salt = Some (Guid.NewGuid ()) } Some { u with salt = Some (Guid.NewGuid ()) }
| _ -> | _ ->
// Leave the user with no salt, so prior hash can be validated/upgraded // Leave the user with no salt, so prior hash can be validated/upgraded
user user
| _ -> user | _ -> user
match saltedUser with match saltedUser with
| Some u -> | Some u ->
let updatedUser = m.populateUser u (pbkdf2Hash (Option.get u.salt)) let updatedUser = m.populateUser u (pbkdf2Hash (Option.get u.salt))
updatedUser |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry) updatedUser |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match m.isNew () with if m.isNew () then
| true ->
let h = CommonFunctions.htmlString let h = CommonFunctions.htmlString
{ UserMessage.info with { UserMessage.info with
text = h s.["Successfully {0} user", s.["Added"].Value.ToLower ()] text = h s["Successfully {0} user", s["Added"].Value.ToLower ()]
description = description =
h s.["Please select at least one group for which this user ({0}) is authorized", h s["Please select at least one group for which this user ({0}) is authorized",
updatedUser.fullName] updatedUser.fullName]
|> Some |> Some
} }
|> addUserMessage ctx |> addUserMessage ctx
return! redirectTo false $"/web/user/{flatGuid u.userId}/small-groups" next ctx return! redirectTo false $"/web/user/{flatGuid u.userId}/small-groups" next ctx
| false -> else
addInfo ctx s.["Successfully {0} user", s.["Updated"].Value.ToLower ()] addInfo ctx s["Successfully {0} user", s["Updated"].Value.ToLower ()]
return! redirectTo false "/web/users" next ctx return! redirectTo false "/web/users" next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }
/// POST /user/small-groups/save /// POST /user/small-groups/save
let saveGroups : HttpHandler = let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> validateCSRF
>=> fun next ctx -> task {
match! ctx.TryBindFormAsync<AssignGroups> () with match! ctx.TryBindFormAsync<AssignGroups> () with
| Ok m -> | Ok m ->
let s = Views.I18N.localizer.Force () let s = Views.I18N.localizer.Force ()
match Seq.length m.smallGroups with match Seq.length m.smallGroups with
| 0 -> | 0 ->
addError ctx s.["You must select at least one group to assign"] addError ctx s["You must select at least one group to assign"]
return! redirectTo false $"/web/user/{flatGuid m.userId}/small-groups" next ctx return! redirectTo false $"/web/user/{flatGuid m.userId}/small-groups" next ctx
| _ -> | _ ->
match! ctx.db.TryUserByIdWithGroups m.userId with match! ctx.db.TryUserByIdWithGroups m.userId with
| Some user -> | Some user ->
let grps = let grps =
m.smallGroups.Split ',' m.smallGroups.Split ','
|> Array.map Guid.Parse |> Array.map Guid.Parse
|> List.ofArray |> List.ofArray
user.smallGroups user.smallGroups
|> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId))) |> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId)))
|> ctx.db.UserGroupXref.RemoveRange |> ctx.db.UserGroupXref.RemoveRange
@ -287,25 +260,23 @@ let saveGroups : HttpHandler =
|> List.ofSeq |> List.ofSeq
|> List.iter ctx.db.AddEntry |> List.iter ctx.db.AddEntry
let! _ = ctx.db.SaveChangesAsync () let! _ = ctx.db.SaveChangesAsync ()
addInfo ctx s.["Successfully updated group permissions for {0}", m.userName] addInfo ctx s["Successfully updated group permissions for {0}", m.userName]
return! redirectTo false "/web/users" next ctx return! redirectTo false "/web/users" next ctx
| _ -> return! fourOhFour next ctx | _ -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx | Error e -> return! bindError e next ctx
} }
/// GET /user/[user-id]/small-groups /// GET /user/[user-id]/small-groups
let smallGroups userId : HttpHandler = let smallGroups userId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
requireAccess [ Admin ]
>=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks let startTicks = DateTime.Now.Ticks
match! ctx.db.TryUserByIdWithGroups userId with match! ctx.db.TryUserByIdWithGroups userId with
| Some user -> | Some user ->
let! grps = ctx.db.GroupList () let! grps = ctx.db.GroupList ()
let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq
return! return!
viewInfo ctx startTicks viewInfo ctx startTicks
|> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx |> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx
|> renderHtml next ctx |> renderHtml next ctx
| None -> return! fourOhFour next ctx | None -> return! fourOhFour next ctx
} }