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

v8.1 #47

Merged
danieljsummers merged 4 commits from v8.1 into main 2023-07-05 00:03:43 +00:00
Conversation 0 Commits 4 Files Changed 22 +475 -645
14 changed files with 475 additions and 645 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit 317c91ad08 - Show all commits

711
src/PrayerTracker.Data/Access.fs
View File

@ -103,126 +103,93 @@ module private Helpers =
} }
open BitBadger.Npgsql.FSharp.Documents
/// Functions to manipulate churches /// Functions to manipulate churches
module Churches = module Churches =
/// Get a list of all churches /// Get a list of all churches
let all conn = let all () =
Sql.existingConnection conn Custom.list "SELECT * FROM pt.church ORDER BY church_name" [] mapToChurch
|> Sql.query "SELECT * FROM pt.church ORDER BY church_name"
|> Sql.executeAsync mapToChurch
/// Delete a church by its ID /// Delete a church by its ID
let deleteById (churchId : ChurchId) conn = backgroundTask { let deleteById (churchId : ChurchId) = backgroundTask {
let idParam = [ [ "@churchId", Sql.uuid churchId.Value ] ] let idParam = [ [ "@churchId", Sql.uuid churchId.Value ] ]
let where = "WHERE small_group_id IN (SELECT id FROM pt.small_group WHERE church_id = @churchId)" let where = "WHERE small_group_id IN (SELECT id FROM pt.small_group WHERE church_id = @churchId)"
let! _ = let! _ =
Sql.existingConnection conn Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync |> Sql.executeTransactionAsync
[ $"DELETE FROM pt.prayer_request {where}", idParam [ $"DELETE FROM pt.prayer_request {where}", idParam
$"DELETE FROM pt.user_small_group {where}", idParam $"DELETE FROM pt.user_small_group {where}", idParam
$"DELETE FROM pt.list_preference {where}", idParam $"DELETE FROM pt.list_preference {where}", idParam
"DELETE FROM pt.small_group WHERE church_id = @churchId", idParam "DELETE FROM pt.small_group WHERE church_id = @churchId", idParam
"DELETE FROM pt.church WHERE id = @churchId", idParam ] "DELETE FROM pt.church WHERE id = @churchId", idParam ]
return () ()
} }
/// Save a church's information /// Save a church's information
let save (church : Church) conn = backgroundTask { let save (church : Church) =
let! _ = Custom.nonQuery
Sql.existingConnection conn "INSERT INTO pt.church (
|> Sql.query """ id, church_name, city, state, has_vps_interface, interface_address
INSERT INTO pt.church ( ) VALUES (
id, church_name, city, state, has_vps_interface, interface_address @id, @name, @city, @state, @hasVpsInterface, @interfaceAddress
) VALUES ( ) ON CONFLICT (id) DO UPDATE
@id, @name, @city, @state, @hasVpsInterface, @interfaceAddress SET church_name = EXCLUDED.church_name,
) ON CONFLICT (id) DO UPDATE city = EXCLUDED.city,
SET church_name = EXCLUDED.church_name, state = EXCLUDED.state,
city = EXCLUDED.city, has_vps_interface = EXCLUDED.has_vps_interface,
state = EXCLUDED.state, interface_address = EXCLUDED.interface_address"
has_vps_interface = EXCLUDED.has_vps_interface, [ "@id", Sql.uuid church.Id.Value
interface_address = EXCLUDED.interface_address""" "@name", Sql.string church.Name
|> Sql.parameters "@city", Sql.string church.City
[ "@id", Sql.uuid church.Id.Value "@state", Sql.string church.State
"@name", Sql.string church.Name "@hasVpsInterface", Sql.bool church.HasVpsInterface
"@city", Sql.string church.City "@interfaceAddress", Sql.stringOrNone church.InterfaceAddress ]
"@state", Sql.string church.State
"@hasVpsInterface", Sql.bool church.HasVpsInterface
"@interfaceAddress", Sql.stringOrNone church.InterfaceAddress ]
|> Sql.executeNonQueryAsync
return ()
}
/// Find a church by its ID /// Find a church by its ID
let tryById (churchId : ChurchId) conn = backgroundTask { let tryById (churchId : ChurchId) =
let! church = Custom.single "SELECT * FROM pt.church WHERE id = @id" [ "@id", Sql.uuid churchId.Value ] mapToChurch
Sql.existingConnection conn
|> Sql.query "SELECT * FROM pt.church WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid churchId.Value ]
|> Sql.executeAsync mapToChurch
return List.tryHead church
}
/// Functions to manipulate small group members /// Functions to manipulate small group members
module Members = module Members =
/// Count members for the given small group /// Count members for the given small group
let countByGroup (groupId : SmallGroupId) conn = let countByGroup (groupId : SmallGroupId) =
Sql.existingConnection conn Custom.scalar "SELECT COUNT(id) AS mbr_count FROM pt.member WHERE small_group_id = @groupId"
|> Sql.query "SELECT COUNT(id) AS mbr_count FROM pt.member WHERE small_group_id = @groupId" [ "@groupId", Sql.uuid groupId.Value ] (fun row -> row.int "mbr_count")
|> Sql.parameters [ "@groupId", Sql.uuid groupId.Value ]
|> Sql.executeRowAsync (fun row -> row.int "mbr_count")
/// Delete a small group member by its ID /// Delete a small group member by its ID
let deleteById (memberId : MemberId) conn = backgroundTask { let deleteById (memberId : MemberId) =
let! _ = Custom.nonQuery "DELETE FROM pt.member WHERE id = @id" [ "@id", Sql.uuid memberId.Value ]
Sql.existingConnection conn
|> Sql.query "DELETE FROM pt.member WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid memberId.Value ]
|> Sql.executeNonQueryAsync
return ()
}
/// Retrieve all members for a given small group /// Retrieve all members for a given small group
let forGroup (groupId : SmallGroupId) conn = let forGroup (groupId : SmallGroupId) =
Sql.existingConnection conn Custom.list "SELECT * FROM pt.member WHERE small_group_id = @groupId ORDER BY member_name"
|> Sql.query "SELECT * FROM pt.member WHERE small_group_id = @groupId ORDER BY member_name" [ "@groupId", Sql.uuid groupId.Value ] mapToMember
|> Sql.parameters [ "@groupId", Sql.uuid groupId.Value ]
|> Sql.executeAsync mapToMember
/// Save a small group member /// Save a small group member
let save (mbr : Member) conn = backgroundTask { let save (mbr : Member) =
let! _ = Custom.nonQuery
Sql.existingConnection conn "INSERT INTO pt.member (
|> Sql.query """ id, small_group_id, member_name, email, email_format
INSERT INTO pt.member ( ) VALUES (
id, small_group_id, member_name, email, email_format @id, @groupId, @name, @email, @format
) VALUES ( ) ON CONFLICT (id) DO UPDATE
@id, @groupId, @name, @email, @format SET member_name = EXCLUDED.member_name,
) ON CONFLICT (id) DO UPDATE email = EXCLUDED.email,
SET member_name = EXCLUDED.member_name, email_format = EXCLUDED.email_format"
email = EXCLUDED.email, [ "@id", Sql.uuid mbr.Id.Value
email_format = EXCLUDED.email_format""" "@groupId", Sql.uuid mbr.SmallGroupId.Value
|> Sql.parameters "@name", Sql.string mbr.Name
[ "@id", Sql.uuid mbr.Id.Value "@email", Sql.string mbr.Email
"@groupId", Sql.uuid mbr.SmallGroupId.Value "@format", Sql.stringOrNone (mbr.Format |> Option.map EmailFormat.toCode) ]
"@name", Sql.string mbr.Name
"@email", Sql.string mbr.Email
"@format", Sql.stringOrNone (mbr.Format |> Option.map EmailFormat.toCode) ]
|> Sql.executeNonQueryAsync
return ()
}
/// Retrieve a small group member by its ID /// Retrieve a small group member by its ID
let tryById (memberId : MemberId) conn = backgroundTask { let tryById (memberId : MemberId) =
let! mbr = Custom.single "SELECT * FROM pt.member WHERE id = @id" [ "@id", Sql.uuid memberId.Value ] mapToMember
Sql.existingConnection conn
|> Sql.query "SELECT * FROM pt.member WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid memberId.Value ]
|> Sql.executeAsync mapToMember
return List.tryHead mbr
}
/// Options to retrieve a list of requests /// Options to retrieve a list of requests
@ -258,34 +225,24 @@ module PrayerRequests =
if pageNbr > 0 then $"LIMIT {pageSize} OFFSET {(pageNbr - 1) * pageSize}" else "" if pageNbr > 0 then $"LIMIT {pageSize} OFFSET {(pageNbr - 1) * pageSize}" else ""
/// Count the number of prayer requests for a church /// Count the number of prayer requests for a church
let countByChurch (churchId : ChurchId) conn = let countByChurch (churchId : ChurchId) =
Sql.existingConnection conn Custom.scalar
|> Sql.query """ "SELECT COUNT(id) AS req_count
SELECT COUNT(id) AS req_count FROM pt.prayer_request
FROM pt.prayer_request WHERE small_group_id IN (SELECT id FROM pt.small_group WHERE church_id = @churchId)"
WHERE small_group_id IN (SELECT id FROM pt.small_group WHERE church_id = @churchId)""" [ "@churchId", Sql.uuid churchId.Value ] (fun row -> row.int "req_count")
|> Sql.parameters [ "@churchId", Sql.uuid churchId.Value ]
|> Sql.executeRowAsync (fun row -> row.int "req_count")
/// Count the number of prayer requests for a small group /// Count the number of prayer requests for a small group
let countByGroup (groupId : SmallGroupId) conn = let countByGroup (groupId : SmallGroupId) =
Sql.existingConnection conn Custom.scalar "SELECT COUNT(id) AS req_count FROM pt.prayer_request WHERE small_group_id = @groupId"
|> Sql.query "SELECT COUNT(id) AS req_count FROM pt.prayer_request WHERE small_group_id = @groupId" [ "@groupId", Sql.uuid groupId.Value ] (fun row -> row.int "req_count")
|> Sql.parameters [ "@groupId", Sql.uuid groupId.Value ]
|> Sql.executeRowAsync (fun row -> row.int "req_count")
/// Delete a prayer request by its ID /// Delete a prayer request by its ID
let deleteById (reqId : PrayerRequestId) conn = backgroundTask { let deleteById (reqId : PrayerRequestId) =
let! _ = Custom.nonQuery "DELETE FROM pt.prayer_request WHERE id = @id" [ "@id", Sql.uuid reqId.Value ]
Sql.existingConnection conn
|> Sql.query "DELETE FROM pt.prayer_request WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid reqId.Value ]
|> Sql.executeNonQueryAsync
return ()
}
/// 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
let forGroup (opts : PrayerRequestOptions) conn = let forGroup (opts : PrayerRequestOptions) =
let theDate = defaultArg opts.ListDate (SmallGroup.localDateNow opts.Clock opts.SmallGroup) let theDate = defaultArg opts.ListDate (SmallGroup.localDateNow opts.Clock opts.SmallGroup)
let where, parameters = let where, parameters =
if opts.ActiveOnly then if opts.ActiveOnly then
@ -294,198 +251,167 @@ module PrayerRequests =
(theDate.AtStartOfDayInZone(SmallGroup.timeZone opts.SmallGroup) (theDate.AtStartOfDayInZone(SmallGroup.timeZone opts.SmallGroup)
- Duration.FromDays opts.SmallGroup.Preferences.DaysToExpire) - Duration.FromDays opts.SmallGroup.Preferences.DaysToExpire)
.ToInstant ()) .ToInstant ())
""" AND ( updated_date > @asOf " AND ( updated_date > @asOf
OR expiration = @manual OR expiration = @manual
OR request_type = @longTerm OR request_type = @longTerm
OR request_type = @expecting) OR request_type = @expecting)
AND expiration <> @forced""", AND expiration <> @forced",
[ "@asOf", Sql.parameter asOf [ "@asOf", Sql.parameter asOf
"@manual", Sql.string (Expiration.toCode Manual) "@manual", Sql.string (Expiration.toCode Manual)
"@longTerm", Sql.string (PrayerRequestType.toCode LongTermRequest) "@longTerm", Sql.string (PrayerRequestType.toCode LongTermRequest)
"@expecting", Sql.string (PrayerRequestType.toCode Expecting) "@expecting", Sql.string (PrayerRequestType.toCode Expecting)
"@forced", Sql.string (Expiration.toCode Forced) ] "@forced", Sql.string (Expiration.toCode Forced) ]
else "", [] else "", []
Sql.existingConnection conn Custom.list
|> Sql.query $""" $"SELECT *
SELECT * FROM pt.prayer_request
FROM pt.prayer_request WHERE small_group_id = @groupId {where}
WHERE small_group_id = @groupId {where} ORDER BY {orderBy opts.SmallGroup.Preferences.RequestSort}
ORDER BY {orderBy opts.SmallGroup.Preferences.RequestSort} {paginate opts.PageNumber opts.SmallGroup.Preferences.PageSize}"
{paginate opts.PageNumber opts.SmallGroup.Preferences.PageSize}""" (("@groupId", Sql.uuid opts.SmallGroup.Id.Value) :: parameters) mapToPrayerRequest
|> Sql.parameters (("@groupId", Sql.uuid opts.SmallGroup.Id.Value) :: parameters)
|> Sql.executeAsync mapToPrayerRequest
/// Save a prayer request /// Save a prayer request
let save (req : PrayerRequest) conn = backgroundTask { let save (req : PrayerRequest) =
let! _ = Custom.nonQuery
Sql.existingConnection conn "INSERT into pt.prayer_request (
|> Sql.query """ id, request_type, user_id, small_group_id, entered_date, updated_date, requestor, request_text,
INSERT into pt.prayer_request ( notify_chaplain, expiration
id, request_type, user_id, small_group_id, entered_date, updated_date, requestor, request_text, ) VALUES (
notify_chaplain, expiration @id, @type, @userId, @groupId, @entered, @updated, @requestor, @text,
) VALUES ( @notifyChaplain, @expiration
@id, @type, @userId, @groupId, @entered, @updated, @requestor, @text, ) ON CONFLICT (id) DO UPDATE
@notifyChaplain, @expiration SET request_type = EXCLUDED.request_type,
) ON CONFLICT (id) DO UPDATE updated_date = EXCLUDED.updated_date,
SET request_type = EXCLUDED.request_type, requestor = EXCLUDED.requestor,
updated_date = EXCLUDED.updated_date, request_text = EXCLUDED.request_text,
requestor = EXCLUDED.requestor, notify_chaplain = EXCLUDED.notify_chaplain,
request_text = EXCLUDED.request_text, expiration = EXCLUDED.expiration"
notify_chaplain = EXCLUDED.notify_chaplain, [ "@id", Sql.uuid req.Id.Value
expiration = EXCLUDED.expiration""" "@type", Sql.string (PrayerRequestType.toCode req.RequestType)
|> Sql.parameters "@userId", Sql.uuid req.UserId.Value
[ "@id", Sql.uuid req.Id.Value "@groupId", Sql.uuid req.SmallGroupId.Value
"@type", Sql.string (PrayerRequestType.toCode req.RequestType) "@entered", Sql.parameter (NpgsqlParameter ("@entered", req.EnteredDate))
"@userId", Sql.uuid req.UserId.Value "@updated", Sql.parameter (NpgsqlParameter ("@updated", req.UpdatedDate))
"@groupId", Sql.uuid req.SmallGroupId.Value "@requestor", Sql.stringOrNone req.Requestor
"@entered", Sql.parameter (NpgsqlParameter ("@entered", req.EnteredDate)) "@text", Sql.string req.Text
"@updated", Sql.parameter (NpgsqlParameter ("@updated", req.UpdatedDate)) "@notifyChaplain", Sql.bool req.NotifyChaplain
"@requestor", Sql.stringOrNone req.Requestor "@expiration", Sql.string (Expiration.toCode req.Expiration) ]
"@text", Sql.string req.Text
"@notifyChaplain", Sql.bool req.NotifyChaplain
"@expiration", Sql.string (Expiration.toCode req.Expiration)
]
|> Sql.executeNonQueryAsync
return ()
}
/// Search prayer requests for the given term /// Search prayer requests for the given term
let searchForGroup group searchTerm pageNbr conn = let searchForGroup group searchTerm pageNbr =
Sql.existingConnection conn Custom.list
|> Sql.query $""" $"SELECT * FROM pt.prayer_request WHERE small_group_id = @groupId AND request_text ILIKE @search
SELECT * FROM pt.prayer_request WHERE small_group_id = @groupId AND request_text ILIKE @search UNION
UNION SELECT * FROM pt.prayer_request WHERE small_group_id = @groupId AND COALESCE(requestor, '') ILIKE @search
SELECT * FROM pt.prayer_request WHERE small_group_id = @groupId AND COALESCE(requestor, '') ILIKE @search ORDER BY {orderBy group.Preferences.RequestSort}
ORDER BY {orderBy group.Preferences.RequestSort} {paginate pageNbr group.Preferences.PageSize}"
{paginate pageNbr group.Preferences.PageSize}""" [ "@groupId", Sql.uuid group.Id.Value; "@search", Sql.string $"%%%s{searchTerm}%%" ] mapToPrayerRequest
|> Sql.parameters [ "@groupId", Sql.uuid group.Id.Value; "@search", Sql.string $"%%%s{searchTerm}%%" ]
|> Sql.executeAsync mapToPrayerRequest
/// Retrieve a prayer request by its ID /// Retrieve a prayer request by its ID
let tryById (reqId : PrayerRequestId) conn = backgroundTask { let tryById (reqId : PrayerRequestId) =
let! req = Custom.single "SELECT * FROM pt.prayer_request WHERE id = @id" [ "@id", Sql.uuid reqId.Value ]
Sql.existingConnection conn mapToPrayerRequest
|> Sql.query "SELECT * FROM pt.prayer_request WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid reqId.Value ]
|> Sql.executeAsync mapToPrayerRequest
return List.tryHead req
}
/// Update the expiration for the given prayer request /// Update the expiration for the given prayer request
let updateExpiration (req : PrayerRequest) withTime conn = backgroundTask { let updateExpiration (req : PrayerRequest) withTime =
let sql, parameters = let sql, parameters =
if withTime then if withTime then
", updated_date = @updated", ", updated_date = @updated",
[ "@updated", Sql.parameter (NpgsqlParameter ("@updated", req.UpdatedDate)) ] [ "@updated", Sql.parameter (NpgsqlParameter ("@updated", req.UpdatedDate)) ]
else "", [] else "", []
let! _ = Custom.nonQuery $"UPDATE pt.prayer_request SET expiration = @expiration{sql} WHERE id = @id"
Sql.existingConnection conn ([ "@expiration", Sql.string (Expiration.toCode req.Expiration)
|> Sql.query $"UPDATE pt.prayer_request SET expiration = @expiration{sql} WHERE id = @id" "@id", Sql.uuid req.Id.Value ]
|> Sql.parameters |> List.append parameters)
([ "@expiration", Sql.string (Expiration.toCode req.Expiration)
"@id", Sql.uuid req.Id.Value ]
|> List.append parameters)
|> Sql.executeNonQueryAsync
return ()
}
/// Functions to retrieve small group information /// Functions to retrieve small group information
module SmallGroups = module SmallGroups =
/// Count the number of small groups for a church /// Count the number of small groups for a church
let countByChurch (churchId : ChurchId) conn = let countByChurch (churchId : ChurchId) =
Sql.existingConnection conn Custom.scalar "SELECT COUNT(id) AS group_count FROM pt.small_group WHERE church_id = @churchId"
|> Sql.query "SELECT COUNT(id) AS group_count FROM pt.small_group WHERE church_id = @churchId" [ "@churchId", Sql.uuid churchId.Value ] (fun row -> row.int "group_count")
|> Sql.parameters [ "@churchId", Sql.uuid churchId.Value ]
|> Sql.executeRowAsync (fun row -> row.int "group_count")
/// Delete a small group by its ID /// Delete a small group by its ID
let deleteById (groupId : SmallGroupId) conn = backgroundTask { let deleteById (groupId : SmallGroupId) = backgroundTask {
let idParam = [ [ "@groupId", Sql.uuid groupId.Value ] ] let idParam = [ [ "@groupId", Sql.uuid groupId.Value ] ]
let! _ = let! _ =
Sql.existingConnection conn Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync |> Sql.executeTransactionAsync
[ "DELETE FROM pt.prayer_request WHERE small_group_id = @groupId", idParam [ "DELETE FROM pt.prayer_request WHERE small_group_id = @groupId", idParam
"DELETE FROM pt.user_small_group WHERE small_group_id = @groupId", idParam "DELETE FROM pt.user_small_group WHERE small_group_id = @groupId", idParam
"DELETE FROM pt.list_preference WHERE small_group_id = @groupId", idParam "DELETE FROM pt.list_preference WHERE small_group_id = @groupId", idParam
"DELETE FROM pt.small_group WHERE id = @groupId", idParam ] "DELETE FROM pt.small_group WHERE id = @groupId", idParam ]
return () ()
} }
/// Get information for all small groups /// Get information for all small groups
let infoForAll conn = let infoForAll () =
Sql.existingConnection conn Custom.list
|> Sql.query """ "SELECT sg.id, sg.group_name, c.church_name, lp.time_zone_id, lp.is_public
SELECT sg.id, sg.group_name, c.church_name, lp.time_zone_id, lp.is_public FROM pt.small_group sg
FROM pt.small_group sg INNER JOIN pt.church c ON c.id = sg.church_id
INNER JOIN pt.church c ON c.id = sg.church_id INNER JOIN pt.list_preference lp ON lp.small_group_id = sg.id
INNER JOIN pt.list_preference lp ON lp.small_group_id = sg.id ORDER BY sg.group_name"
ORDER BY sg.group_name""" [] mapToSmallGroupInfo
|> Sql.executeAsync mapToSmallGroupInfo
/// Get a list of small group IDs along with a description that includes the church name /// Get a list of small group IDs along with a description that includes the church name
let listAll conn = let listAll () =
Sql.existingConnection conn Custom.list
|> Sql.query """ "SELECT g.group_name, g.id, c.church_name
SELECT g.group_name, g.id, c.church_name FROM pt.small_group g
FROM pt.small_group g INNER JOIN pt.church c ON c.id = g.church_id
INNER JOIN pt.church c ON c.id = g.church_id ORDER BY c.church_name, g.group_name"
ORDER BY c.church_name, g.group_name""" [] mapToSmallGroupItem
|> Sql.executeAsync mapToSmallGroupItem
/// Get a list of small group IDs and descriptions for groups with a group password /// Get a list of small group IDs and descriptions for groups with a group password
let listProtected conn = let listProtected () =
Sql.existingConnection conn Custom.list
|> Sql.query """ "SELECT g.group_name, g.id, c.church_name, lp.is_public
SELECT g.group_name, g.id, c.church_name, lp.is_public FROM pt.small_group g
FROM pt.small_group g INNER JOIN pt.church c ON c.id = g.church_id
INNER JOIN pt.church c ON c.id = g.church_id INNER JOIN pt.list_preference lp ON lp.small_group_id = g.id
INNER JOIN pt.list_preference lp ON lp.small_group_id = g.id WHERE COALESCE(lp.group_password, '') <> ''
WHERE COALESCE(lp.group_password, '') <> '' ORDER BY c.church_name, g.group_name"
ORDER BY c.church_name, g.group_name""" [] mapToSmallGroupItem
|> Sql.executeAsync mapToSmallGroupItem
/// Get a list of small group IDs and descriptions for groups that are public or have a group password /// Get a list of small group IDs and descriptions for groups that are public or have a group password
let listPublicAndProtected conn = let listPublicAndProtected () =
Sql.existingConnection conn Custom.list
|> Sql.query """ "SELECT g.group_name, g.id, c.church_name, lp.time_zone_id, lp.is_public
SELECT g.group_name, g.id, c.church_name, lp.time_zone_id, lp.is_public FROM pt.small_group g
FROM pt.small_group g INNER JOIN pt.church c ON c.id = g.church_id
INNER JOIN pt.church c ON c.id = g.church_id INNER JOIN pt.list_preference lp ON lp.small_group_id = g.id
INNER JOIN pt.list_preference lp ON lp.small_group_id = g.id WHERE lp.is_public = TRUE
WHERE lp.is_public = TRUE OR COALESCE(lp.group_password, '') <> ''
OR COALESCE(lp.group_password, '') <> '' ORDER BY c.church_name, g.group_name"
ORDER BY c.church_name, g.group_name""" [] mapToSmallGroupInfo
|> Sql.executeAsync mapToSmallGroupInfo
/// Log on for a small group (includes list preferences) /// Log on for a small group (includes list preferences)
let logOn (groupId : SmallGroupId) password conn = backgroundTask { let logOn (groupId : SmallGroupId) password =
let! group = Custom.single
Sql.existingConnection conn "SELECT sg.*, lp.*
|> Sql.query """ FROM pt.small_group sg
SELECT sg.*, lp.* INNER JOIN pt.list_preference lp ON lp.small_group_id = sg.id
FROM pt.small_group sg WHERE sg.id = @id
INNER JOIN pt.list_preference lp ON lp.small_group_id = sg.id AND lp.group_password = @password"
WHERE sg.id = @id [ "@id", Sql.uuid groupId.Value; "@password", Sql.string password ] mapToSmallGroupWithPreferences
AND lp.group_password = @password"""
|> Sql.parameters [ "@id", Sql.uuid groupId.Value; "@password", Sql.string password ]
|> Sql.executeAsync mapToSmallGroupWithPreferences
return List.tryHead group
}
/// Save a small group /// Save a small group
let save (group : SmallGroup) isNew conn = backgroundTask { let save (group : SmallGroup) isNew = backgroundTask {
let! _ = let! _ =
Sql.existingConnection conn Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync [ |> Sql.executeTransactionAsync [
""" INSERT INTO pt.small_group ( "INSERT INTO pt.small_group (
id, church_id, group_name id, church_id, group_name
) VALUES ( ) VALUES (
@id, @churchId, @name @id, @churchId, @name
) ON CONFLICT (id) DO UPDATE ) ON CONFLICT (id) DO UPDATE
SET church_id = EXCLUDED.church_id, SET church_id = EXCLUDED.church_id,
group_name = EXCLUDED.group_name""", group_name = EXCLUDED.group_name",
[ [ "@id", Sql.uuid group.Id.Value [ [ "@id", Sql.uuid group.Id.Value
"@churchId", Sql.uuid group.ChurchId.Value "@churchId", Sql.uuid group.ChurchId.Value
"@name", Sql.string group.Name ] ] "@name", Sql.string group.Name ] ]
@ -493,216 +419,154 @@ module SmallGroups =
"INSERT INTO pt.list_preference (small_group_id) VALUES (@id)", "INSERT INTO pt.list_preference (small_group_id) VALUES (@id)",
[ [ "@id", Sql.uuid group.Id.Value ] ] [ [ "@id", Sql.uuid group.Id.Value ] ]
] ]
return () ()
} }
/// Save a small group's list preferences /// Save a small group's list preferences
let savePreferences (pref : ListPreferences) conn = backgroundTask { let savePreferences (pref : ListPreferences) =
let! _ = Custom.nonQuery
Sql.existingConnection conn "UPDATE pt.list_preference
|> Sql.query """ SET days_to_keep_new = @daysToKeepNew,
UPDATE pt.list_preference days_to_expire = @daysToExpire,
SET days_to_keep_new = @daysToKeepNew, long_term_update_weeks = @longTermUpdateWeeks,
days_to_expire = @daysToExpire, email_from_name = @emailFromName,
long_term_update_weeks = @longTermUpdateWeeks, email_from_address = @emailFromAddress,
email_from_name = @emailFromName, fonts = @fonts,
email_from_address = @emailFromAddress, heading_color = @headingColor,
fonts = @fonts, line_color = @lineColor,
heading_color = @headingColor, heading_font_size = @headingFontSize,
line_color = @lineColor, text_font_size = @textFontSize,
heading_font_size = @headingFontSize, request_sort = @requestSort,
text_font_size = @textFontSize, group_password = @groupPassword,
request_sort = @requestSort, default_email_type = @defaultEmailType,
group_password = @groupPassword, is_public = @isPublic,
default_email_type = @defaultEmailType, time_zone_id = @timeZoneId,
is_public = @isPublic, page_size = @pageSize,
time_zone_id = @timeZoneId, as_of_date_display = @asOfDateDisplay
page_size = @pageSize, WHERE small_group_id = @groupId"
as_of_date_display = @asOfDateDisplay [ "@groupId", Sql.uuid pref.SmallGroupId.Value
WHERE small_group_id = @groupId""" "@daysToKeepNew", Sql.int pref.DaysToKeepNew
|> Sql.parameters "@daysToExpire", Sql.int pref.DaysToExpire
[ "@groupId", Sql.uuid pref.SmallGroupId.Value "@longTermUpdateWeeks", Sql.int pref.LongTermUpdateWeeks
"@daysToKeepNew", Sql.int pref.DaysToKeepNew "@emailFromName", Sql.string pref.EmailFromName
"@daysToExpire", Sql.int pref.DaysToExpire "@emailFromAddress", Sql.string pref.EmailFromAddress
"@longTermUpdateWeeks", Sql.int pref.LongTermUpdateWeeks "@fonts", Sql.string pref.Fonts
"@emailFromName", Sql.string pref.EmailFromName "@headingColor", Sql.string pref.HeadingColor
"@emailFromAddress", Sql.string pref.EmailFromAddress "@lineColor", Sql.string pref.LineColor
"@fonts", Sql.string pref.Fonts "@headingFontSize", Sql.int pref.HeadingFontSize
"@headingColor", Sql.string pref.HeadingColor "@textFontSize", Sql.int pref.TextFontSize
"@lineColor", Sql.string pref.LineColor "@requestSort", Sql.string (RequestSort.toCode pref.RequestSort)
"@headingFontSize", Sql.int pref.HeadingFontSize "@groupPassword", Sql.string pref.GroupPassword
"@textFontSize", Sql.int pref.TextFontSize "@defaultEmailType", Sql.string (EmailFormat.toCode pref.DefaultEmailType)
"@requestSort", Sql.string (RequestSort.toCode pref.RequestSort) "@isPublic", Sql.bool pref.IsPublic
"@groupPassword", Sql.string pref.GroupPassword "@timeZoneId", Sql.string (TimeZoneId.toString pref.TimeZoneId)
"@defaultEmailType", Sql.string (EmailFormat.toCode pref.DefaultEmailType) "@pageSize", Sql.int pref.PageSize
"@isPublic", Sql.bool pref.IsPublic "@asOfDateDisplay", Sql.string (AsOfDateDisplay.toCode pref.AsOfDateDisplay) ]
"@timeZoneId", Sql.string (TimeZoneId.toString pref.TimeZoneId)
"@pageSize", Sql.int pref.PageSize
"@asOfDateDisplay", Sql.string (AsOfDateDisplay.toCode pref.AsOfDateDisplay)
]
|> Sql.executeNonQueryAsync
return ()
}
/// Get a small group by its ID /// Get a small group by its ID
let tryById (groupId : SmallGroupId) conn = backgroundTask { let tryById (groupId : SmallGroupId) =
let! group = Custom.single "SELECT * FROM pt.small_group WHERE id = @id" [ "@id", Sql.uuid groupId.Value ] mapToSmallGroup
Sql.existingConnection conn
|> Sql.query "SELECT * FROM pt.small_group WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid groupId.Value ]
|> Sql.executeAsync mapToSmallGroup
return List.tryHead group
}
/// Get a small group by its ID with its list preferences populated /// Get a small group by its ID with its list preferences populated
let tryByIdWithPreferences (groupId : SmallGroupId) conn = backgroundTask { let tryByIdWithPreferences (groupId : SmallGroupId) =
let! group = Custom.single
Sql.existingConnection conn "SELECT sg.*, lp.*
|> Sql.query """ FROM pt.small_group sg
SELECT sg.*, lp.* INNER JOIN pt.list_preference lp ON lp.small_group_id = sg.id
FROM pt.small_group sg WHERE sg.id = @id"
INNER JOIN pt.list_preference lp ON lp.small_group_id = sg.id [ "@id", Sql.uuid groupId.Value ] mapToSmallGroupWithPreferences
WHERE sg.id = @id"""
|> Sql.parameters [ "@id", Sql.uuid groupId.Value ]
|> Sql.executeAsync mapToSmallGroupWithPreferences
return List.tryHead group
}
/// Functions to manipulate users /// Functions to manipulate users
module Users = module Users =
/// Retrieve all PrayerTracker users /// Retrieve all PrayerTracker users
let all conn = let all () =
Sql.existingConnection conn Custom.list "SELECT * FROM pt.pt_user ORDER BY last_name, first_name" [] mapToUser
|> Sql.query "SELECT * FROM pt.pt_user ORDER BY last_name, first_name"
|> Sql.executeAsync mapToUser
/// Count the number of users for a church /// Count the number of users for a church
let countByChurch (churchId : ChurchId) conn = let countByChurch (churchId : ChurchId) =
Sql.existingConnection conn Custom.scalar
|> Sql.query """ "SELECT COUNT(u.id) AS user_count
SELECT COUNT(u.id) AS user_count FROM pt.pt_user u
FROM pt.pt_user u WHERE EXISTS (
WHERE EXISTS ( SELECT 1
SELECT 1 FROM pt.user_small_group usg
FROM pt.user_small_group usg INNER JOIN pt.small_group sg ON sg.id = usg.small_group_id
INNER JOIN pt.small_group sg ON sg.id = usg.small_group_id WHERE usg.user_id = u.id
WHERE usg.user_id = u.id AND sg.church_id = @churchId)"
AND sg.church_id = @churchId)""" [ "@churchId", Sql.uuid churchId.Value ] (fun row -> row.int "user_count")
|> Sql.parameters [ "@churchId", Sql.uuid churchId.Value ]
|> Sql.executeRowAsync (fun row -> row.int "user_count")
/// Count the number of users for a small group /// Count the number of users for a small group
let countByGroup (groupId : SmallGroupId) conn = let countByGroup (groupId : SmallGroupId) =
Sql.existingConnection conn Custom.scalar "SELECT COUNT(user_id) AS user_count FROM pt.user_small_group WHERE small_group_id = @groupId"
|> Sql.query "SELECT COUNT(user_id) AS user_count FROM pt.user_small_group WHERE small_group_id = @groupId" [ "@groupId", Sql.uuid groupId.Value ] (fun row -> row.int "user_count")
|> Sql.parameters [ "@groupId", Sql.uuid groupId.Value ]
|> Sql.executeRowAsync (fun row -> row.int "user_count")
/// Delete a user by its database ID /// Delete a user by its database ID
let deleteById (userId : UserId) conn = backgroundTask { let deleteById (userId : UserId) =
let! _ = Custom.nonQuery "DELETE FROM pt.pt_user WHERE id = @id" [ "@id", Sql.uuid userId.Value ]
Sql.existingConnection conn
|> Sql.query "DELETE FROM pt.pt_user WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid userId.Value ]
|> Sql.executeNonQueryAsync
return ()
}
/// Get the IDs of the small groups for which the given user is authorized /// Get the IDs of the small groups for which the given user is authorized
let groupIdsByUserId (userId : UserId) conn = let groupIdsByUserId (userId : UserId) =
Sql.existingConnection conn Custom.list "SELECT small_group_id FROM pt.user_small_group WHERE user_id = @id"
|> Sql.query "SELECT small_group_id FROM pt.user_small_group WHERE user_id = @id" [ "@id", Sql.uuid userId.Value ] (fun row -> SmallGroupId (row.uuid "small_group_id"))
|> Sql.parameters [ "@id", Sql.uuid userId.Value ]
|> Sql.executeAsync (fun row -> SmallGroupId (row.uuid "small_group_id"))
/// Get a list of users authorized to administer the given small group /// Get a list of users authorized to administer the given small group
let listByGroupId (groupId : SmallGroupId) conn = let listByGroupId (groupId : SmallGroupId) =
Sql.existingConnection conn Custom.list
|> Sql.query """ "SELECT u.*
SELECT u.* FROM pt.pt_user u
FROM pt.pt_user u INNER JOIN pt.user_small_group usg ON usg.user_id = u.id
INNER JOIN pt.user_small_group usg ON usg.user_id = u.id WHERE usg.small_group_id = @groupId
WHERE usg.small_group_id = @groupId ORDER BY u.last_name, u.first_name"
ORDER BY u.last_name, u.first_name""" [ "@groupId", Sql.uuid groupId.Value ] mapToUser
|> Sql.parameters [ "@groupId", Sql.uuid groupId.Value ]
|> Sql.executeAsync mapToUser
/// Save a user's information /// Save a user's information
let save (user : User) conn = backgroundTask { let save (user : User) =
let! _ = Custom.nonQuery
Sql.existingConnection conn "INSERT INTO pt.pt_user (
|> Sql.query """ id, first_name, last_name, email, is_admin, password_hash
INSERT INTO pt.pt_user ( ) VALUES (
id, first_name, last_name, email, is_admin, password_hash @id, @firstName, @lastName, @email, @isAdmin, @passwordHash
) VALUES ( ) ON CONFLICT (id) DO UPDATE
@id, @firstName, @lastName, @email, @isAdmin, @passwordHash SET first_name = EXCLUDED.first_name,
) ON CONFLICT (id) DO UPDATE last_name = EXCLUDED.last_name,
SET first_name = EXCLUDED.first_name, email = EXCLUDED.email,
last_name = EXCLUDED.last_name, is_admin = EXCLUDED.is_admin,
email = EXCLUDED.email, password_hash = EXCLUDED.password_hash"
is_admin = EXCLUDED.is_admin, [ "@id", Sql.uuid user.Id.Value
password_hash = EXCLUDED.password_hash""" "@firstName", Sql.string user.FirstName
|> Sql.parameters "@lastName", Sql.string user.LastName
[ "@id", Sql.uuid user.Id.Value "@email", Sql.string user.Email
"@firstName", Sql.string user.FirstName "@isAdmin", Sql.bool user.IsAdmin
"@lastName", Sql.string user.LastName "@passwordHash", Sql.string user.PasswordHash ]
"@email", Sql.string user.Email
"@isAdmin", Sql.bool user.IsAdmin
"@passwordHash", Sql.string user.PasswordHash
]
|> Sql.executeNonQueryAsync
return ()
}
/// Find a user by its e-mail address and authorized small group /// Find a user by its e-mail address and authorized small group
let tryByEmailAndGroup email (groupId : SmallGroupId) conn = backgroundTask { let tryByEmailAndGroup email (groupId : SmallGroupId) =
let! user = Custom.single
Sql.existingConnection conn "SELECT u.*
|> Sql.query """ FROM pt.pt_user u
SELECT u.* INNER JOIN pt.user_small_group usg ON usg.user_id = u.id AND usg.small_group_id = @groupId
FROM pt.pt_user u WHERE u.email = @email"
INNER JOIN pt.user_small_group usg ON usg.user_id = u.id AND usg.small_group_id = @groupId [ "@email", Sql.string email; "@groupId", Sql.uuid groupId.Value ] mapToUser
WHERE u.email = @email"""
|> Sql.parameters [ "@email", Sql.string email; "@groupId", Sql.uuid groupId.Value ]
|> Sql.executeAsync mapToUser
return List.tryHead user
}
/// Find a user by their database ID /// Find a user by their database ID
let tryById (userId : UserId) conn = backgroundTask { let tryById (userId : UserId) =
let! user = Custom.single "SELECT * FROM pt.pt_user WHERE id = @id" [ "@id", Sql.uuid userId.Value ] mapToUser
Sql.existingConnection conn
|> Sql.query "SELECT * FROM pt.pt_user WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid userId.Value ]
|> Sql.executeAsync mapToUser
return List.tryHead user
}
/// Update a user's last seen date/time /// Update a user's last seen date/time
let updateLastSeen (userId : UserId) (now : Instant) conn = backgroundTask { let updateLastSeen (userId : UserId) (now : Instant) =
let! _ = Custom.nonQuery "UPDATE pt.pt_user SET last_seen = @now WHERE id = @id"
Sql.existingConnection conn [ "@id", Sql.uuid userId.Value; "@now", Sql.parameter (NpgsqlParameter ("@now", now)) ]
|> Sql.query "UPDATE pt.pt_user SET last_seen = @now WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid userId.Value; "@now", Sql.parameter (NpgsqlParameter ("@now", now)) ]
|> Sql.executeNonQueryAsync
return ()
}
/// Update a user's password hash /// Update a user's password hash
let updatePassword (user : User) conn = backgroundTask { let updatePassword (user : User) =
let! _ = Custom.nonQuery "UPDATE pt.pt_user SET password_hash = @passwordHash WHERE id = @id"
Sql.existingConnection conn [ "@id", Sql.uuid user.Id.Value; "@passwordHash", Sql.string user.PasswordHash ]
|> Sql.query "UPDATE pt.pt_user SET password_hash = @passwordHash WHERE id = @id"
|> Sql.parameters [ "@id", Sql.uuid user.Id.Value; "@passwordHash", Sql.string user.PasswordHash ]
|> Sql.executeNonQueryAsync
return ()
}
/// Update a user's authorized small groups /// Update a user's authorized small groups
let updateSmallGroups (userId : UserId) groupIds conn = backgroundTask { let updateSmallGroups (userId : UserId) groupIds = backgroundTask {
let! existingGroupIds = groupIdsByUserId userId conn let! existingGroupIds = groupIdsByUserId userId
let toAdd = let toAdd =
groupIds |> List.filter (fun it -> existingGroupIds |> List.exists (fun grpId -> grpId = it) |> not) groupIds |> List.filter (fun it -> existingGroupIds |> List.exists (fun grpId -> grpId = it) |> not)
let toDelete = let toDelete =
@ -718,7 +582,8 @@ module Users =
} }
if not (Seq.isEmpty queries) then if not (Seq.isEmpty queries) then
let! _ = let! _ =
Sql.existingConnection conn Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync (List.ofSeq queries) |> Sql.executeTransactionAsync (List.ofSeq queries)
() ()
} }

103
src/PrayerTracker.Data/DistributedCache.fs
View File

@ -47,33 +47,30 @@ module private CacheHelpers =
p.ParameterName, Sql.parameter p p.ParameterName, Sql.parameter p
open BitBadger.Npgsql.FSharp.Documents
/// A distributed cache implementation in PostgreSQL used to handle sessions for myWebLog /// A distributed cache implementation in PostgreSQL used to handle sessions for myWebLog
type DistributedCache (connStr : string) = type DistributedCache () =
// ~~~ INITIALIZATION ~~~ // ~~~ INITIALIZATION ~~~
do do
task { task {
let! exists = let! exists =
Sql.connect connStr Custom.scalar
|> Sql.query $" $"SELECT EXISTS
SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public' AND tablename = 'session')
(SELECT 1 FROM pg_tables WHERE schemaname = 'public' AND tablename = 'session') AS does_exist"
AS does_exist" [] (fun row -> row.bool "does_exist")
|> Sql.executeRowAsync (fun row -> row.bool "does_exist")
if not exists then if not exists then
let! _ = do! Custom.nonQuery
Sql.connect connStr
|> Sql.query
"CREATE TABLE session ( "CREATE TABLE session (
id TEXT NOT NULL PRIMARY KEY, id TEXT NOT NULL PRIMARY KEY,
payload BYTEA NOT NULL, payload BYTEA NOT NULL,
expire_at TIMESTAMPTZ NOT NULL, expire_at TIMESTAMPTZ NOT NULL,
sliding_expiration INTERVAL, sliding_expiration INTERVAL,
absolute_expiration TIMESTAMPTZ); absolute_expiration TIMESTAMPTZ);
CREATE INDEX idx_session_expiration ON session (expire_at)" CREATE INDEX idx_session_expiration ON session (expire_at)" []
|> Sql.executeNonQueryAsync
()
} |> sync } |> sync
// ~~~ SUPPORT FUNCTIONS ~~~ // ~~~ SUPPORT FUNCTIONS ~~~
@ -82,16 +79,14 @@ type DistributedCache (connStr : string) =
let getEntry key = backgroundTask { let getEntry key = backgroundTask {
let idParam = "@id", Sql.string key let idParam = "@id", Sql.string key
let! tryEntry = let! tryEntry =
Sql.connect connStr Custom.single "SELECT * FROM session WHERE id = @id" [ idParam ]
|> Sql.query "SELECT * FROM session WHERE id = @id" (fun row ->
|> Sql.parameters [ idParam ] { Id = row.string "id"
|> Sql.executeAsync (fun row -> Payload = row.bytea "payload"
{ Id = row.string "id" ExpireAt = row.fieldValue<Instant> "expire_at"
Payload = row.bytea "payload" SlidingExpiration = row.fieldValueOrNone<Duration> "sliding_expiration"
ExpireAt = row.fieldValue<Instant> "expire_at" AbsoluteExpiration = row.fieldValueOrNone<Instant> "absolute_expiration" })
SlidingExpiration = row.fieldValueOrNone<Duration> "sliding_expiration" match tryEntry with
AbsoluteExpiration = row.fieldValueOrNone<Instant> "absolute_expiration" })
match List.tryHead tryEntry with
| Some entry -> | Some entry ->
let now = getNow () let now = getNow ()
let slideExp = defaultArg entry.SlidingExpiration Duration.MinValue let slideExp = defaultArg entry.SlidingExpiration Duration.MinValue
@ -103,12 +98,8 @@ type DistributedCache (connStr : string) =
true, { entry with ExpireAt = absExp } true, { entry with ExpireAt = absExp }
else true, { entry with ExpireAt = now.Plus slideExp } else true, { entry with ExpireAt = now.Plus slideExp }
if needsRefresh then if needsRefresh then
let! _ = do! Custom.nonQuery "UPDATE session SET expire_at = @expireAt WHERE id = @id"
Sql.connect connStr [ expireParam item.ExpireAt; idParam ]
|> Sql.query "UPDATE session SET expire_at = @expireAt WHERE id = @id"
|> Sql.parameters [ expireParam item.ExpireAt; idParam ]
|> Sql.executeNonQueryAsync
()
return if item.ExpireAt > now then Some entry else None return if item.ExpireAt > now then Some entry else None
| None -> return None | None -> return None
} }
@ -120,26 +111,16 @@ type DistributedCache (connStr : string) =
let purge () = backgroundTask { let purge () = backgroundTask {
let now = getNow () let now = getNow ()
if lastPurge.Plus (Duration.FromMinutes 30L) < now then if lastPurge.Plus (Duration.FromMinutes 30L) < now then
let! _ = do! Custom.nonQuery "DELETE FROM session WHERE expire_at < @expireAt" [ expireParam now ]
Sql.connect connStr
|> Sql.query "DELETE FROM session WHERE expire_at < @expireAt"
|> Sql.parameters [ expireParam now ]
|> Sql.executeNonQueryAsync
lastPurge <- now lastPurge <- now
} }
/// Remove a cache entry /// Remove a cache entry
let removeEntry key = backgroundTask { let removeEntry key =
let! _ = Custom.nonQuery "DELETE FROM session WHERE id = @id" [ "@id", Sql.string key ]
Sql.connect connStr
|> Sql.query "DELETE FROM session WHERE id = @id"
|> Sql.parameters [ "@id", Sql.string key ]
|> Sql.executeNonQueryAsync
()
}
/// Save an entry /// Save an entry
let saveEntry (opts : DistributedCacheEntryOptions) key payload = backgroundTask { let saveEntry (opts : DistributedCacheEntryOptions) key payload =
let now = getNow () let now = getNow ()
let expireAt, slideExp, absExp = let expireAt, slideExp, absExp =
if opts.SlidingExpiration.HasValue then if opts.SlidingExpiration.HasValue then
@ -155,27 +136,21 @@ type DistributedCache (connStr : string) =
// Default to 2 hour sliding expiration // Default to 2 hour sliding expiration
let slide = Duration.FromHours 2 let slide = Duration.FromHours 2
now.Plus slide, Some slide, None now.Plus slide, Some slide, None
let! _ = Custom.nonQuery
Sql.connect connStr "INSERT INTO session (
|> Sql.query id, payload, expire_at, sliding_expiration, absolute_expiration
"INSERT INTO session ( ) VALUES (
id, payload, expire_at, sliding_expiration, absolute_expiration @id, @payload, @expireAt, @slideExp, @absExp
) VALUES ( ) ON CONFLICT (id) DO UPDATE
@id, @payload, @expireAt, @slideExp, @absExp SET payload = EXCLUDED.payload,
) ON CONFLICT (id) DO UPDATE expire_at = EXCLUDED.expire_at,
SET payload = EXCLUDED.payload, sliding_expiration = EXCLUDED.sliding_expiration,
expire_at = EXCLUDED.expire_at, absolute_expiration = EXCLUDED.absolute_expiration"
sliding_expiration = EXCLUDED.sliding_expiration, [ "@id", Sql.string key
absolute_expiration = EXCLUDED.absolute_expiration" "@payload", Sql.bytea payload
|> Sql.parameters expireParam expireAt
[ "@id", Sql.string key optParam "slideExp" slideExp
"@payload", Sql.bytea payload optParam "absExp" absExp ]
expireParam expireAt
optParam "slideExp" slideExp
optParam "absExp" absExp ]
|> Sql.executeNonQueryAsync
()
}
// ~~~ IMPLEMENTATION FUNCTIONS ~~~ // ~~~ IMPLEMENTATION FUNCTIONS ~~~

9
src/PrayerTracker.Data/PrayerTracker.Data.fsproj
View File

@ -7,11 +7,12 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="BitBadger.Npgsql.FSharp.Documents" Version="1.0.0-beta3" />
<PackageReference Include="Giraffe" Version="6.0.0" /> <PackageReference Include="Giraffe" Version="6.0.0" />
<PackageReference Include="NodaTime" Version="3.1.2" /> <PackageReference Include="NodaTime" Version="3.1.9" />
<PackageReference Update="FSharp.Core" Version="6.0.5" /> <PackageReference Include="Npgsql.FSharp" Version="5.7.0" />
<PackageReference Include="Npgsql.FSharp" Version="5.3.0" /> <PackageReference Include="Npgsql.NodaTime" Version="7.0.4" />
<PackageReference Include="Npgsql.NodaTime" Version="6.0.6" /> <PackageReference Update="FSharp.Core" Version="7.0.300" />
</ItemGroup> </ItemGroup>
</Project> </Project>

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

@ -19,4 +19,4 @@ 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)

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

@ -304,14 +304,14 @@ let private contentSection viewInfo pgTitle (content : XmlNode) = [
| Some onLoad -> | Some onLoad ->
let doCall = if onLoad.EndsWith ")" then "" else "()" let doCall = if onLoad.EndsWith ")" then "" else "()"
script [] [ script [] [
rawText $""" rawText $"
window.doOnLoad = () => {{ window.doOnLoad = () => {{
if (window.PT) {{ if (window.PT) {{
{onLoad}{doCall} {onLoad}{doCall}
delete window.doOnLoad delete window.doOnLoad
}} else {{ setTimeout(window.doOnLoad, 500) }} }} else {{ setTimeout(window.doOnLoad, 500) }}
}} }}
window.doOnLoad()""" window.doOnLoad()"
] ]
| None -> () | None -> ()
] ]

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

@ -14,16 +14,15 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Giraffe" Version="6.0.0" />
<PackageReference Include="Giraffe.ViewEngine" Version="1.4.0" /> <PackageReference Include="Giraffe.ViewEngine" Version="1.4.0" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="1.8.0" /> <PackageReference Include="Giraffe.ViewEngine.Htmx" Version="1.9.2" />
<PackageReference Include="MailKit" Version="3.3.0" /> <PackageReference Include="MailKit" Version="4.1.0" />
<PackageReference Include="Microsoft.AspNetCore.Html.Abstractions" Version="2.2.0" /> <PackageReference Include="Microsoft.AspNetCore.Html.Abstractions" Version="2.2.0" />
<PackageReference Include="Microsoft.AspNetCore.Http" Version="2.2.2" /> <PackageReference Include="Microsoft.AspNetCore.Http" Version="2.2.2" />
<PackageReference Include="Microsoft.AspNetCore.Http.Extensions" Version="2.2.0" /> <PackageReference Include="Microsoft.AspNetCore.Http.Extensions" Version="2.2.0" />
<PackageReference Include="Microsoft.AspNetCore.Mvc" Version="2.2.0" /> <PackageReference Include="Microsoft.AspNetCore.Mvc" Version="2.2.0" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.2" /> <PackageReference Include="Newtonsoft.Json" Version="13.0.3" />
<PackageReference Update="FSharp.Core" Version="6.0.5" /> <PackageReference Update="FSharp.Core" Version="7.0.300" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>

20
src/PrayerTracker/App.fs
View File

@ -35,6 +35,7 @@ module Configure =
(ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel" (ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
open System.Globalization open System.Globalization
open BitBadger.Npgsql.FSharp.Documents
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Localization open Microsoft.AspNetCore.Localization
open Microsoft.Extensions.Caching.Distributed open Microsoft.Extensions.Caching.Distributed
@ -63,21 +64,18 @@ module Configure =
opts.SlidingExpiration <- true opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/error/403") opts.AccessDeniedPath <- "/error/403")
let _ = svc.AddAuthorization () let _ = svc.AddAuthorization ()
let _ =
svc.AddSingleton<IDistributedCache> (fun sp -> let cfg = svc.BuildServiceProvider().GetService<IConfiguration> ()
let cfg = sp.GetService<IConfiguration> () let dsb = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PrayerTracker")
DistributedCache (cfg.GetConnectionString "PrayerTracker") :> IDistributedCache) let _ = dsb.UseNodaTime()
Configuration.useDataSource (dsb.Build ())
let _ = svc.AddSingleton<IDistributedCache, DistributedCache> ()
let _ = svc.AddSession () let _ = svc.AddSession ()
let _ = svc.AddAntiforgery () let _ = svc.AddAntiforgery ()
let _ = svc.AddRouting () let _ = svc.AddRouting ()
let _ = svc.AddSingleton<IClock> SystemClock.Instance let _ = svc.AddSingleton<IClock> SystemClock.Instance
let _ =
svc.AddScoped<NpgsqlConnection>(fun sp ->
let cfg = sp.GetService<IConfiguration> ()
let conn = new NpgsqlConnection (cfg.GetConnectionString "PrayerTracker")
conn.OpenAsync () |> Async.AwaitTask |> Async.RunSynchronously
conn)
let _ = NpgsqlConnection.GlobalTypeMapper.UseNodaTime ()
() ()
open Giraffe open Giraffe

34
src/PrayerTracker/Church.fs
View File

@ -8,21 +8,20 @@ open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
/// Find statistics for the given church /// Find statistics for the given church
let private findStats churchId conn = task { let private findStats churchId = task {
let! groups = SmallGroups.countByChurch churchId conn let! groups = SmallGroups.countByChurch churchId
let! requests = PrayerRequests.countByChurch churchId conn let! requests = PrayerRequests.countByChurch churchId
let! users = Users.countByChurch churchId conn let! users = Users.countByChurch churchId
return shortGuid churchId.Value, { SmallGroups = groups; PrayerRequests = requests; Users = users } return shortGuid churchId.Value, { SmallGroups = groups; PrayerRequests = requests; Users = users }
} }
/// POST /church/[church-id]/delete // POST /church/[church-id]/delete
let delete chId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let delete chId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let churchId = ChurchId chId let churchId = ChurchId chId
let conn = ctx.Conn match! Churches.tryById churchId with
match! Churches.tryById churchId conn with
| Some church -> | Some church ->
let! _, stats = findStats churchId conn let! _, stats = findStats churchId
do! Churches.deleteById churchId conn do! Churches.deleteById churchId
addInfo ctx addInfo ctx
ctx.Strings["The church “{0}” and its {1} small group(s) (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)", ctx.Strings["The church “{0}” and its {1} small group(s) (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]
@ -32,7 +31,7 @@ let delete chId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun
open System open System
/// GET /church/[church-id]/edit // GET /church/[church-id]/edit
let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
if churchId = Guid.Empty then if churchId = Guid.Empty then
return! return!
@ -40,7 +39,7 @@ let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> ta
|> Views.Church.edit EditChurch.empty ctx |> Views.Church.edit EditChurch.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! Churches.tryById (ChurchId churchId) ctx.Conn with match! Churches.tryById (ChurchId churchId) with
| Some church -> | Some church ->
return! return!
viewInfo ctx viewInfo ctx
@ -49,27 +48,26 @@ let edit churchId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> ta
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
} }
/// GET /churches // GET /churches
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let conn = ctx.Conn let! churches = Churches.all ()
let! churches = Churches.all conn let stats = churches |> List.map (fun c -> findStats c.Id |> Async.AwaitTask |> Async.RunSynchronously)
let stats = churches |> List.map (fun c -> findStats c.Id conn |> Async.AwaitTask |> Async.RunSynchronously)
return! return!
viewInfo ctx viewInfo ctx
|> 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 = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditChurch> () with match! ctx.TryBindFormAsync<EditChurch> () with
| Ok model -> | Ok model ->
let! church = let! church =
if model.IsNew then Task.FromResult (Some { Church.empty with Id = (Guid.NewGuid >> ChurchId) () }) if model.IsNew then Task.FromResult (Some { Church.empty with Id = (Guid.NewGuid >> ChurchId) () })
else Churches.tryById (idFromShort ChurchId model.ChurchId) ctx.Conn else Churches.tryById (idFromShort ChurchId model.ChurchId)
match church with match church with
| Some ch -> | Some ch ->
do! Churches.save (model.PopulateChurch ch) ctx.Conn do! Churches.save (model.PopulateChurch ch)
let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower () let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addInfo ctx ctx.Strings["Successfully {0} church “{1}”", act, model.Name] addInfo ctx ctx.Strings["Successfully {0} church “{1}”", act, model.Name]
return! redirectTo false "/churches" next ctx return! redirectTo false "/churches" next ctx

11
src/PrayerTracker/Extensions.fs
View File

@ -76,14 +76,11 @@ type HttpContext with
/// The system clock (via DI) /// The system clock (via DI)
member this.Clock = this.GetService<IClock> () member this.Clock = this.GetService<IClock> ()
/// The PostgreSQL connection (configured via DI)
member this.Conn = this.GetService<NpgsqlConnection> ()
/// The current instant /// The current instant
member this.Now = this.Clock.GetCurrentInstant () member this.Now = this.Clock.GetCurrentInstant ()
/// The common string localizer /// The common string localizer
member this.Strings = Views.I18N.localizer.Force () member _.Strings = Views.I18N.localizer.Force ()
/// The currently logged on small group (sets the value in the session if it is missing) /// The currently logged on small group (sets the value in the session if it is missing)
member this.CurrentGroup () = task { member this.CurrentGroup () = task {
@ -92,7 +89,7 @@ type HttpContext with
| None -> | None ->
match this.User.SmallGroupId with match this.User.SmallGroupId with
| Some groupId -> | Some groupId ->
match! SmallGroups.tryByIdWithPreferences groupId this.Conn with match! SmallGroups.tryByIdWithPreferences groupId with
| Some group -> | Some group ->
this.Session.CurrentGroup <- Some group this.Session.CurrentGroup <- Some group
return Some group return Some group
@ -107,10 +104,10 @@ type HttpContext with
| None -> | None ->
match this.User.UserId with match this.User.UserId with
| Some userId -> | Some userId ->
match! Users.tryById userId this.Conn with match! Users.tryById userId with
| Some user -> | Some user ->
// Set last seen for user // Set last seen for user
do! Users.updateLastSeen userId this.Now this.Conn do! Users.updateLastSeen userId this.Now
this.Session.CurrentUser <- Some user this.Session.CurrentUser <- Some user
return Some user return Some user
| None -> return None | None -> return None

14
src/PrayerTracker/Home.fs
View File

@ -7,19 +7,19 @@ open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Localization open Microsoft.AspNetCore.Localization
open PrayerTracker open PrayerTracker
/// GET /error/[error-code] // GET /error/[error-code]
let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let error code : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx viewInfo ctx
|> Views.Home.error code |> Views.Home.error code
|> renderHtml next ctx |> renderHtml next ctx
/// GET / // GET /
let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx viewInfo ctx
|> Views.Home.index |> Views.Home.index
|> renderHtml next ctx |> renderHtml next ctx
/// GET /language/[culture] // GET /language/[culture]
let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
try try
match culture with match culture with
@ -42,13 +42,13 @@ let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fu
let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/" | r -> r let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/" | r -> r
redirectTo false url next ctx redirectTo false url next ctx
/// GET /legal/privacy-policy // GET /legal/privacy-policy
let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx viewInfo ctx
|> Views.Home.privacyPolicy |> Views.Home.privacyPolicy
|> renderHtml next ctx |> renderHtml next ctx
/// GET /legal/terms-of-service // GET /legal/terms-of-service
let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx viewInfo ctx
|> Views.Home.termsOfService |> Views.Home.termsOfService
@ -57,7 +57,7 @@ let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
open Microsoft.AspNetCore.Authentication open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
/// GET /log-off // GET /log-off
let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
ctx.Session.Clear () ctx.Session.Clear ()
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
@ -65,7 +65,7 @@ let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
return! redirectTo false "/" next ctx return! redirectTo false "/" next ctx
} }
/// GET /unauthorized // GET /unauthorized
let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx viewInfo ctx
|> Views.Home.unauthorized |> Views.Home.unauthorized

52
src/PrayerTracker/PrayerRequest.fs
View File

@ -9,7 +9,7 @@ open PrayerTracker.ViewModels
/// Retrieve a prayer request, and ensure that it belongs to the current class /// Retrieve a prayer request, and ensure that it belongs to the current class
let private findRequest (ctx : HttpContext) reqId = task { let private findRequest (ctx : HttpContext) reqId = task {
match! PrayerRequests.tryById reqId ctx.Conn with match! PrayerRequests.tryById reqId with
| Some req when req.SmallGroupId = ctx.Session.CurrentGroup.Value.Id -> return Ok req | Some req when req.SmallGroupId = ctx.Session.CurrentGroup.Value.Id -> return Ok req
| Some _ -> | Some _ ->
addError ctx ctx.Strings["The prayer request you tried to access is not assigned to your group"] addError ctx ctx.Strings["The prayer request you tried to access is not assigned to your group"]
@ -28,7 +28,7 @@ let private generateRequestList (ctx : HttpContext) date = task {
ListDate = Some listDate ListDate = Some listDate
ActiveOnly = true ActiveOnly = true
PageNumber = 0 PageNumber = 0
} ctx.Conn }
return return
{ Requests = reqs { Requests = reqs
Date = listDate Date = listDate
@ -49,7 +49,7 @@ let private parseListDate (date : string option) =
open System open System
/// GET /prayer-request/[request-id]/edit // GET /prayer-request/[request-id]/edit
let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let now = SmallGroup.localDateNow ctx.Clock group let now = SmallGroup.localDateNow ctx.Clock group
@ -79,13 +79,13 @@ let edit reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
| Result.Error e -> return! e | Result.Error e -> return! e
} }
/// GET /prayer-requests/email/[date] // GET /prayer-requests/email/[date]
let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let s = ctx.Strings let s = ctx.Strings
let listDate = parseListDate (Some date) let listDate = parseListDate (Some date)
let! list = generateRequestList ctx listDate let! list = generateRequestList ctx listDate
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let! recipients = Members.forGroup group.Id ctx.Conn let! recipients = Members.forGroup group.Id
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails do! Email.sendEmails
{ Client = client { Client = client
@ -102,31 +102,31 @@ let email date : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
|> renderHtml next ctx |> renderHtml next ctx
} }
/// POST /prayer-request/[request-id]/delete // POST /prayer-request/[request-id]/delete
let delete reqId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let delete reqId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
let requestId = PrayerRequestId reqId let requestId = PrayerRequestId reqId
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
do! PrayerRequests.deleteById req.Id ctx.Conn do! PrayerRequests.deleteById req.Id
addInfo ctx ctx.Strings["The prayer request was deleted successfully"] addInfo ctx ctx.Strings["The prayer request was deleted successfully"]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e | Result.Error e -> return! e
} }
/// GET /prayer-request/[request-id]/expire // GET /prayer-request/[request-id]/expire
let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let expire reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let requestId = PrayerRequestId reqId let requestId = PrayerRequestId reqId
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
do! PrayerRequests.updateExpiration { req with Expiration = Forced } false ctx.Conn do! PrayerRequests.updateExpiration { req with Expiration = Forced } false
addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings["Expired"].Value.ToLower ()] addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings["Expired"].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e | Result.Error e -> return! e
} }
/// GET /prayer-requests/[group-id]/list // GET /prayer-requests/[group-id]/list
let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
match! SmallGroups.tryByIdWithPreferences (SmallGroupId groupId) ctx.Conn with match! SmallGroups.tryByIdWithPreferences (SmallGroupId groupId) with
| Some group when group.Preferences.IsPublic -> | Some group when group.Preferences.IsPublic ->
let! reqs = let! reqs =
PrayerRequests.forGroup PrayerRequests.forGroup
@ -135,7 +135,7 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
ListDate = None ListDate = None
ActiveOnly = true ActiveOnly = true
PageNumber = 0 PageNumber = 0
} ctx.Conn }
return! return!
viewInfo ctx viewInfo ctx
|> Views.PrayerRequest.list |> Views.PrayerRequest.list
@ -153,18 +153,18 @@ let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun ne
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
} }
/// GET /prayer-requests/lists // GET /prayer-requests/lists
let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let! groups = SmallGroups.listPublicAndProtected ctx.Conn let! groups = SmallGroups.listPublicAndProtected ()
return! return!
viewInfo ctx viewInfo ctx
|> Views.PrayerRequest.lists groups |> 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 = requireAccess [ User ] >=> fun next ctx -> task { let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let pageNbr = let pageNbr =
@ -174,7 +174,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
let! model = backgroundTask { let! model = backgroundTask {
match ctx.GetQueryStringValue "search" with match ctx.GetQueryStringValue "search" with
| Ok search -> | Ok search ->
let! reqs = PrayerRequests.searchForGroup group search pageNbr ctx.Conn let! reqs = PrayerRequests.searchForGroup group search pageNbr
return return
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
@ -189,7 +189,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
ListDate = None ListDate = None
ActiveOnly = onlyActive ActiveOnly = onlyActive
PageNumber = pageNbr PageNumber = pageNbr
} ctx.Conn }
return return
{ MaintainRequests.empty with { MaintainRequests.empty with
Requests = reqs Requests = reqs
@ -203,7 +203,7 @@ let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /prayer-request/print/[date] // GET /prayer-request/print/[date]
let print date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task { let print date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task {
let! list = generateRequestList ctx (parseListDate (Some date)) let! list = generateRequestList ctx (parseListDate (Some date))
return! return!
@ -211,12 +211,12 @@ let print date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx ->
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /prayer-request/[request-id]/restore // GET /prayer-request/[request-id]/restore
let restore reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let restore reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let requestId = PrayerRequestId reqId let requestId = PrayerRequestId reqId
match! findRequest ctx requestId with match! findRequest ctx requestId with
| Ok req -> | Ok req ->
do! PrayerRequests.updateExpiration { req with Expiration = Automatic; UpdatedDate = ctx.Now } true ctx.Conn do! PrayerRequests.updateExpiration { req with Expiration = Automatic; UpdatedDate = ctx.Now } true
addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings["Restored"].Value.ToLower ()] addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings["Restored"].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
| Result.Error e -> return! e | Result.Error e -> return! e
@ -224,7 +224,7 @@ let restore reqId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> tas
open System.Threading.Tasks open System.Threading.Tasks
/// POST /prayer-request/save // POST /prayer-request/save
let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditRequest> () with match! ctx.TryBindFormAsync<EditRequest> () with
| Ok model -> | Ok model ->
@ -237,7 +237,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
UserId = ctx.User.UserId.Value UserId = ctx.User.UserId.Value
} }
|> (Some >> Task.FromResult) |> (Some >> Task.FromResult)
else PrayerRequests.tryById (idFromShort PrayerRequestId model.RequestId) ctx.Conn else PrayerRequests.tryById (idFromShort PrayerRequestId model.RequestId)
match req with match req with
| Some pr when pr.SmallGroupId = group.Id -> | Some pr when pr.SmallGroupId = group.Id ->
let now = SmallGroup.localDateNow ctx.Clock group let now = SmallGroup.localDateNow ctx.Clock group
@ -257,7 +257,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
{ it with EnteredDate = dt; UpdatedDate = dt } { it with EnteredDate = dt; UpdatedDate = dt }
| it when defaultArg model.SkipDateUpdate false -> it | it when defaultArg model.SkipDateUpdate false -> it
| it -> { it with UpdatedDate = ctx.Now } | it -> { it with UpdatedDate = ctx.Now }
do! PrayerRequests.save updated ctx.Conn do! PrayerRequests.save updated
let act = if model.IsNew then "Added" else "Updated" let act = if model.IsNew then "Added" else "Updated"
addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings[act].Value.ToLower ()] addInfo ctx ctx.Strings["Successfully {0} prayer request", ctx.Strings[act].Value.ToLower ()]
return! redirectTo false "/prayer-requests" next ctx return! redirectTo false "/prayer-requests" next ctx
@ -266,7 +266,7 @@ let save : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ct
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// GET /prayer-request/view/[date?] // GET /prayer-request/view/[date?]
let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task { let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task {
let! list = generateRequestList ctx (parseListDate date) let! list = generateRequestList ctx (parseListDate date)
return! return!

7
src/PrayerTracker/PrayerTracker.fsproj
View File

@ -24,10 +24,9 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="Giraffe" Version="6.0.0" /> <PackageReference Include="Giraffe.Htmx" Version="1.9.2" />
<PackageReference Include="Giraffe.Htmx" Version="1.8.0" /> <PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.0.1" />
<PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.0.0" /> <PackageReference Update="FSharp.Core" Version="7.0.300" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>

86
src/PrayerTracker/SmallGroup.fs
View File

@ -7,21 +7,20 @@ open PrayerTracker.Data
open PrayerTracker.Entities open PrayerTracker.Entities
open PrayerTracker.ViewModels open PrayerTracker.ViewModels
/// GET /small-group/announcement // GET /small-group/announcement
let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx -> let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
{ viewInfo ctx with HelpLink = Some Help.sendAnnouncement } { viewInfo ctx with HelpLink = Some Help.sendAnnouncement }
|> Views.SmallGroup.announcement ctx.Session.CurrentUser.Value.IsAdmin ctx |> Views.SmallGroup.announcement ctx.Session.CurrentUser.Value.IsAdmin ctx
|> renderHtml next ctx |> renderHtml next ctx
/// POST /small-group/[group-id]/delete // POST /small-group/[group-id]/delete
let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let groupId = SmallGroupId grpId let groupId = SmallGroupId grpId
let conn = ctx.Conn match! SmallGroups.tryById groupId with
match! SmallGroups.tryById groupId conn with
| Some grp -> | Some grp ->
let! reqs = PrayerRequests.countByGroup groupId conn let! reqs = PrayerRequests.countByGroup groupId
let! users = Users.countByGroup groupId conn let! users = Users.countByGroup groupId
do! SmallGroups.deleteById groupId conn do! SmallGroups.deleteById groupId
addInfo ctx addInfo ctx
ctx.Strings["The group “{0}” and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)", ctx.Strings["The group “{0}” and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)",
grp.Name, reqs, users] grp.Name, reqs, users]
@ -29,22 +28,22 @@ let delete grpId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fu
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
} }
/// POST /small-group/member/[member-id]/delete // POST /small-group/member/[member-id]/delete
let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let deleteMember mbrId : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let memberId = MemberId mbrId let memberId = MemberId mbrId
match! Members.tryById memberId ctx.Conn with match! Members.tryById memberId with
| Some mbr when mbr.SmallGroupId = group.Id -> | Some mbr when mbr.SmallGroupId = group.Id ->
do! Members.deleteById memberId ctx.Conn do! Members.deleteById memberId
addHtmlInfo ctx ctx.Strings["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.Name] addHtmlInfo ctx ctx.Strings["The group member &ldquo;{0}&rdquo; was deleted successfully", mbr.Name]
return! redirectTo false "/small-group/members" next ctx return! redirectTo false "/small-group/members" next ctx
| Some _ | Some _
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
} }
/// GET /small-group/[group-id]/edit // GET /small-group/[group-id]/edit
let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let! churches = Churches.all ctx.Conn let! churches = Churches.all ()
let groupId = SmallGroupId grpId let groupId = SmallGroupId grpId
if groupId.Value = Guid.Empty then if groupId.Value = Guid.Empty then
return! return!
@ -52,7 +51,7 @@ let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
|> Views.SmallGroup.edit EditSmallGroup.empty churches ctx |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! SmallGroups.tryById groupId ctx.Conn with match! SmallGroups.tryById groupId with
| Some grp -> | Some grp ->
return! return!
viewInfo ctx viewInfo ctx
@ -61,7 +60,7 @@ let edit grpId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
} }
/// GET /small-group/member/[member-id]/edit // GET /small-group/member/[member-id]/edit
let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType ctx.Strings let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType ctx.Strings
@ -72,7 +71,7 @@ let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
|> Views.SmallGroup.editMember EditMember.empty types ctx |> Views.SmallGroup.editMember EditMember.empty types ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! Members.tryById memberId ctx.Conn with match! Members.tryById memberId with
| Some mbr when mbr.SmallGroupId = group.Id -> | Some mbr when mbr.SmallGroupId = group.Id ->
return! return!
viewInfo ctx viewInfo ctx
@ -82,9 +81,9 @@ let editMember mbrId : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
} }
/// GET /small-group/log-on/[group-id?] // GET /small-group/log-on/[group-id?]
let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOn grpId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let! groups = SmallGroups.listProtected ctx.Conn let! groups = SmallGroups.listProtected ()
let groupId = match grpId with Some gid -> shortGuid gid | None -> "" let groupId = match grpId with Some gid -> shortGuid gid | None -> ""
return! return!
{ viewInfo ctx with HelpLink = Some Help.logOn } { viewInfo ctx with HelpLink = Some Help.logOn }
@ -96,11 +95,11 @@ open System.Security.Claims
open Microsoft.AspNetCore.Authentication open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
/// POST /small-group/log-on/submit // POST /small-group/log-on/submit
let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task { let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<GroupLogOn> () with match! ctx.TryBindFormAsync<GroupLogOn> () with
| Ok model -> | Ok model ->
match! SmallGroups.logOn (idFromShort SmallGroupId model.SmallGroupId) model.Password ctx.Conn with match! SmallGroups.logOn (idFromShort SmallGroupId model.SmallGroupId) model.Password with
| Some group -> | Some group ->
ctx.Session.CurrentGroup <- Some group ctx.Session.CurrentGroup <- Some group
let identity = ClaimsIdentity ( let identity = ClaimsIdentity (
@ -119,19 +118,19 @@ let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validat
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// GET /small-groups // GET /small-groups
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let! groups = SmallGroups.infoForAll ctx.Conn let! groups = SmallGroups.infoForAll ()
return! return!
viewInfo ctx viewInfo ctx
|> Views.SmallGroup.maintain groups ctx |> Views.SmallGroup.maintain groups ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group/members // GET /small-group/members
let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let! members = Members.forGroup group.Id ctx.Conn let! members = Members.forGroup group.Id
let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType ctx.Strings |> Map.ofSeq let types = ReferenceList.emailTypeList group.Preferences.DefaultEmailType ctx.Strings |> Map.ofSeq
return! return!
{ viewInfo ctx with HelpLink = Some Help.maintainGroupMembers } { viewInfo ctx with HelpLink = Some Help.maintainGroupMembers }
@ -139,20 +138,19 @@ let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group // GET /small-group
let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
let conn = ctx.Conn
let! reqs = PrayerRequests.forGroup let! reqs = PrayerRequests.forGroup
{ SmallGroup = group { SmallGroup = group
Clock = ctx.Clock Clock = ctx.Clock
ListDate = None ListDate = None
ActiveOnly = true ActiveOnly = true
PageNumber = 0 PageNumber = 0
} conn }
let! reqCount = PrayerRequests.countByGroup group.Id conn let! reqCount = PrayerRequests.countByGroup group.Id
let! mbrCount = Members.countByGroup group.Id conn let! mbrCount = Members.countByGroup group.Id
let! admins = Users.listByGroupId group.Id conn let! admins = Users.listByGroupId group.Id
let model = let model =
{ TotalActiveReqs = List.length reqs { TotalActiveReqs = List.length reqs
AllReqs = reqCount AllReqs = reqCount
@ -173,7 +171,7 @@ let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /small-group/preferences // GET /small-group/preferences
let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task { let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
return! return!
{ viewInfo ctx with HelpLink = Some Help.groupPreferences } { viewInfo ctx with HelpLink = Some Help.groupPreferences }
@ -183,16 +181,16 @@ let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task
open System.Threading.Tasks open System.Threading.Tasks
/// POST /small-group/save // POST /small-group/save
let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditSmallGroup> () with match! ctx.TryBindFormAsync<EditSmallGroup> () with
| Ok model -> | Ok model ->
let! tryGroup = let! tryGroup =
if model.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () }) if model.IsNew then Task.FromResult (Some { SmallGroup.empty with Id = (Guid.NewGuid >> SmallGroupId) () })
else SmallGroups.tryById (idFromShort SmallGroupId model.SmallGroupId) ctx.Conn else SmallGroups.tryById (idFromShort SmallGroupId model.SmallGroupId)
match tryGroup with match tryGroup with
| Some group -> | Some group ->
do! SmallGroups.save (model.populateGroup group) model.IsNew ctx.Conn do! SmallGroups.save (model.populateGroup group) model.IsNew
let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower () let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addHtmlInfo ctx ctx.Strings["Successfully {0} group “{1}”", act, model.Name] addHtmlInfo ctx ctx.Strings["Successfully {0} group “{1}”", act, model.Name]
return! redirectTo false "/small-groups" next ctx return! redirectTo false "/small-groups" next ctx
@ -200,7 +198,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// POST /small-group/member/save // POST /small-group/member/save
let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditMember> () with match! ctx.TryBindFormAsync<EditMember> () with
| Ok model -> | Ok model ->
@ -208,7 +206,7 @@ let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun n
let! tryMbr = let! tryMbr =
if model.IsNew then if model.IsNew then
Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = group.Id }) Task.FromResult (Some { Member.empty with Id = (Guid.NewGuid >> MemberId) (); SmallGroupId = group.Id })
else Members.tryById (idFromShort MemberId model.MemberId) ctx.Conn else Members.tryById (idFromShort MemberId model.MemberId)
match tryMbr with match tryMbr with
| Some mbr when mbr.SmallGroupId = group.Id -> | Some mbr when mbr.SmallGroupId = group.Id ->
do! Members.save do! Members.save
@ -216,7 +214,7 @@ let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun n
Name = model.Name Name = model.Name
Email = model.Email Email = model.Email
Format = String.noneIfBlank model.Format |> Option.map EmailFormat.fromCode Format = String.noneIfBlank model.Format |> Option.map EmailFormat.fromCode
} ctx.Conn }
let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower () let act = ctx.Strings[if model.IsNew then "Added" else "Updated"].Value.ToLower ()
addInfo ctx ctx.Strings["Successfully {0} group member", act] addInfo ctx ctx.Strings["Successfully {0} group member", act]
return! redirectTo false "/small-group/members" next ctx return! redirectTo false "/small-group/members" next ctx
@ -225,18 +223,18 @@ let saveMember : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun n
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// POST /small-group/preferences/save // POST /small-group/preferences/save
let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditPreferences> () with match! ctx.TryBindFormAsync<EditPreferences> () with
| Ok model -> | Ok model ->
// Since the class is stored in the session, we'll use an intermediate instance to persist it; once that works, // Since the class is stored in the session, we'll use an intermediate instance to persist it; once that works,
// we can repopulate the session instance. That way, if the update fails, the page should still show the // we can repopulate the session instance. That way, if the update fails, the page should still show the
// database values, not the then out-of-sync session ones. // database values, not the then out-of-sync session ones.
let group = ctx.Session.CurrentGroup.Value let group = ctx.Session.CurrentGroup.Value
match! SmallGroups.tryByIdWithPreferences group.Id ctx.Conn with match! SmallGroups.tryByIdWithPreferences group.Id with
| Some group -> | Some group ->
let pref = model.PopulatePreferences group.Preferences let pref = model.PopulatePreferences group.Preferences
do! SmallGroups.savePreferences pref ctx.Conn do! SmallGroups.savePreferences pref
// Refresh session instance // Refresh session instance
ctx.Session.CurrentGroup <- Some { group with Preferences = pref } ctx.Session.CurrentGroup <- Some { group with Preferences = pref }
addInfo ctx ctx.Strings["Group preferences updated successfully"] addInfo ctx ctx.Strings["Group preferences updated successfully"]
@ -248,7 +246,7 @@ let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
open Giraffe.ViewEngine open Giraffe.ViewEngine
open PrayerTracker.Views.CommonFunctions open PrayerTracker.Views.CommonFunctions
/// POST /small-group/announcement/send // POST /small-group/announcement/send
let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<Announcement> () with match! ctx.TryBindFormAsync<Announcement> () with
| Ok model -> | Ok model ->
@ -266,9 +264,9 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
// Send the e-mails // Send the e-mails
let! recipients = task { let! recipients = task {
if model.SendToClass = "N" && usr.IsAdmin then if model.SendToClass = "N" && usr.IsAdmin then
let! users = Users.all ctx.Conn let! users = Users.all ()
return users |> List.map (fun u -> { Member.empty with Name = u.Name; Email = u.Email }) return users |> List.map (fun u -> { Member.empty with Name = u.Name; Email = u.Email })
else return! Members.forGroup group.Id ctx.Conn else return! Members.forGroup group.Id
} }
use! client = Email.getConnection () use! client = Email.getConnection ()
do! Email.sendEmails do! Email.sendEmails
@ -297,7 +295,7 @@ let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCsrf >=>
Text = requestText Text = requestText
EnteredDate = now.Date.AtStartOfDayInZone(zone).ToInstant() EnteredDate = now.Date.AtStartOfDayInZone(zone).ToInstant()
UpdatedDate = now.InZoneLeniently(zone).ToInstant() UpdatedDate = now.InZoneLeniently(zone).ToInstant()
} ctx.Conn }
// Tell 'em what they've won, Johnny! // Tell 'em what they've won, Johnny!
let toWhom = let toWhom =
if model.SendToClass = "N" then s["{0} users", s["PrayerTracker"]].Value if model.SendToClass = "N" then s["{0} users", s["PrayerTracker"]].Value

58
src/PrayerTracker/User.fs
View File

@ -55,15 +55,15 @@ module Hashing =
/// Retrieve a user from the database by password, upgrading password hashes if required /// Retrieve a user from the database by password, upgrading password hashes if required
let private findUserByPassword model conn = task { let private findUserByPassword model = task {
match! Users.tryByEmailAndGroup model.Email (idFromShort SmallGroupId model.SmallGroupId) conn with match! Users.tryByEmailAndGroup model.Email (idFromShort SmallGroupId model.SmallGroupId) with
| Some user -> | Some user ->
let hasher = PrayerTrackerPasswordHasher () let hasher = PrayerTrackerPasswordHasher ()
match hasher.VerifyHashedPassword (user, user.PasswordHash, model.Password) with match hasher.VerifyHashedPassword (user, user.PasswordHash, model.Password) with
| PasswordVerificationResult.Success -> return Some user | PasswordVerificationResult.Success -> return Some user
| PasswordVerificationResult.SuccessRehashNeeded -> | PasswordVerificationResult.SuccessRehashNeeded ->
let upgraded = { user with PasswordHash = hasher.HashPassword (user, model.Password) } let upgraded = { user with PasswordHash = hasher.HashPassword (user, model.Password) }
do! Users.updatePassword upgraded conn do! Users.updatePassword upgraded
return Some upgraded return Some upgraded
| _ -> return None | _ -> return None
| None -> return None | None -> return None
@ -76,14 +76,14 @@ let sanitizeUrl providedUrl defaultUrl =
elif Seq.exists Char.IsControl url then defaultUrl elif Seq.exists Char.IsControl url then defaultUrl
else url else url
/// POST /user/password/change // POST /user/password/change
let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task { let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<ChangePassword> () with match! ctx.TryBindFormAsync<ChangePassword> () with
| Ok model -> | Ok model ->
let curUsr = ctx.Session.CurrentUser.Value let curUsr = ctx.Session.CurrentUser.Value
let hasher = PrayerTrackerPasswordHasher () let hasher = PrayerTrackerPasswordHasher ()
let! user = task { let! user = task {
match! Users.tryById curUsr.Id ctx.Conn with match! Users.tryById curUsr.Id with
| Some usr -> | Some usr ->
if hasher.VerifyHashedPassword (usr, usr.PasswordHash, model.OldPassword) if hasher.VerifyHashedPassword (usr, usr.PasswordHash, model.OldPassword)
= PasswordVerificationResult.Success then = PasswordVerificationResult.Success then
@ -93,7 +93,7 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f
} }
match user with match user with
| Some usr when model.NewPassword = model.NewPasswordConfirm -> | Some usr when model.NewPassword = model.NewPasswordConfirm ->
do! Users.updatePassword { usr with PasswordHash = hasher.HashPassword (usr, model.NewPassword) } ctx.Conn do! Users.updatePassword { usr with PasswordHash = hasher.HashPassword (usr, model.NewPassword) }
addInfo ctx ctx.Strings["Your password was changed successfully"] addInfo ctx ctx.Strings["Your password was changed successfully"]
return! redirectTo false "/" next ctx return! redirectTo false "/" next ctx
| Some _ -> | Some _ ->
@ -105,12 +105,12 @@ let changePassword : HttpHandler = requireAccess [ User ] >=> validateCsrf >=> f
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// POST /user/[user-id]/delete // POST /user/[user-id]/delete
let delete usrId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let delete usrId : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
let userId = UserId usrId let userId = UserId usrId
match! Users.tryById userId ctx.Conn with match! Users.tryById userId with
| Some user -> | Some user ->
do! Users.deleteById userId ctx.Conn do! Users.deleteById userId
addInfo ctx ctx.Strings["Successfully deleted user {0}", user.Name] addInfo ctx ctx.Strings["Successfully deleted user {0}", user.Name]
return! redirectTo false "/users" next ctx return! redirectTo false "/users" next ctx
| _ -> return! fourOhFour ctx | _ -> return! fourOhFour ctx
@ -122,14 +122,14 @@ open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Html open Microsoft.AspNetCore.Html
/// POST /user/log-on // POST /user/log-on
let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task { let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<UserLogOn> () with match! ctx.TryBindFormAsync<UserLogOn> () with
| Ok model -> | Ok model ->
let s = ctx.Strings let s = ctx.Strings
match! findUserByPassword model ctx.Conn with match! findUserByPassword model with
| Some user -> | Some user ->
match! SmallGroups.tryByIdWithPreferences (idFromShort SmallGroupId model.SmallGroupId) ctx.Conn with match! SmallGroups.tryByIdWithPreferences (idFromShort SmallGroupId model.SmallGroupId) with
| Some group -> | Some group ->
ctx.Session.CurrentUser <- Some user ctx.Session.CurrentUser <- Some user
ctx.Session.CurrentGroup <- Some group ctx.Session.CurrentGroup <- Some group
@ -143,7 +143,7 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
AuthenticationProperties ( AuthenticationProperties (
IssuedUtc = DateTimeOffset.UtcNow, IssuedUtc = DateTimeOffset.UtcNow,
IsPersistent = defaultArg model.RememberMe false)) IsPersistent = defaultArg model.RememberMe false))
do! Users.updateLastSeen user.Id ctx.Now ctx.Conn do! Users.updateLastSeen user.Id ctx.Now
addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]] addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
return! redirectTo false (sanitizeUrl model.RedirectUrl "/small-group") next ctx return! redirectTo false (sanitizeUrl model.RedirectUrl "/small-group") next ctx
| None -> return! fourOhFour ctx | None -> return! fourOhFour ctx
@ -165,7 +165,7 @@ let doLogOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCsr
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// GET /user/[user-id]/edit // GET /user/[user-id]/edit
let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let userId = UserId usrId let userId = UserId usrId
if userId.Value = Guid.Empty then if userId.Value = Guid.Empty then
@ -174,7 +174,7 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
|> Views.User.edit EditUser.empty ctx |> Views.User.edit EditUser.empty ctx
|> renderHtml next ctx |> renderHtml next ctx
else else
match! Users.tryById userId ctx.Conn with match! Users.tryById userId with
| Some user -> | Some user ->
return! return!
viewInfo ctx viewInfo ctx
@ -183,9 +183,9 @@ let edit usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task
| _ -> return! fourOhFour ctx | _ -> return! fourOhFour ctx
} }
/// GET /user/log-on // GET /user/log-on
let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task { let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let! groups = SmallGroups.listAll ctx.Conn let! groups = SmallGroups.listAll ()
let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
match url with match url with
| Some _ -> | Some _ ->
@ -198,16 +198,16 @@ let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx
|> renderHtml next ctx |> renderHtml next ctx
} }
/// GET /users // GET /users
let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let! users = Users.all ctx.Conn let! users = Users.all ()
return! return!
viewInfo ctx viewInfo ctx
|> 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 = requireAccess [ User ] >=> fun next ctx -> let password : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
{ viewInfo ctx with HelpLink = Some Help.changePassword } { viewInfo ctx with HelpLink = Some Help.changePassword }
|> Views.User.changePassword ctx |> Views.User.changePassword ctx
@ -215,18 +215,18 @@ let password : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
open System.Threading.Tasks open System.Threading.Tasks
/// POST /user/save // POST /user/save
let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<EditUser> () with match! ctx.TryBindFormAsync<EditUser> () with
| Ok model -> | Ok model ->
let! user = let! user =
if model.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () }) if model.IsNew then Task.FromResult (Some { User.empty with Id = (Guid.NewGuid >> UserId) () })
else Users.tryById (idFromShort UserId model.UserId) ctx.Conn else Users.tryById (idFromShort UserId model.UserId)
match user with match user with
| Some usr -> | Some usr ->
let hasher = PrayerTrackerPasswordHasher () let hasher = PrayerTrackerPasswordHasher ()
let updatedUser = model.PopulateUser usr (fun pw -> hasher.HashPassword (usr, pw)) let updatedUser = model.PopulateUser usr (fun pw -> hasher.HashPassword (usr, pw))
do! Users.save updatedUser ctx.Conn do! Users.save updatedUser
let s = ctx.Strings let s = ctx.Strings
if model.IsNew then if model.IsNew then
let h = CommonFunctions.htmlString let h = CommonFunctions.htmlString
@ -246,7 +246,7 @@ let save : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next c
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// POST /user/small-groups/save // POST /user/small-groups/save
let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task { let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun next ctx -> task {
match! ctx.TryBindFormAsync<AssignGroups> () with match! ctx.TryBindFormAsync<AssignGroups> () with
| Ok model -> | Ok model ->
@ -256,19 +256,19 @@ let saveGroups : HttpHandler = requireAccess [ Admin ] >=> validateCsrf >=> fun
return! redirectTo false $"/user/{model.UserId}/small-groups" next ctx return! redirectTo false $"/user/{model.UserId}/small-groups" next ctx
| _ -> | _ ->
do! Users.updateSmallGroups (idFromShort UserId model.UserId) do! Users.updateSmallGroups (idFromShort UserId model.UserId)
(model.SmallGroups.Split ',' |> Array.map (idFromShort SmallGroupId) |> List.ofArray) ctx.Conn (model.SmallGroups.Split ',' |> Array.map (idFromShort SmallGroupId) |> List.ofArray)
addInfo ctx ctx.Strings["Successfully updated group permissions for {0}", model.UserName] addInfo ctx ctx.Strings["Successfully updated group permissions for {0}", model.UserName]
return! redirectTo false "/users" next ctx return! redirectTo false "/users" next ctx
| Result.Error e -> return! bindError e next ctx | Result.Error e -> return! bindError e next ctx
} }
/// GET /user/[user-id]/small-groups // GET /user/[user-id]/small-groups
let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task { let smallGroups usrId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let userId = UserId usrId let userId = UserId usrId
match! Users.tryById userId ctx.Conn with match! Users.tryById userId with
| Some user -> | Some user ->
let! groups = SmallGroups.listAll ctx.Conn let! groups = SmallGroups.listAll ()
let! groupIds = Users.groupIdsByUserId userId ctx.Conn let! groupIds = Users.groupIdsByUserId userId
let curGroups = groupIds |> List.map (fun g -> shortGuid g.Value) let curGroups = groupIds |> List.map (fun g -> shortGuid g.Value)
return! return!
viewInfo ctx viewInfo ctx