]
module PrayerTracker.Utils
-open System.Net
+open System
open System.Security.Cryptography
open System.Text
-open System.Text.RegularExpressions
-open System
/// Hash a string with a SHA1 hash
let sha1Hash (x : string) =
- use alg = SHA1.Create ()
- alg.ComputeHash (Encoding.ASCII.GetBytes x)
- |> Seq.map (fun chr -> chr.ToString "x2")
- |> String.concat ""
+ use alg = SHA1.Create ()
+ alg.ComputeHash (Encoding.ASCII.GetBytes x)
+ |> Seq.map (fun chr -> chr.ToString "x2")
+ |> String.concat ""
/// Hash a string using 1,024 rounds of PBKDF2 and a salt
let pbkdf2Hash (salt : Guid) (x : string) =
- use alg = new Rfc2898DeriveBytes (x, Encoding.UTF8.GetBytes (salt.ToString "N"), 1024)
- (alg.GetBytes >> Convert.ToBase64String) 64
+ use alg = new Rfc2898DeriveBytes (x, Encoding.UTF8.GetBytes (salt.ToString "N"), 1024)
+ (alg.GetBytes >> Convert.ToBase64String) 64
/// String helper functions
module String =
- /// string.Trim()
- let trim (str: string) = str.Trim ()
+ /// string.Trim()
+ let trim (str: string) = str.Trim ()
- /// string.Replace()
- let replace (find : string) repl (str : string) = str.Replace (find, repl)
+ /// string.Replace()
+ let replace (find : string) repl (str : string) = str.Replace (find, repl)
- /// Replace the first occurrence of a string with a second string within a given string
- let replaceFirst (needle : string) replacement (haystack : string) =
- match haystack.IndexOf needle with
- | -1 -> haystack
- | idx ->
- [ haystack.[0..idx - 1]
- replacement
- haystack.[idx + needle.Length..]
- ]
- |> String.concat ""
+ /// Replace the first occurrence of a string with a second string within a given string
+ let replaceFirst (needle : string) replacement (haystack : string) =
+ match haystack.IndexOf needle with
+ | -1 -> haystack
+ | idx ->
+ [ haystack[0..idx - 1]
+ replacement
+ haystack[idx + needle.Length..]
+ ]
+ |> String.concat ""
+open System.Text.RegularExpressions
+
/// Strip HTML tags from the given string
// Adapted from http://www.dijksterhuis.org/safely-cleaning-html-with-strip_tags-in-csharp/
let stripTags allowedTags input =
- let stripHtmlExp = Regex @"(<\/?[^>]+>)"
- let mutable output = input
- for tag in stripHtmlExp.Matches input do
- let htmlTag = tag.Value.ToLower ()
- let isAllowed =
- allowedTags
- |> List.fold
- (fun acc t ->
- acc
+ let stripHtmlExp = Regex @"(<\/?[^>]+>)"
+ let mutable output = input
+ for tag in stripHtmlExp.Matches input do
+ let htmlTag = tag.Value.ToLower ()
+ let isAllowed =
+ allowedTags
+ |> List.fold (fun acc t ->
+ acc
|| htmlTag.IndexOf $"<{t}>" = 0
|| htmlTag.IndexOf $"<{t} " = 0
|| htmlTag.IndexOf $"{t}" = 0) false
- match isAllowed with
- | true -> ()
- | false -> output <- String.replaceFirst tag.Value "" output
- output
+ if isAllowed then output <- String.replaceFirst tag.Value "" output
+ output
/// Wrap a string at the specified number of characters
let wordWrap charPerLine (input : string) =
- match input.Length with
- | len when len <= charPerLine -> input
- | _ ->
- seq {
- for line in input.Replace("\r", "").Split '\n' do
- let mutable remaining = line
- match remaining.Length with
- | 0 -> ()
- | _ ->
- while charPerLine < remaining.Length do
- match charPerLine + 1 < remaining.Length && remaining.[charPerLine] = ' ' with
- | true ->
- // Line length is followed by a space; return [charPerLine] as a line
- yield remaining.[0..charPerLine - 1]
- remaining <- remaining.[charPerLine + 1..]
- | false ->
- match remaining.[0..charPerLine - 1].LastIndexOf ' ' with
- | -1 ->
- // No whitespace; just break it at [characters]
- yield remaining.[0..charPerLine - 1]
- remaining <- remaining.[charPerLine..]
- | spaceIdx ->
- // Break on the last space in the line
- yield remaining.[0..spaceIdx - 1]
- remaining <- remaining.[spaceIdx + 1..]
- // Leftovers - yum!
- match remaining.Length with 0 -> () | _ -> yield remaining
+ match input.Length with
+ | len when len <= charPerLine -> input
+ | _ ->
+ seq {
+ for line in input.Replace("\r", "").Split '\n' do
+ let mutable remaining = line
+ match remaining.Length with
+ | 0 -> ()
+ | _ ->
+ while charPerLine < remaining.Length do
+ if charPerLine + 1 < remaining.Length && remaining[charPerLine] = ' ' then
+ // Line length is followed by a space; return [charPerLine] as a line
+ yield remaining[0..charPerLine - 1]
+ remaining <- remaining[charPerLine + 1..]
+ else
+ match remaining[0..charPerLine - 1].LastIndexOf ' ' with
+ | -1 ->
+ // No whitespace; just break it at [characters]
+ yield remaining[0..charPerLine - 1]
+ remaining <- remaining[charPerLine..]
+ | spaceIdx ->
+ // Break on the last space in the line
+ yield remaining[0..spaceIdx - 1]
+ remaining <- remaining[spaceIdx + 1..]
+ // Leftovers - yum!
+ match remaining.Length with 0 -> () | _ -> yield remaining
}
- |> Seq.fold (fun (acc : StringBuilder) line -> acc.AppendFormat ("{0}\n", line)) (StringBuilder ())
- |> string
+ |> Seq.fold (fun (acc : StringBuilder) -> acc.AppendLine) (StringBuilder ())
+ |> string
/// Modify the text returned by CKEditor into the format we need for request and announcement text
let ckEditorToText (text : string) =
- let trim (str : string) = str.Trim ()
- [ "\n\t", ""
- " ", " "
- " ", " "
- "", "
"
- "
", ""
- "", ""
+ [ "\n\t", ""
+ " ", " "
+ " ", " "
+ "
", "
"
+ "
", ""
+ "", ""
]
- |> List.fold (fun (txt : string) (x, y) -> String.replace x y txt) text
- |> trim
+ |> List.fold (fun (txt : string) (x, y) -> String.replace x y txt) text
+ |> String.trim
+open System.Net
+
/// Convert an HTML piece of text to plain text
let htmlToPlainText html =
- match html with
- | null | "" -> ""
- | _ ->
- html.Trim ()
- |> stripTags [ "br" ]
- |> String.replace "
" "\n"
- |> String.replace "
" "\n"
- |> WebUtility.HtmlDecode
- |> String.replace "\u00a0" " "
+ match html with
+ | null | "" -> ""
+ | _ ->
+ html.Trim ()
+ |> stripTags [ "br" ]
+ |> String.replace "
" "\n"
+ |> String.replace "
" "\n"
+ |> WebUtility.HtmlDecode
+ |> String.replace "\u00a0" " "
/// Get the second portion of a tuple as a string
let sndAsString x = (snd >> string) x
/// Make a URL with query string parameters
-let makeUrl (url : string) (qs : (string * string) list) =
- let queryString =
- qs
- |> List.fold
- (fun (acc : StringBuilder) (key, value) ->
- acc.Append(key).Append("=").Append(WebUtility.UrlEncode value).Append "&")
- (StringBuilder ())
- match queryString.Length with
- | 0 -> url
- | _ -> queryString.Insert(0, "?").Insert(0, url).Remove(queryString.Length - 1, 1).ToString ()
+let makeUrl url qs =
+ if List.isEmpty qs then url
+ else $"""{url}?{String.Join('&', List.map (fun (k, v) -> $"%s{k}={WebUtility.UrlEncode v}") qs)}"""
/// "Magic string" repository
[]
module Key =
- /// This contains constants for session-stored objects within PrayerTracker
- module Session =
- /// The currently logged-on small group
- let currentGroup = "CurrentGroup"
- /// The currently logged-on user
- let currentUser = "CurrentUser"
- /// User messages to be displayed the next time a page is sent
- let userMessages = "UserMessages"
- /// The URL to which the user should be redirected once they have logged in
- let redirectUrl = "RedirectUrl"
+ /// This contains constants for session-stored objects within PrayerTracker
+ module Session =
+
+ /// The currently logged-on small group
+ let currentGroup = "CurrentGroup"
+
+ /// The currently logged-on user
+ let currentUser = "CurrentUser"
+
+ /// User messages to be displayed the next time a page is sent
+ let userMessages = "UserMessages"
+
+ /// The URL to which the user should be redirected once they have logged in
+ let redirectUrl = "RedirectUrl"
- /// Names and value names for use with cookies
- module Cookie =
- /// The name of the user cookie
- let user = "LoggedInUser"
- /// The name of the class cookie
- let group = "LoggedInClass"
- /// The name of the culture cookie
- let culture = "CurrentCulture"
- /// The name of the idle timeout cookie
- let timeout = "TimeoutCookie"
- /// The cookies that should be cleared when a user or group logs off
- let logOffCookies = [ user; group; timeout ]
+ /// Names and value names for use with cookies
+ module Cookie =
+
+ /// The name of the user cookie
+ let user = "LoggedInUser"
+
+ /// The name of the class cookie
+ let group = "LoggedInClass"
+
+ /// The name of the culture cookie
+ let culture = "CurrentCulture"
+
+ /// The name of the idle timeout cookie
+ let timeout = "TimeoutCookie"
+
+ /// The cookies that should be cleared when a user or group logs off
+ let logOffCookies = [ user; group; timeout ]
/// Enumerated values for small group request list visibility (derived from preferences, used in UI)
module RequestVisibility =
- /// Requests are publicly accessible
- []
- let ``public`` = 1
- /// The small group members can enter a password to view the request list
- []
- let passwordProtected = 2
- /// No one can see the requests for a small group except its administrators ("User" access level)
- []
- let ``private`` = 3
+
+ /// Requests are publicly accessible
+ []
+ let ``public`` = 1
+
+ /// The small group members can enter a password to view the request list
+ []
+ let passwordProtected = 2
+
+ /// No one can see the requests for a small group except its administrators ("User" access level)
+ []
+ let ``private`` = 3
/// Links for help locations
module Help =
- /// Help link for small group preference edit page
- let groupPreferences = "small-group/preferences"
- /// Help link for send announcement page
- let sendAnnouncement = "small-group/announcement"
- /// Help link for maintain group members page
- let maintainGroupMembers = "small-group/members"
- /// Help link for request edit page
- let editRequest = "requests/edit"
- /// Help link for maintain requests page
- let maintainRequests = "requests/maintain"
- /// Help link for view request list page
- let viewRequestList = "requests/view"
- /// Help link for user and class login pages
- let logOn = "user/log-on"
- /// Help link for user password change page
- let changePassword = "user/password"
- /// Create a full link for a help page
- let fullLink lang url = $"https://docs.prayer.bitbadger.solutions/%s{lang}/%s{url}.html"
+
+ /// Help link for small group preference edit page
+ let groupPreferences = "small-group/preferences"
+
+ /// Help link for send announcement page
+ let sendAnnouncement = "small-group/announcement"
+
+ /// Help link for maintain group members page
+ let maintainGroupMembers = "small-group/members"
+
+ /// Help link for request edit page
+ let editRequest = "requests/edit"
+
+ /// Help link for maintain requests page
+ let maintainRequests = "requests/maintain"
+
+ /// Help link for view request list page
+ let viewRequestList = "requests/view"
+
+ /// Help link for user and class login pages
+ let logOn = "user/log-on"
+
+ /// Help link for user password change page
+ let changePassword = "user/password"
+
+ /// Create a full link for a help page
+ let fullLink lang url = $"https://docs.prayer.bitbadger.solutions/%s{lang}/%s{url}.html"
+
/// This class serves as a common anchor for resources
type Common () =
- do ()
+ do ()
diff --git a/src/PrayerTracker.UI/ViewModels.fs b/src/PrayerTracker.UI/ViewModels.fs
index 478171e..5ccf329 100644
--- a/src/PrayerTracker.UI/ViewModels.fs
+++ b/src/PrayerTracker.UI/ViewModels.fs
@@ -4,688 +4,803 @@ open Microsoft.AspNetCore.Html
open Microsoft.Extensions.Localization
open PrayerTracker
open PrayerTracker.Entities
-open System
/// Helper module to return localized reference lists
module ReferenceList =
- /// A localized list of the AsOfDateDisplay DU cases
- let asOfDateList (s : IStringLocalizer) =
- [ NoDisplay.code, s.["Do not display the “as of” date"]
- ShortDate.code, s.["Display a short “as of” date"]
- LongDate.code, s.["Display a full “as of” date"]
- ]
+ /// A localized list of the AsOfDateDisplay DU cases
+ let asOfDateList (s : IStringLocalizer) =
+ [ NoDisplay.code, s["Do not display the “as of” date"]
+ ShortDate.code, s["Display a short “as of” date"]
+ LongDate.code, s["Display a full “as of” date"]
+ ]
- /// A list of e-mail type options
- let emailTypeList def (s : IStringLocalizer) =
- // Localize the default type
- let defaultType =
- match def with
- | HtmlFormat -> s.["HTML Format"].Value
- | PlainTextFormat -> s.["Plain-Text Format"].Value
- seq {
- "", LocalizedString ("", $"""{s.["Group Default"].Value} ({defaultType})""")
- HtmlFormat.code, s.["HTML Format"]
- PlainTextFormat.code, s.["Plain-Text Format"]
- }
+ /// A list of e-mail type options
+ let emailTypeList def (s : IStringLocalizer) =
+ // Localize the default type
+ let defaultType =
+ s[match def with HtmlFormat -> "HTML Format" | PlainTextFormat -> "Plain-Text Format"].Value
+ seq {
+ "", LocalizedString ("", $"""{s["Group Default"].Value} ({defaultType})""")
+ HtmlFormat.code, s["HTML Format"]
+ PlainTextFormat.code, s["Plain-Text Format"]
+ }
- /// A list of expiration options
- let expirationList (s : IStringLocalizer) includeExpireNow =
- [ Automatic.code, s.["Expire Normally"]
- Manual.code, s.["Request Never Expires"]
- match includeExpireNow with true -> Forced.code, s.["Expire Immediately"] | false -> ()
- ]
+ /// A list of expiration options
+ let expirationList (s : IStringLocalizer) includeExpireNow =
+ [ Automatic.code, s["Expire Normally"]
+ Manual.code, s["Request Never Expires"]
+ if includeExpireNow then Forced.code, s["Expire Immediately"]
+ ]
- /// A list of request types
- let requestTypeList (s : IStringLocalizer) =
- [ CurrentRequest, s.["Current Requests"]
- LongTermRequest, s.["Long-Term Requests"]
- PraiseReport, s.["Praise Reports"]
- Expecting, s.["Expecting"]
- Announcement, s.["Announcements"]
- ]
+ /// A list of request types
+ let requestTypeList (s : IStringLocalizer) =
+ [ CurrentRequest, s["Current Requests"]
+ LongTermRequest, s["Long-Term Requests"]
+ PraiseReport, s["Praise Reports"]
+ Expecting, s["Expecting"]
+ Announcement, s["Announcements"]
+ ]
// fsharplint:disable RecordFieldNames MemberNames
/// This is used to create a message that is displayed to the user
[]
type UserMessage =
- { /// The type
- level : string
- /// The actual message
- text : HtmlString
- /// The description (further information)
- description : HtmlString option
+ { /// The type
+ level : string
+
+ /// The actual message
+ text : HtmlString
+
+ /// The description (further information)
+ description : HtmlString option
}
-module UserMessage =
- /// Error message template
- let error =
- { level = "ERROR"
- text = HtmlString.Empty
- description = None
- }
- /// Warning message template
- let warning =
- { level = "WARNING"
- text = HtmlString.Empty
- description = None
- }
- /// Info message template
- let info =
- { level = "Info"
- text = HtmlString.Empty
- description = None
- }
+/// Support for the UserMessage type
+module UserMessage =
+
+ /// Error message template
+ let error =
+ { level = "ERROR"
+ text = HtmlString.Empty
+ description = None
+ }
+
+ /// Warning message template
+ let warning =
+ { level = "WARNING"
+ text = HtmlString.Empty
+ description = None
+ }
+
+ /// Info message template
+ let info =
+ { level = "Info"
+ text = HtmlString.Empty
+ description = None
+ }
+
+
+open System
/// View model required by the layout template, given as first parameter for all pages in PrayerTracker
[]
type AppViewInfo =
- { /// CSS files for the page
- style : string list
- /// JavaScript files for the page
- script : string list
- /// The link for help on this page
- helpLink : string option
- /// Messages to be displayed to the user
- messages : UserMessage list
- /// The current version of PrayerTracker
- version : string
- /// The ticks when the request started
- requestStart : int64
- /// The currently logged on user, if there is one
- user : User option
- /// The currently logged on small group, if there is one
- group : SmallGroup option
+ { /// CSS files for the page
+ style : string list
+
+ /// JavaScript files for the page
+ script : string list
+
+ /// The link for help on this page
+ helpLink : string option
+
+ /// Messages to be displayed to the user
+ messages : UserMessage list
+
+ /// The current version of PrayerTracker
+ version : string
+
+ /// The ticks when the request started
+ requestStart : int64
+
+ /// The currently logged on user, if there is one
+ user : User option
+
+ /// The currently logged on small group, if there is one
+ group : SmallGroup option
}
+
+/// Support for the AppViewInfo type
module AppViewInfo =
- /// A fresh version that can be populated to process the current request
- let fresh =
- { style = []
- script = []
- helpLink = None
- messages = []
- version = ""
- requestStart = DateTime.Now.Ticks
- user = None
- group = None
- }
+
+ /// A fresh version that can be populated to process the current request
+ let fresh =
+ { style = []
+ script = []
+ helpLink = None
+ messages = []
+ version = ""
+ requestStart = DateTime.Now.Ticks
+ user = None
+ group = None
+ }
/// Form for sending a small group or system-wide announcement
[]
type Announcement =
- { /// Whether the announcement should be sent to the class or to PrayerTracker users
- sendToClass : string
- /// The text of the announcement
- text : string
- /// Whether this announcement should be added to the "Announcements" of the prayer list
- addToRequestList : bool option
- /// The ID of the request type to which this announcement should be added
- requestType : string option
+ { /// Whether the announcement should be sent to the class or to PrayerTracker users
+ sendToClass : string
+
+ /// The text of the announcement
+ text : string
+
+ /// Whether this announcement should be added to the "Announcements" of the prayer list
+ addToRequestList : bool option
+
+ /// The ID of the request type to which this announcement should be added
+ requestType : string option
}
with
- /// The text of the announcement, in plain text
- member this.plainText () = (htmlToPlainText >> wordWrap 74) this.text
+
+ /// The text of the announcement, in plain text
+ member this.plainText () = (htmlToPlainText >> wordWrap 74) this.text
/// Form for assigning small groups to a user
[]
type AssignGroups =
- { /// The Id of the user being assigned
- userId : UserId
- /// The full name of the user being assigned
- userName : string
- /// The Ids of the small groups to which the user is authorized
- smallGroups : string
+ { /// The Id of the user being assigned
+ userId : UserId
+
+ /// The full name of the user being assigned
+ userName : string
+
+ /// The Ids of the small groups to which the user is authorized
+ smallGroups : string
}
+
+/// Support for the AssignGroups type
module AssignGroups =
- /// Create an instance of this form from an existing user
- let fromUser (u : User) =
- { userId = u.userId
- userName = u.fullName
- smallGroups = ""
- }
+
+ /// Create an instance of this form from an existing user
+ let fromUser (u : User) =
+ { userId = u.userId
+ userName = u.fullName
+ smallGroups = ""
+ }
/// Form to allow users to change their password
[]
type ChangePassword =
- { /// The user's current password
- oldPassword : string
- /// The user's new password
- newPassword : string
- /// The user's new password, confirmed
- newPasswordConfirm : string
+ { /// The user's current password
+ oldPassword : string
+ /// The user's new password
+ newPassword : string
+ /// The user's new password, confirmed
+ newPasswordConfirm : string
}
/// Form for adding or editing a church
[]
type EditChurch =
- { /// The Id of the church
- churchId : ChurchId
- /// The name of the church
- name : string
- /// The city for the church
- city : string
- /// The state for the church
- st : string
- /// Whether the church has an active VPR interface
- hasInterface : bool option
- /// The address for the interface
- interfaceAddress : string option
+ { /// The Id of the church
+ churchId : ChurchId
+
+ /// The name of the church
+ name : string
+
+ /// The city for the church
+ city : string
+
+ /// The state for the church
+ st : string
+
+ /// Whether the church has an active VPR interface
+ hasInterface : bool option
+
+ /// The address for the interface
+ interfaceAddress : string option
}
with
- /// Is this a new church?
- member this.isNew () = Guid.Empty = this.churchId
- /// Populate a church from this form
- member this.populateChurch (church : Church) =
- { church with
- name = this.name
- city = this.city
- st = this.st
- hasInterface = match this.hasInterface with Some x -> x | None -> false
- interfaceAddress = match this.hasInterface with Some x when x -> this.interfaceAddress | _ -> None
- }
+
+ /// Is this a new church?
+ member this.isNew () = Guid.Empty = this.churchId
+
+ /// Populate a church from this form
+ member this.populateChurch (church : Church) =
+ { church with
+ name = this.name
+ city = this.city
+ st = this.st
+ hasInterface = match this.hasInterface with Some x -> x | None -> false
+ interfaceAddress = match this.hasInterface with Some x when x -> this.interfaceAddress | _ -> None
+ }
+
+/// Support for the EditChurch type
module EditChurch =
- /// Create an instance from an existing church
- let fromChurch (ch : Church) =
- { churchId = ch.churchId
- name = ch.name
- city = ch.city
- st = ch.st
- hasInterface = match ch.hasInterface with true -> Some true | false -> None
- interfaceAddress = ch.interfaceAddress
- }
- /// An instance to use for adding churches
- let empty =
- { churchId = Guid.Empty
- name = ""
- city = ""
- st = ""
- hasInterface = None
- interfaceAddress = None
- }
+
+ /// Create an instance from an existing church
+ let fromChurch (ch : Church) =
+ { churchId = ch.churchId
+ name = ch.name
+ city = ch.city
+ st = ch.st
+ hasInterface = match ch.hasInterface with true -> Some true | false -> None
+ interfaceAddress = ch.interfaceAddress
+ }
+
+ /// An instance to use for adding churches
+ let empty =
+ { churchId = Guid.Empty
+ name = ""
+ city = ""
+ st = ""
+ hasInterface = None
+ interfaceAddress = None
+ }
/// Form for adding/editing small group members
[]
type EditMember =
- { /// The Id for this small group member (not user-entered)
- memberId : MemberId
- /// The name of the member
- memberName : string
- /// The e-mail address
- emailAddress : string
- /// The e-mail format
- emailType : string
+ { /// The Id for this small group member (not user-entered)
+ memberId : MemberId
+
+ /// The name of the member
+ memberName : string
+
+ /// The e-mail address
+ emailAddress : string
+
+ /// The e-mail format
+ emailType : string
}
with
- /// Is this a new member?
- member this.isNew () = Guid.Empty = this.memberId
+
+ /// Is this a new member?
+ member this.isNew () = Guid.Empty = this.memberId
+
+/// Support for the EditMember type
module EditMember =
- /// Create an instance from an existing member
- let fromMember (m : Member) =
- { memberId = m.memberId
- memberName = m.memberName
- emailAddress = m.email
- emailType = match m.format with Some f -> f | None -> ""
- }
- /// An empty instance
- let empty =
- { memberId = Guid.Empty
- memberName = ""
- emailAddress = ""
- emailType = ""
- }
+
+ /// Create an instance from an existing member
+ let fromMember (m : Member) =
+ { memberId = m.memberId
+ memberName = m.memberName
+ emailAddress = m.email
+ emailType = match m.format with Some f -> f | None -> ""
+ }
+
+ /// An empty instance
+ let empty =
+ { memberId = Guid.Empty
+ memberName = ""
+ emailAddress = ""
+ emailType = ""
+ }
/// This form allows the user to set class preferences
[]
type EditPreferences =
- { /// The number of days after which requests are automatically expired
- expireDays : int
- /// The number of days requests are considered "new"
- daysToKeepNew : int
- /// The number of weeks after which a long-term requests is flagged as requiring an update
- longTermUpdateWeeks : int
- /// Whether to sort by updated date or requestor/subject
- requestSort : string
- /// The name from which e-mail will be sent
- emailFromName : string
- /// The e-mail address from which e-mail will be sent
- emailFromAddress : string
- /// The default e-mail type for this group
- defaultEmailType : string
- /// Whether the heading line color uses named colors or R/G/B
- headingLineType : string
- /// The named color for the heading lines
- headingLineColor : string
- /// Whether the heading text color uses named colors or R/G/B
- headingTextType : string
- /// The named color for the heading text
- headingTextColor : string
- /// The fonts to use for the list
- listFonts : string
- /// The font size for the heading text
- headingFontSize : int
- /// The font size for the list text
- listFontSize : int
- /// The time zone for the class
- timeZone : string
- /// The list visibility
- listVisibility : int
- /// The small group password
- groupPassword : string option
- /// The page size for search / inactive requests
- pageSize : int
- /// How the as-of date should be displayed
- asOfDate : string
+ { /// The number of days after which requests are automatically expired
+ expireDays : int
+
+ /// The number of days requests are considered "new"
+ daysToKeepNew : int
+
+ /// The number of weeks after which a long-term requests is flagged as requiring an update
+ longTermUpdateWeeks : int
+
+ /// Whether to sort by updated date or requestor/subject
+ requestSort : string
+
+ /// The name from which e-mail will be sent
+ emailFromName : string
+
+ /// The e-mail address from which e-mail will be sent
+ emailFromAddress : string
+
+ /// The default e-mail type for this group
+ defaultEmailType : string
+
+ /// Whether the heading line color uses named colors or R/G/B
+ headingLineType : string
+
+ /// The named color for the heading lines
+ headingLineColor : string
+
+ /// Whether the heading text color uses named colors or R/G/B
+ headingTextType : string
+
+ /// The named color for the heading text
+ headingTextColor : string
+
+ /// The fonts to use for the list
+ listFonts : string
+
+ /// The font size for the heading text
+ headingFontSize : int
+
+ /// The font size for the list text
+ listFontSize : int
+
+ /// The time zone for the class
+ timeZone : string
+
+ /// The list visibility
+ listVisibility : int
+
+ /// The small group password
+ groupPassword : string option
+
+ /// The page size for search / inactive requests
+ pageSize : int
+
+ /// How the as-of date should be displayed
+ asOfDate : string
}
with
- /// Set the properties of a small group based on the form's properties
- member this.populatePreferences (prefs : ListPreferences) =
- let isPublic, grpPw =
- match this.listVisibility with
- | RequestVisibility.``public`` -> true, ""
- | RequestVisibility.passwordProtected -> false, (defaultArg this.groupPassword "")
- | RequestVisibility.``private``
- | _ -> false, ""
- { prefs with
- daysToExpire = this.expireDays
- daysToKeepNew = this.daysToKeepNew
- longTermUpdateWeeks = this.longTermUpdateWeeks
- requestSort = RequestSort.fromCode this.requestSort
- emailFromName = this.emailFromName
- emailFromAddress = this.emailFromAddress
- defaultEmailType = EmailFormat.fromCode this.defaultEmailType
- lineColor = this.headingLineColor
- headingColor = this.headingTextColor
- listFonts = this.listFonts
- headingFontSize = this.headingFontSize
- textFontSize = this.listFontSize
- timeZoneId = this.timeZone
- isPublic = isPublic
- groupPassword = grpPw
- pageSize = this.pageSize
- asOfDateDisplay = AsOfDateDisplay.fromCode this.asOfDate
- }
+
+ /// Set the properties of a small group based on the form's properties
+ member this.populatePreferences (prefs : ListPreferences) =
+ let isPublic, grpPw =
+ match this.listVisibility with
+ | RequestVisibility.``public`` -> true, ""
+ | RequestVisibility.passwordProtected -> false, (defaultArg this.groupPassword "")
+ | RequestVisibility.``private``
+ | _ -> false, ""
+ { prefs with
+ daysToExpire = this.expireDays
+ daysToKeepNew = this.daysToKeepNew
+ longTermUpdateWeeks = this.longTermUpdateWeeks
+ requestSort = RequestSort.fromCode this.requestSort
+ emailFromName = this.emailFromName
+ emailFromAddress = this.emailFromAddress
+ defaultEmailType = EmailFormat.fromCode this.defaultEmailType
+ lineColor = this.headingLineColor
+ headingColor = this.headingTextColor
+ listFonts = this.listFonts
+ headingFontSize = this.headingFontSize
+ textFontSize = this.listFontSize
+ timeZoneId = this.timeZone
+ isPublic = isPublic
+ groupPassword = grpPw
+ pageSize = this.pageSize
+ asOfDateDisplay = AsOfDateDisplay.fromCode this.asOfDate
+ }
+
+/// Support for the EditPreferences type
module EditPreferences =
- /// Populate an edit form from existing preferences
- let fromPreferences (prefs : ListPreferences) =
- let setType (x : string) = match x.StartsWith "#" with true -> "RGB" | false -> "Name"
- { expireDays = prefs.daysToExpire
- daysToKeepNew = prefs.daysToKeepNew
- longTermUpdateWeeks = prefs.longTermUpdateWeeks
- requestSort = prefs.requestSort.code
- emailFromName = prefs.emailFromName
- emailFromAddress = prefs.emailFromAddress
- defaultEmailType = prefs.defaultEmailType.code
- headingLineType = setType prefs.lineColor
- headingLineColor = prefs.lineColor
- headingTextType = setType prefs.headingColor
- headingTextColor = prefs.headingColor
- listFonts = prefs.listFonts
- headingFontSize = prefs.headingFontSize
- listFontSize = prefs.textFontSize
- timeZone = prefs.timeZoneId
- groupPassword = Some prefs.groupPassword
- pageSize = prefs.pageSize
- asOfDate = prefs.asOfDateDisplay.code
- listVisibility =
- match true with
- | _ when prefs.isPublic -> RequestVisibility.``public``
- | _ when prefs.groupPassword = "" -> RequestVisibility.``private``
- | _ -> RequestVisibility.passwordProtected
- }
+ /// Populate an edit form from existing preferences
+ let fromPreferences (prefs : ListPreferences) =
+ let setType (x : string) = match x.StartsWith "#" with true -> "RGB" | false -> "Name"
+ { expireDays = prefs.daysToExpire
+ daysToKeepNew = prefs.daysToKeepNew
+ longTermUpdateWeeks = prefs.longTermUpdateWeeks
+ requestSort = prefs.requestSort.code
+ emailFromName = prefs.emailFromName
+ emailFromAddress = prefs.emailFromAddress
+ defaultEmailType = prefs.defaultEmailType.code
+ headingLineType = setType prefs.lineColor
+ headingLineColor = prefs.lineColor
+ headingTextType = setType prefs.headingColor
+ headingTextColor = prefs.headingColor
+ listFonts = prefs.listFonts
+ headingFontSize = prefs.headingFontSize
+ listFontSize = prefs.textFontSize
+ timeZone = prefs.timeZoneId
+ groupPassword = Some prefs.groupPassword
+ pageSize = prefs.pageSize
+ asOfDate = prefs.asOfDateDisplay.code
+ listVisibility =
+ match true with
+ | _ when prefs.isPublic -> RequestVisibility.``public``
+ | _ when prefs.groupPassword = "" -> RequestVisibility.``private``
+ | _ -> RequestVisibility.passwordProtected
+ }
/// Form for adding or editing prayer requests
[]
type EditRequest =
- { /// The Id of the request
- requestId : PrayerRequestId
- /// The type of the request
- requestType : string
- /// The date of the request
- //[]
- enteredDate : DateTime option
- /// Whether to update the date or not
- skipDateUpdate : bool option
- /// The requestor or subject
- requestor : string option
- /// How this request is expired
- expiration : string
- /// The text of the request
- text : string
+ { /// The Id of the request
+ requestId : PrayerRequestId
+
+ /// The type of the request
+ requestType : string
+
+ /// The date of the request
+ enteredDate : DateTime option
+
+ /// Whether to update the date or not
+ skipDateUpdate : bool option
+
+ /// The requestor or subject
+ requestor : string option
+
+ /// How this request is expired
+ expiration : string
+
+ /// The text of the request
+ text : string
}
with
- /// Is this a new request?
- member this.isNew () = Guid.Empty = this.requestId
+
+ /// Is this a new request?
+ member this.isNew () = Guid.Empty = this.requestId
+
+/// Support for the EditRequest type
module EditRequest =
- /// An empty instance to use for new requests
- let empty =
- { requestId = Guid.Empty
- requestType = CurrentRequest.code
- enteredDate = None
- skipDateUpdate = None
- requestor = None
- expiration = Automatic.code
- text = ""
- }
- /// Create an instance from an existing request
- let fromRequest req =
- { empty with
- requestId = req.prayerRequestId
- requestType = req.requestType.code
- requestor = req.requestor
- expiration = req.expiration.code
- text = req.text
- }
+
+ /// An empty instance to use for new requests
+ let empty =
+ { requestId = Guid.Empty
+ requestType = CurrentRequest.code
+ enteredDate = None
+ skipDateUpdate = None
+ requestor = None
+ expiration = Automatic.code
+ text = ""
+ }
+
+ /// Create an instance from an existing request
+ let fromRequest req =
+ { empty with
+ requestId = req.prayerRequestId
+ requestType = req.requestType.code
+ requestor = req.requestor
+ expiration = req.expiration.code
+ text = req.text
+ }
/// Form for the admin-level editing of small groups
[]
type EditSmallGroup =
- { /// The Id of the small group
- smallGroupId : SmallGroupId
- /// The name of the small group
- name : string
- /// The Id of the church to which this small group belongs
- churchId : ChurchId
+ { /// The Id of the small group
+ smallGroupId : SmallGroupId
+
+ /// The name of the small group
+ name : string
+
+ /// The Id of the church to which this small group belongs
+ churchId : ChurchId
}
with
- /// Is this a new small group?
- member this.isNew () = Guid.Empty = this.smallGroupId
- /// Populate a small group from this form
- member this.populateGroup (grp : SmallGroup) =
- { grp with
- name = this.name
- churchId = this.churchId
- }
+
+ /// Is this a new small group?
+ member this.isNew () = Guid.Empty = this.smallGroupId
+
+ /// Populate a small group from this form
+ member this.populateGroup (grp : SmallGroup) =
+ { grp with
+ name = this.name
+ churchId = this.churchId
+ }
+
+/// Support for the EditSmallGroup type
module EditSmallGroup =
- /// Create an instance from an existing small group
- let fromGroup (g : SmallGroup) =
- { smallGroupId = g.smallGroupId
- name = g.name
- churchId = g.churchId
- }
- /// An empty instance (used when adding a new group)
- let empty =
- { smallGroupId = Guid.Empty
- name = ""
- churchId = Guid.Empty
- }
+
+ /// Create an instance from an existing small group
+ let fromGroup (g : SmallGroup) =
+ { smallGroupId = g.smallGroupId
+ name = g.name
+ churchId = g.churchId
+ }
+
+ /// An empty instance (used when adding a new group)
+ let empty =
+ { smallGroupId = Guid.Empty
+ name = ""
+ churchId = Guid.Empty
+ }
/// Form for the user edit page
[]
type EditUser =
- { /// The Id of the user
- userId : UserId
- /// The first name of the user
- firstName : string
- /// The last name of the user
- lastName : string
- /// The e-mail address for the user
- emailAddress : string
- /// The password for the user
- password : string
- /// The password hash for the user a second time
- passwordConfirm : string
- /// Is this user a PrayerTracker administrator?
- isAdmin : bool option
+ { /// The Id of the user
+ userId : UserId
+
+ /// The first name of the user
+ firstName : string
+
+ /// The last name of the user
+ lastName : string
+
+ /// The e-mail address for the user
+ emailAddress : string
+
+ /// The password for the user
+ password : string
+
+ /// The password hash for the user a second time
+ passwordConfirm : string
+
+ /// Is this user a PrayerTracker administrator?
+ isAdmin : bool option
}
with
- /// Is this a new user?
- member this.isNew () = Guid.Empty = this.userId
- /// Populate a user from the form
- member this.populateUser (user : User) hasher =
- { user with
- firstName = this.firstName
- lastName = this.lastName
- emailAddress = this.emailAddress
- isAdmin = match this.isAdmin with Some x -> x | None -> false
- }
- |> function
- | u when isNull this.password || this.password = "" -> u
- | u -> { u with passwordHash = hasher this.password }
+
+ /// Is this a new user?
+ member this.isNew () = Guid.Empty = this.userId
+
+ /// Populate a user from the form
+ member this.populateUser (user : User) hasher =
+ { user with
+ firstName = this.firstName
+ lastName = this.lastName
+ emailAddress = this.emailAddress
+ isAdmin = match this.isAdmin with Some x -> x | None -> false
+ }
+ |> function
+ | u when isNull this.password || this.password = "" -> u
+ | u -> { u with passwordHash = hasher this.password }
+
+/// Support for the EditUser type
module EditUser =
- /// An empty instance
- let empty =
- { userId = Guid.Empty
- firstName = ""
- lastName = ""
- emailAddress = ""
- password = ""
- passwordConfirm = ""
- isAdmin = None
- }
- /// Create an instance from an existing user
- let fromUser (user : User) =
- { empty with
- userId = user.userId
- firstName = user.firstName
- lastName = user.lastName
- emailAddress = user.emailAddress
- isAdmin = match user.isAdmin with true -> Some true | false -> None
- }
+
+ /// An empty instance
+ let empty =
+ { userId = Guid.Empty
+ firstName = ""
+ lastName = ""
+ emailAddress = ""
+ password = ""
+ passwordConfirm = ""
+ isAdmin = None
+ }
+
+ /// Create an instance from an existing user
+ let fromUser (user : User) =
+ { empty with
+ userId = user.userId
+ firstName = user.firstName
+ lastName = user.lastName
+ emailAddress = user.emailAddress
+ isAdmin = match user.isAdmin with true -> Some true | false -> None
+ }
/// Form for the small group log on page
[]
type GroupLogOn =
- { /// The ID of the small group to which the user is logging on
- smallGroupId : SmallGroupId
- /// The password entered
- password : string
- /// Whether to remember the login
- rememberMe : bool option
+ { /// The ID of the small group to which the user is logging on
+ smallGroupId : SmallGroupId
+
+ /// The password entered
+ password : string
+
+ /// Whether to remember the login
+ rememberMe : bool option
}
+
+/// Support for the GroupLogOn type
module GroupLogOn =
- /// An empty instance
- let empty =
- { smallGroupId = Guid.Empty
- password = ""
- rememberMe = None
- }
+
+ /// An empty instance
+ let empty =
+ { smallGroupId = Guid.Empty
+ password = ""
+ rememberMe = None
+ }
/// Items needed to display the request maintenance page
[]
type MaintainRequests =
- { /// The requests to be displayed
- requests : PrayerRequest seq
- /// The small group to which the requests belong
- smallGroup : SmallGroup
- /// Whether only active requests are included
- onlyActive : bool option
- /// The search term for the requests
- searchTerm : string option
- /// The page number of the results
- pageNbr : int option
+ { /// The requests to be displayed
+ requests : PrayerRequest seq
+
+ /// The small group to which the requests belong
+ smallGroup : SmallGroup
+
+ /// Whether only active requests are included
+ onlyActive : bool option
+
+ /// The search term for the requests
+ searchTerm : string option
+
+ /// The page number of the results
+ pageNbr : int option
}
+
+/// Support for the MaintainRequests type
module MaintainRequests =
- /// An empty instance
- let empty =
- { requests = Seq.empty
- smallGroup = SmallGroup.empty
- onlyActive = None
- searchTerm = None
- pageNbr = None
- }
+
+ /// An empty instance
+ let empty =
+ { requests = Seq.empty
+ smallGroup = SmallGroup.empty
+ onlyActive = None
+ searchTerm = None
+ pageNbr = None
+ }
/// Items needed to display the small group overview page
[]
type Overview =
- { /// The total number of active requests
- totalActiveReqs : int
- /// The numbers of active requests by category
- activeReqsByCat : Map
- /// A count of all requests
- allReqs : int
- /// A count of all members
- totalMbrs : int
+ { /// The total number of active requests
+ totalActiveReqs : int
+
+ /// The numbers of active requests by category
+ activeReqsByCat : Map
+
+ /// A count of all requests
+ allReqs : int
+
+ /// A count of all members
+ totalMbrs : int
}
/// Form for the user log on page
[]
type UserLogOn =
- { /// The e-mail address of the user
- emailAddress : string
- /// The password entered
- password : string
- /// The ID of the small group to which the user is logging on
- smallGroupId : SmallGroupId
- /// Whether to remember the login
- rememberMe : bool option
- /// The URL to which the user should be redirected once login is successful
- redirectUrl : string option
+ { /// The e-mail address of the user
+ emailAddress : string
+
+ /// The password entered
+ password : string
+
+ /// The ID of the small group to which the user is logging on
+ smallGroupId : SmallGroupId
+
+ /// Whether to remember the login
+ rememberMe : bool option
+
+ /// The URL to which the user should be redirected once login is successful
+ redirectUrl : string option
}
+
+/// Support for the UserLogOn type
module UserLogOn =
- /// An empty instance
- let empty =
- { emailAddress = ""
- password = ""
- smallGroupId = Guid.Empty
- rememberMe = None
- redirectUrl = None
- }
+
+ /// An empty instance
+ let empty =
+ { emailAddress = ""
+ password = ""
+ smallGroupId = Guid.Empty
+ rememberMe = None
+ redirectUrl = None
+ }
open Giraffe.ViewEngine
/// This represents a list of requests
type RequestList =
- { /// The prayer request list
- requests : PrayerRequest list
- /// The date for which this list is being generated
- date : DateTime
- /// The small group to which this list belongs
- listGroup : SmallGroup
- /// Whether to show the class header
- showHeader : bool
- /// The list of recipients (populated if requests are e-mailed)
- recipients : Member list
- /// Whether the user can e-mail this list
- canEmail : bool
+ { /// The prayer request list
+ requests : PrayerRequest list
+
+ /// The date for which this list is being generated
+ date : DateTime
+
+ /// The small group to which this list belongs
+ listGroup : SmallGroup
+
+ /// Whether to show the class header
+ showHeader : bool
+
+ /// The list of recipients (populated if requests are e-mailed)
+ recipients : Member list
+
+ /// Whether the user can e-mail this list
+ canEmail : bool
}
with
- /// Get the requests for a specified type
- member this.requestsInCategory cat =
- let reqs =
- this.requests
- |> Seq.ofList
- |> Seq.filter (fun req -> req.requestType = cat)
- match this.listGroup.preferences.requestSort with
- | SortByDate -> reqs |> Seq.sortByDescending (fun req -> req.updatedDate)
- | SortByRequestor -> reqs |> Seq.sortBy (fun req -> req.requestor)
- |> List.ofSeq
- /// Is this request new?
- member this.isNew (req : PrayerRequest) =
- (this.date - req.updatedDate).Days <= this.listGroup.preferences.daysToKeepNew
- /// Generate this list as HTML
- member this.asHtml (s : IStringLocalizer) =
- let prefs = this.listGroup.preferences
- let asOfSize = Math.Round (float prefs.textFontSize * 0.8, 2)
- [ match this.showHeader with
- | true ->
- div [ _style $"text-align:center;font-family:{prefs.listFonts}" ] [
- span [ _style $"font-size:%i{prefs.headingFontSize}pt;" ] [
- strong [] [ str s.["Prayer Requests"].Value ]
- ]
- br []
- span [ _style $"font-size:%i{prefs.textFontSize}pt;" ] [
- strong [] [ str this.listGroup.name ]
- br []
- str (this.date.ToString s.["MMMM d, yyyy"].Value)
- ]
- ]
- br []
- | false -> ()
- let typs = ReferenceList.requestTypeList s
- for cat in
- typs
- |> Seq.ofList
- |> Seq.map fst
- |> Seq.filter (fun c -> 0 < (this.requests |> List.filter (fun req -> req.requestType = c) |> List.length)) do
- let reqs = this.requestsInCategory cat
- let catName = typs |> List.filter (fun t -> fst t = cat) |> List.head |> snd
- div [ _style "padding-left:10px;padding-bottom:.5em;" ] [
- table [ _style $"font-family:{prefs.listFonts};page-break-inside:avoid;" ] [
- tr [] [
- td [ _style $"font-size:%i{prefs.headingFontSize}pt;color:{prefs.headingColor};padding:3px 0;border-top:solid 3px {prefs.lineColor};border-bottom:solid 3px {prefs.lineColor};font-weight:bold;" ] [
- rawText " "; str catName.Value; rawText " "
- ]
- ]
- ]
- ]
- reqs
- |> List.map (fun req ->
- let bullet = match this.isNew req with true -> "circle" | false -> "disc"
- li [ _style $"list-style-type:{bullet};font-family:{prefs.listFonts};font-size:%i{prefs.textFontSize}pt;padding-bottom:.25em;" ] [
- match req.requestor with
- | Some rqstr when rqstr <> "" ->
- strong [] [ str rqstr ]
- rawText " — "
- | Some _ -> ()
- | None -> ()
- rawText req.text
- match prefs.asOfDateDisplay with
- | NoDisplay -> ()
- | ShortDate
- | LongDate ->
- let dt =
- match prefs.asOfDateDisplay with
- | ShortDate -> req.updatedDate.ToShortDateString ()
- | LongDate -> req.updatedDate.ToLongDateString ()
- | _ -> ""
- i [ _style $"font-size:%.2f{asOfSize}pt" ] [
- rawText " ("; str s.["as of"].Value; str " "; str dt; rawText ")"
- ]
- ])
- |> ul []
- br []
- ]
- |> RenderView.AsString.htmlNodes
- /// Generate this list as plain text
- member this.asText (s : IStringLocalizer) =
- seq {
- this.listGroup.name
- s.["Prayer Requests"].Value
- this.date.ToString s.["MMMM d, yyyy"].Value
- " "
- let typs = ReferenceList.requestTypeList s
- for cat in
- typs
- |> Seq.ofList
- |> Seq.map fst
- |> Seq.filter (fun c -> 0 < (this.requests |> List.filter (fun req -> req.requestType = c) |> List.length)) do
- let reqs = this.requestsInCategory cat
- let typ = (typs |> List.filter (fun t -> fst t = cat) |> List.head |> snd).Value
- let dashes = String.replicate (typ.Length + 4) "-"
- dashes
- $" {typ.ToUpper ()}"
- dashes
- for req in reqs do
- let bullet = match this.isNew req with true -> "+" | false -> "-"
- let requestor = match req.requestor with Some r -> sprintf "%s - " r | None -> ""
- match this.listGroup.preferences.asOfDateDisplay with
- | NoDisplay -> ""
- | _ ->
- let dt =
- match this.listGroup.preferences.asOfDateDisplay with
- | ShortDate -> req.updatedDate.ToShortDateString ()
- | LongDate -> req.updatedDate.ToLongDateString ()
- | _ -> ""
- $""" ({s.["as of"].Value} {dt})"""
- |> sprintf " %s %s%s%s" bullet requestor (htmlToPlainText req.text)
- " "
- }
- |> String.concat "\n"
- |> wordWrap 74
+ /// Group requests by their type, along with the type and its localized string
+ member private this.requestsByType (s : IStringLocalizer) =
+ ReferenceList.requestTypeList s
+ |> List.map (fun (typ, name) -> typ, name, this.requests |> List.filter (fun req -> req.requestType = typ))
+ |> List.filter (fun (_, _, reqs) -> not (List.isEmpty reqs))
+
+ /// Get the requests for a specified type
+ member this.requestsInCategory cat =
+ let reqs =
+ this.requests
+ |> Seq.ofList
+ |> Seq.filter (fun req -> req.requestType = cat)
+ match this.listGroup.preferences.requestSort with
+ | SortByDate -> reqs |> Seq.sortByDescending (fun req -> req.updatedDate)
+ | SortByRequestor -> reqs |> Seq.sortBy (fun req -> req.requestor)
+ |> List.ofSeq
+
+ /// Is this request new?
+ member this.isNew (req : PrayerRequest) =
+ (this.date - req.updatedDate).Days <= this.listGroup.preferences.daysToKeepNew
+
+ /// Generate this list as HTML
+ member this.asHtml (s : IStringLocalizer) =
+ let prefs = this.listGroup.preferences
+ let asOfSize = Math.Round (float prefs.textFontSize * 0.8, 2)
+ [ if this.showHeader then
+ div [ _style $"text-align:center;font-family:{prefs.listFonts}" ] [
+ span [ _style $"font-size:%i{prefs.headingFontSize}pt;" ] [
+ strong [] [ str s["Prayer Requests"].Value ]
+ ]
+ br []
+ span [ _style $"font-size:%i{prefs.textFontSize}pt;" ] [
+ strong [] [ str this.listGroup.name ]
+ br []
+ str (this.date.ToString s["MMMM d, yyyy"].Value)
+ ]
+ ]
+ br []
+ for _, name, reqs in this.requestsByType s do
+ div [ _style "padding-left:10px;padding-bottom:.5em;" ] [
+ table [ _style $"font-family:{prefs.listFonts};page-break-inside:avoid;" ] [
+ tr [] [
+ td [ _style $"font-size:%i{prefs.headingFontSize}pt;color:{prefs.headingColor};padding:3px 0;border-top:solid 3px {prefs.lineColor};border-bottom:solid 3px {prefs.lineColor};font-weight:bold;" ] [
+ rawText " "; str name.Value; rawText " "
+ ]
+ ]
+ ]
+ ]
+ reqs
+ |> List.map (fun req ->
+ let bullet = if this.isNew req then "circle" else "disc"
+ li [ _style $"list-style-type:{bullet};font-family:{prefs.listFonts};font-size:%i{prefs.textFontSize}pt;padding-bottom:.25em;" ] [
+ match req.requestor with
+ | Some r when r <> "" ->
+ strong [] [ str r ]
+ rawText " — "
+ | Some _ -> ()
+ | None -> ()
+ rawText req.text
+ match prefs.asOfDateDisplay with
+ | NoDisplay -> ()
+ | ShortDate
+ | LongDate ->
+ let dt =
+ match prefs.asOfDateDisplay with
+ | ShortDate -> req.updatedDate.ToShortDateString ()
+ | LongDate -> req.updatedDate.ToLongDateString ()
+ | _ -> ""
+ i [ _style $"font-size:%.2f{asOfSize}pt" ] [
+ rawText " ("; str s["as of"].Value; str " "; str dt; rawText ")"
+ ]
+ ])
+ |> ul []
+ br []
+ ]
+ |> RenderView.AsString.htmlNodes
+
+ /// Generate this list as plain text
+ member this.asText (s : IStringLocalizer) =
+ seq {
+ this.listGroup.name
+ s["Prayer Requests"].Value
+ this.date.ToString s["MMMM d, yyyy"].Value
+ " "
+ for _, name, reqs in this.requestsByType s do
+ let dashes = String.replicate (name.Value.Length + 4) "-"
+ dashes
+ $" {name.Value.ToUpper ()}"
+ dashes
+ for req in reqs do
+ let bullet = if this.isNew req then "+" else "-"
+ let requestor = match req.requestor with Some r -> $"{r} - " | None -> ""
+ match this.listGroup.preferences.asOfDateDisplay with
+ | NoDisplay -> ""
+ | _ ->
+ let dt =
+ match this.listGroup.preferences.asOfDateDisplay with
+ | ShortDate -> req.updatedDate.ToShortDateString ()
+ | LongDate -> req.updatedDate.ToLongDateString ()
+ | _ -> ""
+ $""" ({s["as of"].Value} {dt})"""
+ |> sprintf " %s %s%s%s" bullet requestor (htmlToPlainText req.text)
+ " "
+ }
+ |> String.concat "\n"
+ |> wordWrap 74
diff --git a/src/PrayerTracker/App.fs b/src/PrayerTracker/App.fs
index 3ce04d6..899a6f4 100644
--- a/src/PrayerTracker/App.fs
+++ b/src/PrayerTracker/App.fs
@@ -7,195 +7,196 @@ open Microsoft.AspNetCore.Hosting
[]
module Configure =
- open Cookies
- open Giraffe
- open Giraffe.EndpointRouting
- open Microsoft.AspNetCore.Localization
- open Microsoft.AspNetCore.Server.Kestrel.Core
- open Microsoft.EntityFrameworkCore
- open Microsoft.Extensions.Configuration
- open Microsoft.Extensions.DependencyInjection
- open Microsoft.Extensions.Hosting
- open Microsoft.Extensions.Localization
- open Microsoft.Extensions.Logging
- open Microsoft.Extensions.Options
- open NodaTime
- open System.Globalization
+ open Cookies
+ open Giraffe
+ open Giraffe.EndpointRouting
+ open Microsoft.AspNetCore.Localization
+ open Microsoft.AspNetCore.Server.Kestrel.Core
+ open Microsoft.EntityFrameworkCore
+ open Microsoft.Extensions.Configuration
+ open Microsoft.Extensions.DependencyInjection
+ open Microsoft.Extensions.Hosting
+ open Microsoft.Extensions.Localization
+ open Microsoft.Extensions.Logging
+ open Microsoft.Extensions.Options
+ open NodaTime
+ open System.Globalization
- /// Set up the configuration for the app
- let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) =
- cfg.SetBasePath(ctx.HostingEnvironment.ContentRootPath)
- .AddJsonFile("appsettings.json", optional = true, reloadOnChange = true)
- .AddJsonFile($"appsettings.{ctx.HostingEnvironment.EnvironmentName}.json", optional = true)
- .AddEnvironmentVariables()
- |> ignore
+ /// Set up the configuration for the app
+ let configuration (ctx : WebHostBuilderContext) (cfg : IConfigurationBuilder) =
+ cfg.SetBasePath(ctx.HostingEnvironment.ContentRootPath)
+ .AddJsonFile("appsettings.json", optional = true, reloadOnChange = true)
+ .AddJsonFile($"appsettings.{ctx.HostingEnvironment.EnvironmentName}.json", optional = true)
+ .AddEnvironmentVariables()
+ |> ignore
- /// Configure Kestrel from appsettings.json
- let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
- (ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
+ /// Configure Kestrel from appsettings.json
+ let kestrel (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
+ (ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
- let services (svc : IServiceCollection) =
- svc.AddOptions()
- .AddLocalization(fun options -> options.ResourcesPath <- "Resources")
- .Configure(
- fun (opts : RequestLocalizationOptions) ->
- let supportedCultures =
- [| CultureInfo "en-US"; CultureInfo "en-GB"; CultureInfo "en-AU"; CultureInfo "en"
- CultureInfo "es-MX"; CultureInfo "es-ES"; CultureInfo "es"
- |]
- opts.DefaultRequestCulture <- RequestCulture ("en-US", "en-US")
- opts.SupportedCultures <- supportedCultures
- opts.SupportedUICultures <- supportedCultures)
- .AddDistributedMemoryCache()
- .AddSession()
- .AddAntiforgery()
- .AddRouting()
- .AddSingleton(SystemClock.Instance)
- |> ignore
- let config = svc.BuildServiceProvider().GetRequiredService()
- let crypto = config.GetSection "CookieCrypto"
- CookieCrypto (crypto.["Key"], crypto.["IV"]) |> setCrypto
- svc.AddDbContext(
- (fun options ->
- options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
- ServiceLifetime.Scoped, ServiceLifetime.Singleton)
- |> ignore
-
- /// Routes for PrayerTracker
- let routes =
- [ subRoute "/web" [
- GET_HEAD [
- subRoute "/church" [
- route "es" Handlers.Church.maintain
- routef "/%O/edit" Handlers.Church.edit
+ let services (svc : IServiceCollection) =
+ let _ = svc.AddOptions()
+ let _ = svc.AddLocalization(fun options -> options.ResourcesPath <- "Resources")
+ let _ =
+ svc.Configure(fun (opts : RequestLocalizationOptions) ->
+ let supportedCultures =[|
+ CultureInfo "en-US"; CultureInfo "en-GB"; CultureInfo "en-AU"; CultureInfo "en"
+ CultureInfo "es-MX"; CultureInfo "es-ES"; CultureInfo "es"
+ |]
+ opts.DefaultRequestCulture <- RequestCulture ("en-US", "en-US")
+ opts.SupportedCultures <- supportedCultures
+ opts.SupportedUICultures <- supportedCultures)
+ let _ = svc.AddDistributedMemoryCache()
+ let _ = svc.AddSession()
+ let _ = svc.AddAntiforgery()
+ let _ = svc.AddRouting()
+ let _ = svc.AddSingleton(SystemClock.Instance)
+
+ let config = svc.BuildServiceProvider().GetRequiredService()
+ let crypto = config.GetSection "CookieCrypto"
+ CookieCrypto (crypto["Key"], crypto["IV"]) |> setCrypto
+
+ let _ = svc.AddDbContext(
+ (fun options ->
+ options.UseNpgsql (config.GetConnectionString "PrayerTracker") |> ignore),
+ ServiceLifetime.Scoped, ServiceLifetime.Singleton)
+ ()
+
+ /// Routes for PrayerTracker
+ let routes = [
+ subRoute "/web" [
+ GET_HEAD [
+ subRoute "/church" [
+ route "es" Handlers.Church.maintain
+ routef "/%O/edit" Handlers.Church.edit
+ ]
+ route "/class/logon" (redirectTo true "/web/small-group/log-on")
+ routef "/error/%s" Handlers.Home.error
+ routef "/language/%s" Handlers.Home.language
+ subRoute "/legal" [
+ route "/privacy-policy" Handlers.Home.privacyPolicy
+ route "/terms-of-service" Handlers.Home.tos
+ ]
+ route "/log-off" Handlers.Home.logOff
+ subRoute "/prayer-request" [
+ route "s" (Handlers.PrayerRequest.maintain true)
+ routef "s/email/%s" Handlers.PrayerRequest.email
+ route "s/inactive" (Handlers.PrayerRequest.maintain false)
+ route "s/lists" Handlers.PrayerRequest.lists
+ routef "s/%O/list" Handlers.PrayerRequest.list
+ route "s/maintain" (redirectTo true "/web/prayer-requests")
+ routef "s/print/%s" Handlers.PrayerRequest.print
+ route "s/view" (Handlers.PrayerRequest.view None)
+ routef "s/view/%s" (Some >> Handlers.PrayerRequest.view)
+ routef "/%O/edit" Handlers.PrayerRequest.edit
+ routef "/%O/expire" Handlers.PrayerRequest.expire
+ routef "/%O/restore" Handlers.PrayerRequest.restore
+ ]
+ subRoute "/small-group" [
+ route "" Handlers.SmallGroup.overview
+ route "s" Handlers.SmallGroup.maintain
+ route "/announcement" Handlers.SmallGroup.announcement
+ routef "/%O/edit" Handlers.SmallGroup.edit
+ route "/log-on" (Handlers.SmallGroup.logOn None)
+ routef "/log-on/%O" (Some >> Handlers.SmallGroup.logOn)
+ route "/logon" (redirectTo true "/web/small-group/log-on")
+ routef "/member/%O/edit" Handlers.SmallGroup.editMember
+ route "/members" Handlers.SmallGroup.members
+ route "/preferences" Handlers.SmallGroup.preferences
+ ]
+ route "/unauthorized" Handlers.Home.unauthorized
+ subRoute "/user" [
+ route "s" Handlers.User.maintain
+ routef "/%O/edit" Handlers.User.edit
+ routef "/%O/small-groups" Handlers.User.smallGroups
+ route "/log-on" Handlers.User.logOn
+ route "/logon" (redirectTo true "/web/user/log-on")
+ route "/password" Handlers.User.password
+ ]
+ route "/" Handlers.Home.homePage
]
- route "/class/logon" (redirectTo true "/web/small-group/log-on")
- routef "/error/%s" Handlers.Home.error
- routef "/language/%s" Handlers.Home.language
- subRoute "/legal" [
- route "/privacy-policy" Handlers.Home.privacyPolicy
- route "/terms-of-service" Handlers.Home.tos
+ POST [
+ subRoute "/church" [
+ routef "/%O/delete" Handlers.Church.delete
+ route "/save" Handlers.Church.save
+ ]
+ subRoute "/prayer-request" [
+ routef "/%O/delete" Handlers.PrayerRequest.delete
+ route "/save" Handlers.PrayerRequest.save
+ ]
+ subRoute "/small-group" [
+ route "/announcement/send" Handlers.SmallGroup.sendAnnouncement
+ routef "/%O/delete" Handlers.SmallGroup.delete
+ route "/log-on/submit" Handlers.SmallGroup.logOnSubmit
+ routef "/member/%O/delete" Handlers.SmallGroup.deleteMember
+ route "/member/save" Handlers.SmallGroup.saveMember
+ route "/preferences/save" Handlers.SmallGroup.savePreferences
+ route "/save" Handlers.SmallGroup.save
+ ]
+ subRoute "/user" [
+ routef "/%O/delete" Handlers.User.delete
+ route "/edit/save" Handlers.User.save
+ route "/log-on" Handlers.User.doLogOn
+ route "/password/change" Handlers.User.changePassword
+ route "/small-groups/save" Handlers.User.saveGroups
+ ]
]
- route "/log-off" Handlers.Home.logOff
- subRoute "/prayer-request" [
- route "s" (Handlers.PrayerRequest.maintain true)
- routef "s/email/%s" Handlers.PrayerRequest.email
- route "s/inactive" (Handlers.PrayerRequest.maintain false)
- route "s/lists" Handlers.PrayerRequest.lists
- routef "s/%O/list" Handlers.PrayerRequest.list
- route "s/maintain" (redirectTo true "/web/prayer-requests")
- routef "s/print/%s" Handlers.PrayerRequest.print
- route "s/view" (Handlers.PrayerRequest.view None)
- routef "s/view/%s" (Some >> Handlers.PrayerRequest.view)
- routef "/%O/edit" Handlers.PrayerRequest.edit
- routef "/%O/expire" Handlers.PrayerRequest.expire
- routef "/%O/restore" Handlers.PrayerRequest.restore
- ]
- subRoute "/small-group" [
- route "" Handlers.SmallGroup.overview
- route "s" Handlers.SmallGroup.maintain
- route "/announcement" Handlers.SmallGroup.announcement
- routef "/%O/edit" Handlers.SmallGroup.edit
- route "/log-on" (Handlers.SmallGroup.logOn None)
- routef "/log-on/%O" (Some >> Handlers.SmallGroup.logOn)
- route "/logon" (redirectTo true "/web/small-group/log-on")
- routef "/member/%O/edit" Handlers.SmallGroup.editMember
- route "/members" Handlers.SmallGroup.members
- route "/preferences" Handlers.SmallGroup.preferences
- ]
- route "/unauthorized" Handlers.Home.unauthorized
- subRoute "/user" [
- route "s" Handlers.User.maintain
- routef "/%O/edit" Handlers.User.edit
- routef "/%O/small-groups" Handlers.User.smallGroups
- route "/log-on" Handlers.User.logOn
- route "/logon" (redirectTo true "/web/user/log-on")
- route "/password" Handlers.User.password
- ]
- route "/" Handlers.Home.homePage
- ]
- POST [
- subRoute "/church" [
- routef "/%O/delete" Handlers.Church.delete
- route "/save" Handlers.Church.save
- ]
- subRoute "/prayer-request" [
- routef "/%O/delete" Handlers.PrayerRequest.delete
- route "/save" Handlers.PrayerRequest.save
- ]
- subRoute "/small-group" [
- route "/announcement/send" Handlers.SmallGroup.sendAnnouncement
- routef "/%O/delete" Handlers.SmallGroup.delete
- route "/log-on/submit" Handlers.SmallGroup.logOnSubmit
- routef "/member/%O/delete" Handlers.SmallGroup.deleteMember
- route "/member/save" Handlers.SmallGroup.saveMember
- route "/preferences/save" Handlers.SmallGroup.savePreferences
- route "/save" Handlers.SmallGroup.save
- ]
- subRoute "/user" [
- routef "/%O/delete" Handlers.User.delete
- route "/edit/save" Handlers.User.save
- route "/log-on" Handlers.User.doLogOn
- route "/password/change" Handlers.User.changePassword
- route "/small-groups/save" Handlers.User.saveGroups
- ]
- ]
]
- // Temp redirect to new URLs
- route "/" (redirectTo false "/web/")
- ]
+ // Temp redirect to new URLs
+ route "/" (redirectTo false "/web/")
+ ]
- /// Giraffe error handler
- let errorHandler (ex : exn) (logger : ILogger) =
- logger.LogError(EventId(), ex, "An unhandled exception has occurred while executing the request.")
- clearResponse >=> setStatusCode 500 >=> text ex.Message
-
- /// Configure logging
- let logging (log : ILoggingBuilder) =
- let env = log.Services.BuildServiceProvider().GetService ()
- match env.IsDevelopment () with
- | true -> log
- | false -> log.AddFilter (fun l -> l > LogLevel.Information)
- |> function l -> l.AddConsole().AddDebug()
- |> ignore
-
- let app (app : IApplicationBuilder) =
- let env = app.ApplicationServices.GetRequiredService()
- (match env.IsDevelopment () with
- | true ->
- app.UseDeveloperExceptionPage ()
- | false ->
- try
- use scope = app.ApplicationServices.GetRequiredService().CreateScope ()
- scope.ServiceProvider.GetService().Database.Migrate ()
- with _ -> () // om nom nom
- app.UseGiraffeErrorHandler errorHandler)
- .UseStatusCodePagesWithReExecute("/error/{0}")
- .UseStaticFiles()
- .UseRouting()
- .UseSession()
- .UseRequestLocalization(app.ApplicationServices.GetService>().Value)
- .UseEndpoints (fun e -> e.MapGiraffeEndpoints routes)
- |> ignore
- Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService ()
+ /// Giraffe error handler
+ let errorHandler (ex : exn) (logger : ILogger) =
+ logger.LogError (EventId(), ex, "An unhandled exception has occurred while executing the request.")
+ clearResponse >=> setStatusCode 500 >=> text ex.Message
+
+ /// Configure logging
+ let logging (log : ILoggingBuilder) =
+ let env = log.Services.BuildServiceProvider().GetService ()
+ if env.IsDevelopment () then log else log.AddFilter (fun l -> l > LogLevel.Information)
+ |> function l -> l.AddConsole().AddDebug()
+ |> ignore
+
+ let app (app : IApplicationBuilder) =
+ let env = app.ApplicationServices.GetRequiredService()
+ if env.IsDevelopment () then
+ let _ = app.UseDeveloperExceptionPage ()
+ ()
+ else
+ try
+ use scope = app.ApplicationServices.GetRequiredService().CreateScope ()
+ scope.ServiceProvider.GetService().Database.Migrate ()
+ with _ -> () // om nom nom
+ let _ = app.UseGiraffeErrorHandler errorHandler
+ ()
+
+ let _ = app.UseStatusCodePagesWithReExecute "/error/{0}"
+ let _ = app.UseStaticFiles ()
+ let _ = app.UseRouting ()
+ let _ = app.UseSession ()
+ let _ = app.UseRequestLocalization
+ (app.ApplicationServices.GetService>().Value)
+ let _ = app.UseEndpoints (fun e -> e.MapGiraffeEndpoints routes)
+ Views.I18N.setUpFactories <| app.ApplicationServices.GetRequiredService ()
/// The web application
module App =
- open System.IO
+ open System.IO
- []
- let main _ =
- let contentRoot = Directory.GetCurrentDirectory ()
- WebHostBuilder()
- .UseContentRoot(contentRoot)
- .ConfigureAppConfiguration(Configure.configuration)
- .UseKestrel(Configure.kestrel)
- .UseWebRoot(Path.Combine (contentRoot, "wwwroot"))
- .ConfigureServices(Configure.services)
- .ConfigureLogging(Configure.logging)
- .Configure(System.Action Configure.app)
- .Build()
- .Run ()
- 0
+ []
+ let main _ =
+ let contentRoot = Directory.GetCurrentDirectory ()
+ WebHostBuilder()
+ .UseContentRoot(contentRoot)
+ .ConfigureAppConfiguration(Configure.configuration)
+ .UseKestrel(Configure.kestrel)
+ .UseWebRoot(Path.Combine (contentRoot, "wwwroot"))
+ .ConfigureServices(Configure.services)
+ .ConfigureLogging(Configure.logging)
+ .Configure(System.Action Configure.app)
+ .Build()
+ .Run ()
+ 0
diff --git a/src/PrayerTracker/Church.fs b/src/PrayerTracker/Church.fs
index b25225b..7bf5bf6 100644
--- a/src/PrayerTracker/Church.fs
+++ b/src/PrayerTracker/Church.fs
@@ -1,27 +1,24 @@
module PrayerTracker.Handlers.Church
+open System
+open System.Threading.Tasks
open Giraffe
open PrayerTracker
open PrayerTracker.Entities
open PrayerTracker.ViewModels
open PrayerTracker.Views.CommonFunctions
-open System
-open System.Threading.Tasks
/// Find statistics for the given church
let private findStats (db : AppDbContext) churchId = task {
- let! grps = db.CountGroupsByChurch churchId
- let! reqs = db.CountRequestsByChurch churchId
- let! usrs = db.CountUsersByChurch churchId
- return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs }
- }
+ let! grps = db.CountGroupsByChurch churchId
+ let! reqs = db.CountRequestsByChurch churchId
+ let! usrs = db.CountUsersByChurch churchId
+ return flatGuid churchId, { smallGroups = grps; prayerRequests = reqs; users = usrs }
+}
/// POST /church/[church-id]/delete
-let delete churchId : HttpHandler =
- requireAccess [ Admin ]
- >=> validateCSRF
- >=> fun next ctx -> task {
+let delete churchId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
match! ctx.db.TryChurchById churchId with
| Some church ->
let! _, stats = findStats ctx.db churchId
@@ -29,70 +26,61 @@ let delete churchId : HttpHandler =
let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
addInfo ctx
- s.["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)",
+ s["The church {0} and its {1} small groups (with {2} prayer request(s)) were deleted successfully; revoked access from {3} user(s)",
church.name, stats.smallGroups, stats.prayerRequests, stats.users]
return! redirectTo false "/web/churches" next ctx
| None -> return! fourOhFour next ctx
- }
+}
/// 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 {
let startTicks = DateTime.Now.Ticks
- match churchId with
- | x when x = Guid.Empty ->
+ if churchId = Guid.Empty then
return!
- viewInfo ctx startTicks
- |> Views.Church.edit EditChurch.empty ctx
- |> renderHtml next ctx
- | _ ->
+ viewInfo ctx startTicks
+ |> Views.Church.edit EditChurch.empty ctx
+ |> renderHtml next ctx
+ else
match! ctx.db.TryChurchById churchId with
| Some church ->
return!
- viewInfo ctx startTicks
- |> Views.Church.edit (EditChurch.fromChurch church) ctx
- |> renderHtml next ctx
+ viewInfo ctx startTicks
+ |> Views.Church.edit (EditChurch.fromChurch church) ctx
+ |> renderHtml next ctx
| None -> return! fourOhFour next ctx
- }
+}
/// GET /churches
-let maintain : HttpHandler =
- requireAccess [ Admin ]
- >=> fun next ctx -> task {
+let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let await = Async.AwaitTask >> Async.RunSynchronously
let! churches = ctx.db.AllChurches ()
let stats = churches |> List.map (fun c -> await (findStats ctx.db c.churchId))
return!
- viewInfo ctx startTicks
- |> Views.Church.maintain churches (stats |> Map.ofList) ctx
- |> renderHtml next ctx
- }
+ viewInfo ctx startTicks
+ |> Views.Church.maintain churches (stats |> Map.ofList) ctx
+ |> renderHtml next ctx
+}
/// 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 () with
| Ok m ->
let! church =
- match m.isNew () with
- | true -> Task.FromResult(Some { Church.empty with churchId = Guid.NewGuid () })
- | false -> ctx.db.TryChurchById m.churchId
+ if m.isNew () then Task.FromResult (Some { Church.empty with churchId = Guid.NewGuid () })
+ else ctx.db.TryChurchById m.churchId
match church with
| Some ch ->
m.populateChurch ch
- |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
+ |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
- let act = s.[match m.isNew () with true -> "Added" | _ -> "Updated"].Value.ToLower ()
- addInfo ctx s.["Successfully {0} church “{1}”", act, m.name]
+ let act = s[if m.isNew () then "Added" else "Updated"].Value.ToLower ()
+ addInfo ctx s["Successfully {0} church “{1}”", act, m.name]
return! redirectTo false "/web/churches" next ctx
| None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx
- }
+}
diff --git a/src/PrayerTracker/CommonFunctions.fs b/src/PrayerTracker/CommonFunctions.fs
index 158376f..ba54e2f 100644
--- a/src/PrayerTracker/CommonFunctions.fs
+++ b/src/PrayerTracker/CommonFunctions.fs
@@ -2,6 +2,10 @@
[]
module PrayerTracker.Handlers.CommonFunctions
+open System
+open System.Net
+open System.Reflection
+open System.Threading.Tasks
open Giraffe
open Microsoft.AspNetCore.Antiforgery
open Microsoft.AspNetCore.Html
@@ -12,244 +16,235 @@ open Microsoft.Extensions.Localization
open PrayerTracker
open PrayerTracker.Cookies
open PrayerTracker.ViewModels
-open System
-open System.Net
-open System.Reflection
-open System.Threading.Tasks
/// Create a select list from an enumeration
let toSelectList<'T> valFunc textFunc withDefault emptyText (items : 'T seq) =
- match items with null -> nullArg "items" | _ -> ()
- [ match withDefault with
- | true ->
- let s = PrayerTracker.Views.I18N.localizer.Force ()
- yield SelectListItem ($"""— %A{s.[emptyText]} —""", "")
- | _ -> ()
- yield! items |> Seq.map (fun x -> SelectListItem (textFunc x, valFunc x))
+ match items with null -> nullArg "items" | _ -> ()
+ [ match withDefault with
+ | true ->
+ let s = PrayerTracker.Views.I18N.localizer.Force ()
+ yield SelectListItem ($"""— %A{s[emptyText]} —""", "")
+ | _ -> ()
+ yield! items |> Seq.map (fun x -> SelectListItem (textFunc x, valFunc x))
]
/// Create a select list from an enumeration
let toSelectListWithEmpty<'T> valFunc textFunc emptyText (items : 'T seq) =
- toSelectList valFunc textFunc true emptyText items
+ toSelectList valFunc textFunc true emptyText items
/// Create a select list from an enumeration
let toSelectListWithDefault<'T> valFunc textFunc (items : 'T seq) =
- toSelectList valFunc textFunc true "Select" items
+ toSelectList valFunc textFunc true "Select" items
/// The version of PrayerTracker
let appVersion =
- let v = Assembly.GetExecutingAssembly().GetName().Version
+ let v = Assembly.GetExecutingAssembly().GetName().Version
#if (DEBUG)
- $"v{v}"
+ $"v{v}"
#else
- seq {
- $"v%d{v.Major}"
- match v.Minor with
- | 0 -> match v.Build with 0 -> () | _ -> $".0.%d{v.Build}"
- | _ ->
- $".%d{v.Minor}"
- match v.Build with 0 -> () | _ -> $".%d{v.Build}"
+ seq {
+ $"v%d{v.Major}"
+ match v.Minor with
+ | 0 -> match v.Build with 0 -> () | _ -> $".0.%d{v.Build}"
+ | _ ->
+ $".%d{v.Minor}"
+ match v.Build with 0 -> () | _ -> $".%d{v.Build}"
}
- |> String.concat ""
+ |> String.concat ""
#endif
/// The currently signed-in user (will raise if none exists)
let currentUser (ctx : HttpContext) =
- match ctx.Session.user with Some u -> u | None -> nullArg "User"
+ match ctx.Session.user with Some u -> u | None -> nullArg "User"
/// The currently signed-in small group (will raise if none exists)
let currentGroup (ctx : HttpContext) =
- match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup"
+ match ctx.Session.smallGroup with Some g -> g | None -> nullArg "SmallGroup"
/// Create the common view information heading
let viewInfo (ctx : HttpContext) startTicks =
- let msg =
- match ctx.Session.messages with
- | [] -> []
- | x ->
- ctx.Session.messages <- []
- x
- match ctx.Session.user with
- | Some u ->
- // The idle timeout is 2 hours; if the app pool is recycled or the actual session goes away, we will log the
- // user back in transparently using this cookie. Every request resets the timer.
- let timeout =
- { Id = u.userId
- GroupId = (currentGroup ctx).smallGroupId
- Until = DateTime.UtcNow.AddHours(2.).Ticks
- Password = ""
- }
- ctx.Response.Cookies.Append
- (Key.Cookie.timeout, { timeout with Password = saltedTimeoutHash timeout }.toPayload (),
- CookieOptions (Expires = Nullable (DateTimeOffset (DateTime timeout.Until)), HttpOnly = true))
- | None -> ()
- { AppViewInfo.fresh with
- version = appVersion
- messages = msg
- requestStart = startTicks
- user = ctx.Session.user
- group = ctx.Session.smallGroup
- }
+ let msg =
+ match ctx.Session.messages with
+ | [] -> []
+ | x ->
+ ctx.Session.messages <- []
+ x
+ match ctx.Session.user with
+ | Some u ->
+ // The idle timeout is 2 hours; if the app pool is recycled or the actual session goes away, we will log the
+ // user back in transparently using this cookie. Every request resets the timer.
+ let timeout =
+ { Id = u.userId
+ GroupId = (currentGroup ctx).smallGroupId
+ Until = DateTime.UtcNow.AddHours(2.).Ticks
+ Password = ""
+ }
+ ctx.Response.Cookies.Append
+ (Key.Cookie.timeout, { timeout with Password = saltedTimeoutHash timeout }.toPayload (),
+ CookieOptions (Expires = Nullable (DateTimeOffset (DateTime timeout.Until)),
+ HttpOnly = true))
+ | None -> ()
+ { AppViewInfo.fresh with
+ version = appVersion
+ messages = msg
+ requestStart = startTicks
+ user = ctx.Session.user
+ group = ctx.Session.smallGroup
+ }
/// The view is the last parameter, so it can be composed
let renderHtml next ctx view =
- htmlView view next ctx
+ htmlView view next ctx
/// Display an error regarding form submission
let bindError (msg : string) next (ctx : HttpContext) =
- System.Console.WriteLine msg
- ctx.SetStatusCode 400
- text msg next ctx
+ Console.WriteLine msg
+ ctx.SetStatusCode 400
+ text msg next ctx
/// Handler that will return a status code 404 and the text "Not Found"
let fourOhFour next (ctx : HttpContext) =
- ctx.SetStatusCode 404
- text "Not Found" next ctx
+ ctx.SetStatusCode 404
+ text "Not Found" next ctx
/// Handler to validate CSRF prevention token
-let validateCSRF : HttpHandler =
- fun next ctx -> task {
+let validateCSRF : HttpHandler = fun next ctx -> task {
match! (ctx.GetService ()).IsRequestValidAsync ctx with
| true -> return! next ctx
| false ->
return! (clearResponse >=> setStatusCode 400 >=> text "Quit hacking...") (fun _ -> Task.FromResult None) ctx
- }
+}
/// Add a message to the session
let addUserMessage (ctx : HttpContext) msg =
- ctx.Session.messages <- msg :: ctx.Session.messages
+ ctx.Session.messages <- msg :: ctx.Session.messages
/// Convert a localized string to an HTML string
let htmlLocString (x : LocalizedString) =
- (WebUtility.HtmlEncode >> HtmlString) x.Value
+ (WebUtility.HtmlEncode >> HtmlString) x.Value
let htmlString (x : LocalizedString) =
- HtmlString x.Value
+ HtmlString x.Value
/// Add an error message to the session
let addError ctx msg =
- addUserMessage ctx { UserMessage.error with text = htmlLocString msg }
+ addUserMessage ctx { UserMessage.error with text = htmlLocString msg }
/// Add an informational message to the session
let addInfo ctx msg =
- addUserMessage ctx { UserMessage.info with text = htmlLocString msg }
+ addUserMessage ctx { UserMessage.info with text = htmlLocString msg }
/// Add an informational HTML message to the session
let addHtmlInfo ctx msg =
- addUserMessage ctx { UserMessage.info with text = htmlString msg }
+ addUserMessage ctx { UserMessage.info with text = htmlString msg }
/// Add a warning message to the session
let addWarning ctx msg =
- addUserMessage ctx { UserMessage.warning with text = htmlLocString msg }
+ addUserMessage ctx { UserMessage.warning with text = htmlLocString msg }
/// A level of required access
type AccessLevel =
- /// Administrative access
- | Admin
- /// Small group administrative access
- | User
- /// Small group member access
- | Group
- /// Errbody
- | Public
+ /// Administrative access
+ | Admin
+ /// Small group administrative access
+ | User
+ /// Small group member access
+ | Group
+ /// Errbody
+ | Public
/// Require the given access role (also refreshes "Remember Me" user and group logons)
let requireAccess level : HttpHandler =
- /// Is there currently a user logged on?
- let isUserLoggedOn (ctx : HttpContext) =
- ctx.Session.user |> Option.isSome
+ /// Is there currently a user logged on?
+ let isUserLoggedOn (ctx : HttpContext) =
+ ctx.Session.user |> Option.isSome
- /// Log a user on from the timeout cookie
- let logOnUserFromTimeoutCookie (ctx : HttpContext) = task {
- // Make sure the cookie hasn't been tampered with
- try
- match TimeoutCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.timeout] with
- | Some c when c.Password = saltedTimeoutHash c ->
- let! user = ctx.db.TryUserById c.Id
- match user with
- | Some _ ->
- ctx.Session.user <- user
- let! grp = ctx.db.TryGroupById c.GroupId
- ctx.Session.smallGroup <- grp
- | _ -> ()
- | _ -> ()
- // If something above doesn't work, the user doesn't get logged in
- with _ -> ()
+ /// Log a user on from the timeout cookie
+ let logOnUserFromTimeoutCookie (ctx : HttpContext) = task {
+ // Make sure the cookie hasn't been tampered with
+ try
+ match TimeoutCookie.fromPayload ctx.Request.Cookies[Key.Cookie.timeout] with
+ | Some c when c.Password = saltedTimeoutHash c ->
+ let! user = ctx.db.TryUserById c.Id
+ match user with
+ | Some _ ->
+ ctx.Session.user <- user
+ let! grp = ctx.db.TryGroupById c.GroupId
+ ctx.Session.smallGroup <- grp
+ | _ -> ()
+ | _ -> ()
+ // If something above doesn't work, the user doesn't get logged in
+ with _ -> ()
}
- /// Attempt to log the user on from their stored cookie
- let logOnUserFromCookie (ctx : HttpContext) = task {
- match UserCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.user] with
- | Some c ->
- let! user = ctx.db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash
- match user with
- | Some _ ->
- ctx.Session.user <- user
- let! grp = ctx.db.TryGroupById c.GroupId
- ctx.Session.smallGroup <- grp
- // Rewrite the cookie to extend the expiration
- ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh)
+ /// Attempt to log the user on from their stored cookie
+ let logOnUserFromCookie (ctx : HttpContext) = task {
+ match UserCookie.fromPayload ctx.Request.Cookies[Key.Cookie.user] with
+ | Some c ->
+ let! user = ctx.db.TryUserLogOnByCookie c.Id c.GroupId c.PasswordHash
+ match user with
+ | Some _ ->
+ ctx.Session.user <- user
+ let! grp = ctx.db.TryGroupById c.GroupId
+ ctx.Session.smallGroup <- grp
+ // Rewrite the cookie to extend the expiration
+ ctx.Response.Cookies.Append (Key.Cookie.user, c.toPayload (), autoRefresh)
+ | _ -> ()
| _ -> ()
- | _ -> ()
}
- /// Is there currently a small group (or member thereof) logged on?
- let isGroupLoggedOn (ctx : HttpContext) =
- ctx.Session.smallGroup |> Option.isSome
+ /// Is there currently a small group (or member thereof) logged on?
+ let isGroupLoggedOn (ctx : HttpContext) =
+ ctx.Session.smallGroup |> Option.isSome
- /// Attempt to log the small group on from their stored cookie
- let logOnGroupFromCookie (ctx : HttpContext) =
- task {
- match GroupCookie.fromPayload ctx.Request.Cookies.[Key.Cookie.group] with
- | Some c ->
- let! grp = ctx.db.TryGroupLogOnByCookie c.GroupId c.PasswordHash sha1Hash
- match grp with
- | Some _ ->
- ctx.Session.smallGroup <- grp
- // Rewrite the cookie to extend the expiration
- ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh)
- | None -> ()
- | None -> ()
+ /// Attempt to log the small group on from their stored cookie
+ let logOnGroupFromCookie (ctx : HttpContext) = task {
+ match GroupCookie.fromPayload ctx.Request.Cookies[Key.Cookie.group] with
+ | Some c ->
+ let! grp = ctx.db.TryGroupLogOnByCookie c.GroupId c.PasswordHash sha1Hash
+ match grp with
+ | Some _ ->
+ ctx.Session.smallGroup <- grp
+ // Rewrite the cookie to extend the expiration
+ ctx.Response.Cookies.Append (Key.Cookie.group, c.toPayload (), autoRefresh)
+ | None -> ()
+ | None -> ()
}
- fun next ctx -> FSharp.Control.Tasks.Affine.task {
- // Auto-logon user or class, if required
- match isUserLoggedOn ctx with
- | true -> ()
- | false ->
- do! logOnUserFromTimeoutCookie ctx
- match isUserLoggedOn ctx with
- | true -> ()
- | false ->
- do! logOnUserFromCookie ctx
- match isGroupLoggedOn ctx with true -> () | false -> do! logOnGroupFromCookie ctx
+ fun next ctx -> task {
+ // Auto-logon user or class, if required
+ if not (isUserLoggedOn ctx) then
+ do! logOnUserFromTimeoutCookie ctx
+ if not (isUserLoggedOn ctx) then
+ do! logOnUserFromCookie ctx
+ if not (isGroupLoggedOn ctx) then do! logOnGroupFromCookie ctx
- match true with
- | _ when level |> List.contains Public -> return! next ctx
- | _ when level |> List.contains User && isUserLoggedOn ctx -> return! next ctx
- | _ when level |> List.contains Group && isGroupLoggedOn ctx -> return! next ctx
- | _ when level |> List.contains Admin && isUserLoggedOn ctx ->
- match (currentUser ctx).isAdmin with
- | true -> return! next ctx
- | false ->
+ match true with
+ | _ when level |> List.contains Public -> return! next ctx
+ | _ when level |> List.contains User && isUserLoggedOn ctx -> return! next ctx
+ | _ when level |> List.contains Group && isGroupLoggedOn ctx -> return! next ctx
+ | _ when level |> List.contains Admin && isUserLoggedOn ctx ->
+ match (currentUser ctx).isAdmin with
+ | true -> return! next ctx
+ | false ->
+ let s = Views.I18N.localizer.Force ()
+ addError ctx s["You are not authorized to view the requested page."]
+ return! redirectTo false "/web/unauthorized" next ctx
+ | _ when level |> List.contains User ->
+ // Redirect to the user log on page
+ ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
+ return! redirectTo false "/web/user/log-on" next ctx
+ | _ when level |> List.contains Group ->
+ // Redirect to the small group log on page
+ ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
+ return! redirectTo false "/web/small-group/log-on" next ctx
+ | _ ->
let s = Views.I18N.localizer.Force ()
- addError ctx s.["You are not authorized to view the requested page."]
+ addError ctx s["You are not authorized to view the requested page."]
return! redirectTo false "/web/unauthorized" next ctx
- | _ when level |> List.contains User ->
- // Redirect to the user log on page
- ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
- return! redirectTo false "/web/user/log-on" next ctx
- | _ when level |> List.contains Group ->
- // Redirect to the small group log on page
- ctx.Session.SetString (Key.Session.redirectUrl, ctx.Request.GetEncodedUrl ())
- return! redirectTo false "/web/small-group/log-on" next ctx
- | _ ->
- let s = Views.I18N.localizer.Force ()
- addError ctx s.["You are not authorized to view the requested page."]
- return! redirectTo false "/web/unauthorized" next ctx
}
diff --git a/src/PrayerTracker/Cookies.fs b/src/PrayerTracker/Cookies.fs
index 13fc471..3ca59f6 100644
--- a/src/PrayerTracker/Cookies.fs
+++ b/src/PrayerTracker/Cookies.fs
@@ -10,47 +10,49 @@ open System.IO
/// Cryptography settings to use for encrypting cookies
type CookieCrypto (key : string, iv : string) =
- /// The key for the AES encryptor/decryptor
- member __.Key = Convert.FromBase64String key
- /// The initialization vector for the AES encryptor/decryptor
- member __.IV = Convert.FromBase64String iv
+
+ /// The key for the AES encryptor/decryptor
+ member _.Key = Convert.FromBase64String key
+
+ /// The initialization vector for the AES encryptor/decryptor
+ member _.IV = Convert.FromBase64String iv
/// Helpers for encrypting/decrypting cookies
[]
module private Crypto =
- /// An instance of the cookie cryptography settings
- let mutable crypto = CookieCrypto ("", "")
+ /// An instance of the cookie cryptography settings
+ let mutable crypto = CookieCrypto ("", "")
- /// Encrypt a cookie payload
- let encrypt (payload : string) =
- use aes = Aes.Create ()
- use enc = aes.CreateEncryptor (crypto.Key, crypto.IV)
- use ms = new MemoryStream ()
- use cs = new CryptoStream (ms, enc, CryptoStreamMode.Write)
- use sw = new StreamWriter (cs)
- sw.Write payload
- sw.Close ()
- (ms.ToArray >> Convert.ToBase64String) ()
-
- /// Decrypt a cookie payload
- let decrypt payload =
- use aes = Aes.Create ()
- use dec = aes.CreateDecryptor (crypto.Key, crypto.IV)
- use ms = new MemoryStream (Convert.FromBase64String payload)
- use cs = new CryptoStream (ms, dec, CryptoStreamMode.Read)
- use sr = new StreamReader (cs)
- sr.ReadToEnd ()
+ /// Encrypt a cookie payload
+ let encrypt (payload : string) =
+ use aes = Aes.Create ()
+ use enc = aes.CreateEncryptor (crypto.Key, crypto.IV)
+ use ms = new MemoryStream ()
+ use cs = new CryptoStream (ms, enc, CryptoStreamMode.Write)
+ use sw = new StreamWriter (cs)
+ sw.Write payload
+ sw.Close ()
+ (ms.ToArray >> Convert.ToBase64String) ()
+
+ /// Decrypt a cookie payload
+ let decrypt payload =
+ use aes = Aes.Create ()
+ use dec = aes.CreateDecryptor (crypto.Key, crypto.IV)
+ use ms = new MemoryStream (Convert.FromBase64String payload)
+ use cs = new CryptoStream (ms, dec, CryptoStreamMode.Read)
+ use sr = new StreamReader (cs)
+ sr.ReadToEnd ()
- /// Encrypt a cookie
- let encryptCookie cookie =
- (JsonConvert.SerializeObject >> encrypt) cookie
+ /// Encrypt a cookie
+ let encryptCookie cookie =
+ (JsonConvert.SerializeObject >> encrypt) cookie
- /// Decrypt a cookie
- let decryptCookie<'T> payload =
- (decrypt >> JsonConvert.DeserializeObject<'T> >> box) payload
- |> function null -> None | x -> Some (unbox<'T> x)
+ /// Decrypt a cookie
+ let decryptCookie<'T> payload =
+ (decrypt >> JsonConvert.DeserializeObject<'T> >> box) payload
+ |> function null -> None | x -> Some (unbox<'T> x)
/// Accessor so that the crypto settings instance can be set during startup
@@ -59,71 +61,83 @@ let setCrypto c = Crypto.crypto <- c
/// Properties stored in the Small Group cookie
type GroupCookie =
- { /// The Id of the small group
- []
- GroupId : Guid
- /// The password hash of the small group
- []
- PasswordHash : string
+ { /// The Id of the small group
+ []
+ GroupId : Guid
+
+ /// The password hash of the small group
+ []
+ PasswordHash : string
}
- with
+with
+
/// Convert these properties to a cookie payload
member this.toPayload () =
- encryptCookie this
+ encryptCookie this
+
/// Create a set of strongly-typed properties from the cookie payload
static member fromPayload x =
- try decryptCookie x with _ -> None
+ try decryptCookie x with _ -> None
/// The payload for the timeout cookie
type TimeoutCookie =
- { /// The Id of the small group to which the user is currently logged in
- []
- GroupId : Guid
- /// The Id of the user who is currently logged in
- []
- Id : Guid
- /// The salted timeout hash to ensure that there has been no tampering with the cookie
- []
- Password : string
- /// How long this cookie is valid
- []
- Until : int64
+ { /// The Id of the small group to which the user is currently logged in
+ []
+ GroupId : Guid
+
+ /// The Id of the user who is currently logged in
+ []
+ Id : Guid
+
+ /// The salted timeout hash to ensure that there has been no tampering with the cookie
+ []
+ Password : string
+
+ /// How long this cookie is valid
+ []
+ Until : int64
}
- with
+with
+
/// Convert this set of properties to the cookie payload
member this.toPayload () =
- encryptCookie this
+ encryptCookie this
+
/// Create a strongly-typed timeout cookie from the cookie payload
static member fromPayload x =
- try decryptCookie x with _ -> None
+ try decryptCookie x with _ -> None
/// The payload for the user's "Remember Me" cookie
type UserCookie =
- { /// The Id of the group into to which the user is logged
- [< JsonProperty "g">]
- GroupId : Guid
- /// The Id of the user
- []
- Id : Guid
- /// The user's password hash
- []
- PasswordHash : string
+ { /// The Id of the group into to which the user is logged
+ [< JsonProperty "g">]
+ GroupId : Guid
+
+ /// The Id of the user
+ []
+ Id : Guid
+
+ /// The user's password hash
+ []
+ PasswordHash : string
}
- with
+with
+
/// Convert this set of properties to a cookie payload
member this.toPayload () =
- encryptCookie this
+ encryptCookie this
+
/// Create the strongly-typed cookie properties from a cookie payload
static member fromPayload x =
- try decryptCookie x with _ -> None
+ try decryptCookie x with _ -> None
/// Create a salted hash to use to validate the idle timeout key
let saltedTimeoutHash (c : TimeoutCookie) =
- sha1Hash $"Prayer%A{c.Id}Tracker%A{c.GroupId}Idle%d{c.Until}Timeout"
+ sha1Hash $"Prayer%A{c.Id}Tracker%A{c.GroupId}Idle%d{c.Until}Timeout"
/// Cookie options to push an expiration out by 100 days
let autoRefresh =
- CookieOptions (Expires = Nullable (DateTimeOffset (DateTime.UtcNow.AddDays 100.)), HttpOnly = true)
+ CookieOptions (Expires = Nullable (DateTimeOffset (DateTime.UtcNow.AddDays 100.)), HttpOnly = true)
diff --git a/src/PrayerTracker/Email.fs b/src/PrayerTracker/Email.fs
index 1ab9ce0..b595605 100644
--- a/src/PrayerTracker/Email.fs
+++ b/src/PrayerTracker/Email.fs
@@ -14,64 +14,67 @@ let private fromAddress = "prayer@bitbadger.solutions"
/// Get an SMTP client connection
// FIXME: make host configurable
let getConnection () = task {
- let client = new SmtpClient ()
- do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None)
- return client
- }
+ let client = new SmtpClient ()
+ do! client.ConnectAsync ("127.0.0.1", 25, SecureSocketOptions.None)
+ return client
+}
/// Create a mail message object, filled with everything but the body content
let createMessage (grp : SmallGroup) subj =
- let msg = MimeMessage ()
- msg.From.Add (MailboxAddress (grp.preferences.emailFromName, fromAddress))
- msg.Subject <- subj
- msg.ReplyTo.Add (MailboxAddress (grp.preferences.emailFromName, grp.preferences.emailFromAddress))
- msg
+ let msg = MimeMessage ()
+ msg.From.Add (MailboxAddress (grp.preferences.emailFromName, fromAddress))
+ msg.Subject <- subj
+ msg.ReplyTo.Add (MailboxAddress (grp.preferences.emailFromName, grp.preferences.emailFromAddress))
+ msg
/// Create an HTML-format e-mail message
let createHtmlMessage grp subj body (s : IStringLocalizer) =
- let bodyText =
- [ """"""
- body
- """
"""
- s.["Generated by P R A Y E R T R A C K E R"].Value
- "
"
- s.["from Bit Badger Solutions"].Value
- "
"
- ]
- |> String.concat ""
- let msg = createMessage grp subj
- msg.Body <- TextPart (TextFormat.Html, Text = bodyText)
- msg
+ let bodyText =
+ [ """"""
+ body
+ """
"""
+ s["Generated by P R A Y E R T R A C K E R"].Value
+ "
"
+ s["from Bit Badger Solutions"].Value
+ "
"
+ ]
+ |> String.concat ""
+ let msg = createMessage grp subj
+ msg.Body <- TextPart (TextFormat.Html, Text = bodyText)
+ msg
/// Create a plain-text-format e-mail message
let createTextMessage grp subj body (s : IStringLocalizer) =
- let bodyText =
- [ body
- "\n\n--\n"
- s.["Generated by P R A Y E R T R A C K E R"].Value
- "\n"
- s.["from Bit Badger Solutions"].Value
- ]
- |> String.concat ""
- let msg = createMessage grp subj
- msg.Body <- TextPart (TextFormat.Plain, Text = bodyText)
- msg
+ let bodyText =
+ [ body
+ "\n\n--\n"
+ s["Generated by P R A Y E R T R A C K E R"].Value
+ "\n"
+ s["from Bit Badger Solutions"].Value
+ ]
+ |> String.concat ""
+ let msg = createMessage grp subj
+ msg.Body <- TextPart (TextFormat.Plain, Text = bodyText)
+ msg
/// Send e-mails to a class
let sendEmails (client : SmtpClient) (recipients : Member list) grp subj html text s = task {
- let htmlMsg = createHtmlMessage grp subj html s
- let plainTextMsg = createTextMessage grp subj text s
+ let htmlMsg = createHtmlMessage grp subj html s
+ let plainTextMsg = createTextMessage grp subj text s
- for mbr in recipients do
- let emailType = match mbr.format with Some f -> EmailFormat.fromCode f | None -> grp.preferences.defaultEmailType
- let emailTo = MailboxAddress (mbr.memberName, mbr.email)
- match emailType with
- | HtmlFormat ->
- htmlMsg.To.Add emailTo
- do! client.SendAsync htmlMsg
- htmlMsg.To.Clear ()
- | PlainTextFormat ->
- plainTextMsg.To.Add emailTo
- do! client.SendAsync plainTextMsg
- plainTextMsg.To.Clear ()
- }
+ for mbr in recipients do
+ let emailType =
+ match mbr.format with
+ | Some f -> EmailFormat.fromCode f
+ | None -> grp.preferences.defaultEmailType
+ let emailTo = MailboxAddress (mbr.memberName, mbr.email)
+ match emailType with
+ | HtmlFormat ->
+ htmlMsg.To.Add emailTo
+ do! client.SendAsync htmlMsg
+ htmlMsg.To.Clear ()
+ | PlainTextFormat ->
+ plainTextMsg.To.Add emailTo
+ do! client.SendAsync plainTextMsg
+ plainTextMsg.To.Clear ()
+}
diff --git a/src/PrayerTracker/Extensions.fs b/src/PrayerTracker/Extensions.fs
index 29b5ce2..1f7c2a0 100644
--- a/src/PrayerTracker/Extensions.fs
+++ b/src/PrayerTracker/Extensions.fs
@@ -11,42 +11,42 @@ open PrayerTracker.ViewModels
// fsharplint:disable MemberNames
type ISession with
- /// Set an object in the session
- member this.SetObject key value =
- this.SetString (key, JsonConvert.SerializeObject value)
+ /// Set an object in the session
+ member this.SetObject key value =
+ this.SetString (key, JsonConvert.SerializeObject value)
- /// Get an object from the session
- member this.GetObject<'T> key =
- match this.GetString key with
- | null -> Unchecked.defaultof<'T>
- | v -> JsonConvert.DeserializeObject<'T> v
+ /// Get an object from the session
+ member this.GetObject<'T> key =
+ match this.GetString key with
+ | null -> Unchecked.defaultof<'T>
+ | v -> JsonConvert.DeserializeObject<'T> v
- /// The current small group for the session
- member this.smallGroup
- with get () = this.GetObject Key.Session.currentGroup |> Option.fromObject
- and set (v : SmallGroup option) =
- match v with
- | Some group -> this.SetObject Key.Session.currentGroup group
- | None -> this.Remove Key.Session.currentGroup
+ /// The current small group for the session
+ member this.smallGroup
+ with get () = this.GetObject Key.Session.currentGroup |> Option.fromObject
+ and set (v : SmallGroup option) =
+ match v with
+ | Some group -> this.SetObject Key.Session.currentGroup group
+ | None -> this.Remove Key.Session.currentGroup
- /// The current user for the session
- member this.user
- with get () = this.GetObject Key.Session.currentUser |> Option.fromObject
- and set (v : User option) =
- match v with
- | Some user -> this.SetObject Key.Session.currentUser user
- | None -> this.Remove Key.Session.currentUser
+ /// The current user for the session
+ member this.user
+ with get () = this.GetObject Key.Session.currentUser |> Option.fromObject
+ and set (v : User option) =
+ match v with
+ | Some user -> this.SetObject Key.Session.currentUser user
+ | None -> this.Remove Key.Session.currentUser
- /// Current messages for the session
- member this.messages
- with get () =
- match box (this.GetObject Key.Session.userMessages) with
- | null -> List.empty
- | msgs -> unbox msgs
- and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v
+ /// Current messages for the session
+ member this.messages
+ with get () =
+ match box (this.GetObject Key.Session.userMessages) with
+ | null -> List.empty
+ | msgs -> unbox msgs
+ and set (v : UserMessage list) = this.SetObject Key.Session.userMessages v
type HttpContext with
- /// The EF Core database context (via DI)
- member this.db
- with get () = this.RequestServices.GetRequiredService ()
+ /// The EF Core database context (via DI)
+ member this.db
+ with get () = this.RequestServices.GetRequiredService ()
diff --git a/src/PrayerTracker/Home.fs b/src/PrayerTracker/Home.fs
index 4fe7a80..9e80aac 100644
--- a/src/PrayerTracker/Home.fs
+++ b/src/PrayerTracker/Home.fs
@@ -1,90 +1,76 @@
module PrayerTracker.Handlers.Home
+open System
+open System.Globalization
open Giraffe
open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Localization
open PrayerTracker
-open System
-open System.Globalization
/// 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 DateTime.Now.Ticks
|> Views.Home.error code
|> renderHtml next ctx
/// GET /
-let homePage : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx ->
+let homePage : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks
|> Views.Home.index
|> renderHtml next ctx
/// GET /language/[culture]
-let language culture : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx ->
+let language culture : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
try
- match culture with
- | null
- | ""
- | "en" -> "en-US"
- | "es" -> "es-MX"
- | _ -> $"{culture}-{culture.ToUpper ()}"
- |> (CultureInfo >> Option.ofObj)
+ match culture with
+ | null
+ | ""
+ | "en" -> "en-US"
+ | "es" -> "es-MX"
+ | _ -> $"{culture}-{culture.ToUpper ()}"
+ |> (CultureInfo >> Option.ofObj)
with
| :? CultureNotFoundException
| :? ArgumentException -> None
|> function
| Some c ->
ctx.Response.Cookies.Append (
- CookieRequestCultureProvider.DefaultCookieName,
- CookieRequestCultureProvider.MakeCookieValue (RequestCulture c),
- CookieOptions (Expires = Nullable (DateTimeOffset (DateTime.Now.AddYears 1))))
+ CookieRequestCultureProvider.DefaultCookieName,
+ CookieRequestCultureProvider.MakeCookieValue (RequestCulture c),
+ CookieOptions (Expires = Nullable (DateTimeOffset (DateTime.Now.AddYears 1))))
| _ -> ()
- let url = match string ctx.Request.Headers.["Referer"] with null | "" -> "/web/" | r -> r
+ let url = match string ctx.Request.Headers["Referer"] with null | "" -> "/web/" | r -> r
redirectTo false url next ctx
/// GET /legal/privacy-policy
-let privacyPolicy : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx ->
+let privacyPolicy : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks
|> Views.Home.privacyPolicy
|> renderHtml next ctx
/// GET /legal/terms-of-service
-let tos : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx ->
+let tos : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks
|> Views.Home.termsOfService
|> renderHtml next ctx
/// GET /log-off
-let logOff : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx ->
+let logOff : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
ctx.Session.Clear ()
// Remove cookies if they exist
Key.Cookie.logOffCookies |> List.iter ctx.Response.Cookies.Delete
let s = Views.I18N.localizer.Force ()
- addHtmlInfo ctx s.["Log Off Successful • Have a nice day!"]
+ addHtmlInfo ctx s["Log Off Successful • Have a nice day!"]
redirectTo false "/web/" next ctx
/// GET /unauthorized
-let unauthorized : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx ->
+let unauthorized : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx ->
viewInfo ctx DateTime.Now.Ticks
|> Views.Home.unauthorized
|> renderHtml next ctx
diff --git a/src/PrayerTracker/PrayerRequest.fs b/src/PrayerTracker/PrayerRequest.fs
index 0b68fef..9b5d14a 100644
--- a/src/PrayerTracker/PrayerRequest.fs
+++ b/src/PrayerTracker/PrayerRequest.fs
@@ -1,253 +1,234 @@
module PrayerTracker.Handlers.PrayerRequest
+open System
+open System.Threading.Tasks
open Giraffe
open Microsoft.AspNetCore.Http
open NodaTime
open PrayerTracker
open PrayerTracker.Entities
open PrayerTracker.ViewModels
-open System
-open System.Threading.Tasks
/// Retrieve a prayer request, and ensure that it belongs to the current class
let private findRequest (ctx : HttpContext) reqId = task {
- match! ctx.db.TryRequestById reqId with
- | Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> return Ok req
- | Some _ ->
- let s = Views.I18N.localizer.Force ()
- addError ctx s.["The prayer request you tried to access is not assigned to your group"]
- return Error (redirectTo false "/web/unauthorized")
- | None -> return Error fourOhFour
- }
+ match! ctx.db.TryRequestById reqId with
+ | Some req when req.smallGroupId = (currentGroup ctx).smallGroupId -> return Ok req
+ | Some _ ->
+ let s = Views.I18N.localizer.Force ()
+ addError ctx s["The prayer request you tried to access is not assigned to your group"]
+ return Error (redirectTo false "/web/unauthorized")
+ | None -> return Error fourOhFour
+}
/// Generate a list of requests for the given date
-let private generateRequestList ctx date =
- let grp = currentGroup ctx
- let clock = ctx.GetService ()
- let listDate =
- match date with
- | Some d -> d
- | None -> grp.localDateNow clock
- let reqs = ctx.db.AllRequestsForSmallGroup grp clock (Some listDate) true 0
- { requests = reqs |> List.ofSeq
- date = listDate
- listGroup = grp
- showHeader = true
- canEmail = ctx.Session.user |> Option.isSome
- recipients = []
- }
+let private generateRequestList ctx date = task {
+ let grp = currentGroup ctx
+ let clock = ctx.GetService ()
+ let listDate = match date with Some d -> d | None -> grp.localDateNow clock
+ let! reqs = ctx.db.AllRequestsForSmallGroup grp clock (Some listDate) true 0
+ return
+ { requests = reqs |> List.ofSeq
+ date = listDate
+ listGroup = grp
+ showHeader = true
+ canEmail = ctx.Session.user |> Option.isSome
+ recipients = []
+ }
+}
/// Parse a string into a date (optionally, of course)
let private parseListDate (date : string option) =
- match date with
- | Some dt -> match DateTime.TryParse dt with true, d -> Some d | false, _ -> None
- | None -> None
+ match date with
+ | Some dt -> match DateTime.TryParse dt with true, d -> Some d | false, _ -> None
+ | None -> None
/// GET /prayer-request/[request-id]/edit
-let edit (reqId : PrayerRequestId) : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx -> task {
+let edit (reqId : PrayerRequestId) : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx
let now = grp.localDateNow (ctx.GetService ())
- match reqId = Guid.Empty with
- | true ->
+ if reqId = Guid.Empty then
return!
- { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
- |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx
- |> renderHtml next ctx
- | false ->
+ { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
+ |> Views.PrayerRequest.edit EditRequest.empty (now.ToString "yyyy-MM-dd") ctx
+ |> renderHtml next ctx
+ else
match! findRequest ctx reqId with
| Ok req ->
let s = Views.I18N.localizer.Force ()
- match req.isExpired now grp.preferences.daysToExpire with
- | true ->
+ if req.isExpired now grp.preferences.daysToExpire then
{ UserMessage.warning with
- text = htmlLocString s.["This request is expired."]
+ text = htmlLocString s["This request is expired."]
description =
- s.["To make it active again, update it as necessary, leave “{0}” and “{1}” unchecked, and it will return as an active request.",
- s.["Expire Immediately"], s.["Check to not update the date"]]
- |> (htmlLocString >> Some)
+ s["To make it active again, update it as necessary, leave “{0}” and “{1}” unchecked, and it will return as an active request.",
+ s["Expire Immediately"], s["Check to not update the date"]]
+ |> (htmlLocString >> Some)
}
|> addUserMessage ctx
- | false -> ()
return!
- { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
- |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx
- |> renderHtml next ctx
+ { viewInfo ctx startTicks with script = [ "ckeditor/ckeditor" ]; helpLink = Some Help.editRequest }
+ |> Views.PrayerRequest.edit (EditRequest.fromRequest req) "" ctx
+ |> renderHtml next ctx
| Error e -> return! e next ctx
- }
+}
/// 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 startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force ()
let listDate = parseListDate (Some date)
let grp = currentGroup ctx
- let list = generateRequestList ctx listDate
+ let! list = generateRequestList ctx listDate
let! recipients = ctx.db.AllMembersForSmallGroup grp.smallGroupId
use! client = Email.getConnection ()
do! Email.sendEmails client recipients
- grp s.["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value
+ grp s["Prayer Requests for {0} - {1:MMMM d, yyyy}", grp.name, list.date].Value
(list.asHtml s) (list.asText s) s
return!
- viewInfo ctx startTicks
- |> Views.PrayerRequest.email { list with recipients = recipients }
- |> renderHtml next ctx
- }
+ viewInfo ctx startTicks
+ |> Views.PrayerRequest.email { list with recipients = recipients }
+ |> renderHtml next ctx
+}
/// 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 {
match! findRequest ctx reqId with
| Ok req ->
let s = Views.I18N.localizer.Force ()
ctx.db.PrayerRequests.Remove req |> ignore
let! _ = ctx.db.SaveChangesAsync ()
- addInfo ctx s.["The prayer request was deleted successfully"]
+ addInfo ctx s["The prayer request was deleted successfully"]
return! redirectTo false "/web/prayer-requests" next ctx
| Error e -> return! e next ctx
- }
+}
/// 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 {
match! findRequest ctx reqId with
| Ok req ->
let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with expiration = Forced }
let! _ = ctx.db.SaveChangesAsync ()
- addInfo ctx s.["Successfully {0} prayer request", s.["Expired"].Value.ToLower ()]
+ addInfo ctx s["Successfully {0} prayer request", s["Expired"].Value.ToLower ()]
return! redirectTo false "/web/prayer-requests" next ctx
| Error e -> return! e next ctx
- }
+}
/// GET /prayer-requests/[group-id]/list
-let list groupId : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx -> task {
+let list groupId : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
match! ctx.db.TryGroupById groupId with
| Some grp when grp.preferences.isPublic ->
let clock = ctx.GetService ()
- let reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0
+ let! reqs = ctx.db.AllRequestsForSmallGroup grp clock None true 0
return!
- viewInfo ctx startTicks
- |> Views.PrayerRequest.list
- { requests = List.ofSeq reqs
- date = grp.localDateNow clock
- listGroup = grp
- showHeader = true
- canEmail = ctx.Session.user |> Option.isSome
- recipients = []
+ viewInfo ctx startTicks
+ |> Views.PrayerRequest.list
+ { requests = reqs
+ date = grp.localDateNow clock
+ listGroup = grp
+ showHeader = true
+ canEmail = ctx.Session.user |> Option.isSome
+ recipients = []
}
- |> renderHtml next ctx
+ |> renderHtml next ctx
| Some _ ->
let s = Views.I18N.localizer.Force ()
- addError ctx s.["The request list for the group you tried to view is not public."]
+ addError ctx s["The request list for the group you tried to view is not public."]
return! redirectTo false "/web/unauthorized" next ctx
| None -> return! fourOhFour next ctx
- }
+}
/// GET /prayer-requests/lists
-let lists : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx -> task {
+let lists : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
- let! grps = ctx.db.PublicAndProtectedGroups ()
+ let! groups = ctx.db.PublicAndProtectedGroups ()
return!
- viewInfo ctx startTicks
- |> Views.PrayerRequest.lists grps
- |> renderHtml next ctx
- }
+ viewInfo ctx startTicks
+ |> Views.PrayerRequest.lists groups
+ |> renderHtml next ctx
+}
/// GET /prayer-requests[/inactive?]
/// - OR -
/// GET /prayer-requests?search=[search-query]
-let maintain onlyActive : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx ->
+let maintain onlyActive : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx
let pageNbr =
- match ctx.GetQueryStringValue "page" with
- | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1
- | Error _ -> 1
- let m =
- match ctx.GetQueryStringValue "search" with
- | Ok srch ->
- { MaintainRequests.empty with
- requests = ctx.db.SearchRequestsForSmallGroup grp srch pageNbr
- searchTerm = Some srch
- pageNbr = Some pageNbr
- }
- | Error _ ->
- { MaintainRequests.empty with
- requests = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService ()) None onlyActive pageNbr
- onlyActive = Some onlyActive
- pageNbr = match onlyActive with true -> None | false -> Some pageNbr
- }
- { viewInfo ctx startTicks with helpLink = Some Help.maintainRequests }
- |> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx
- |> renderHtml next ctx
-
+ match ctx.GetQueryStringValue "page" with
+ | Ok pg -> match Int32.TryParse pg with true, p -> p | false, _ -> 1
+ | Error _ -> 1
+ let! m = backgroundTask {
+ match ctx.GetQueryStringValue "search" with
+ | Ok search ->
+ let! reqs = ctx.db.SearchRequestsForSmallGroup grp search pageNbr
+ return
+ { MaintainRequests.empty with
+ requests = reqs
+ searchTerm = Some search
+ pageNbr = Some pageNbr
+ }
+ | Error _ ->
+ let! reqs = ctx.db.AllRequestsForSmallGroup grp (ctx.GetService ()) None onlyActive pageNbr
+ return
+ { MaintainRequests.empty with
+ requests = reqs
+ onlyActive = Some onlyActive
+ pageNbr = match onlyActive with true -> None | false -> Some pageNbr
+ }
+ }
+ return!
+ { viewInfo ctx startTicks with helpLink = Some Help.maintainRequests }
+ |> Views.PrayerRequest.maintain { m with smallGroup = grp } ctx
+ |> renderHtml next ctx
+}
/// GET /prayer-request/print/[date]
-let print date : HttpHandler =
- requireAccess [ User; Group ]
- >=> fun next ctx ->
- let list = parseListDate (Some date) |> generateRequestList ctx
- Views.PrayerRequest.print list appVersion
- |> renderHtml next ctx
+let print date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task {
+ let! list = generateRequestList ctx (parseListDate (Some date))
+ return!
+ Views.PrayerRequest.print list appVersion
+ |> renderHtml next ctx
+}
/// 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 {
match! findRequest ctx reqId with
| Ok req ->
let s = Views.I18N.localizer.Force ()
ctx.db.UpdateEntry { req with expiration = Automatic; updatedDate = DateTime.Now }
let! _ = ctx.db.SaveChangesAsync ()
- addInfo ctx s.["Successfully {0} prayer request", s.["Restored"].Value.ToLower ()]
+ addInfo ctx s["Successfully {0} prayer request", s["Restored"].Value.ToLower ()]
return! redirectTo false "/web/prayer-requests" next ctx
| Error e -> return! e next ctx
- }
+}
/// 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 () with
| Ok m ->
let! req =
- match m.isNew () with
- | true -> Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () })
- | false -> ctx.db.TryRequestById m.requestId
+ if m.isNew () then Task.FromResult (Some { PrayerRequest.empty with prayerRequestId = Guid.NewGuid () })
+ else ctx.db.TryRequestById m.requestId
match req with
| Some pr ->
let upd8 =
- { pr with
- requestType = PrayerRequestType.fromCode m.requestType
- requestor = match m.requestor with Some x when x.Trim () = "" -> None | x -> x
- text = ckEditorToText m.text
- expiration = Expiration.fromCode m.expiration
+ { pr with
+ requestType = PrayerRequestType.fromCode m.requestType
+ requestor = match m.requestor with Some x when x.Trim () = "" -> None | x -> x
+ text = ckEditorToText m.text
+ expiration = Expiration.fromCode m.expiration
}
let grp = currentGroup ctx
let now = grp.localDateNow (ctx.GetService ())
@@ -262,23 +243,23 @@ let save : HttpHandler =
}
| false when Option.isSome m.skipDateUpdate && Option.get m.skipDateUpdate -> upd8
| false -> { upd8 with updatedDate = now }
- |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
+ |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
- let act = match m.isNew () with true -> "Added" | false -> "Updated"
- addInfo ctx s.["Successfully {0} prayer request", s.[act].Value.ToLower ()]
+ let act = if m.isNew () then "Added" else "Updated"
+ addInfo ctx s["Successfully {0} prayer request", s.[act].Value.ToLower ()]
return! redirectTo false "/web/prayer-requests" next ctx
| None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx
- }
+}
/// GET /prayer-request/view/[date?]
-let view date : HttpHandler =
- requireAccess [ User; Group ]
- >=> fun next ctx ->
- let startTicks = DateTime.Now.Ticks
- let list = parseListDate date |> generateRequestList ctx
- viewInfo ctx startTicks
- |> Views.PrayerRequest.view { list with showHeader = false }
- |> renderHtml next ctx
+let view date : HttpHandler = requireAccess [ User; Group ] >=> fun next ctx -> task {
+ let startTicks = DateTime.Now.Ticks
+ let! list = generateRequestList ctx (parseListDate date)
+ return!
+ viewInfo ctx startTicks
+ |> Views.PrayerRequest.view { list with showHeader = false }
+ |> renderHtml next ctx
+}
diff --git a/src/PrayerTracker/SmallGroup.fs b/src/PrayerTracker/SmallGroup.fs
index 442067d..07171a8 100644
--- a/src/PrayerTracker/SmallGroup.fs
+++ b/src/PrayerTracker/SmallGroup.fs
@@ -14,25 +14,20 @@ open System.Threading.Tasks
/// Set a small group "Remember Me" cookie
let private setGroupCookie (ctx : HttpContext) pwHash =
- ctx.Response.Cookies.Append
- (Key.Cookie.group, { GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (), autoRefresh)
+ ctx.Response.Cookies.Append
+ (Key.Cookie.group, { GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (),
+ autoRefresh)
/// GET /small-group/announcement
-let announcement : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx ->
- let startTicks = DateTime.Now.Ticks
- { viewInfo ctx startTicks with helpLink = Some Help.sendAnnouncement; script = [ "ckeditor/ckeditor" ] }
+let announcement : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
+ { viewInfo ctx DateTime.Now.Ticks with helpLink = Some Help.sendAnnouncement; script = [ "ckeditor/ckeditor" ] }
|> Views.SmallGroup.announcement (currentUser ctx).isAdmin ctx
|> renderHtml next ctx
/// POST /small-group/[group-id]/delete
-let delete groupId : HttpHandler =
- requireAccess [ Admin ]
- >=> validateCSRF
- >=> fun next ctx -> task {
+let delete groupId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
let s = Views.I18N.localizer.Force ()
match! ctx.db.TryGroupById groupId with
| Some grp ->
@@ -41,103 +36,86 @@ let delete groupId : HttpHandler =
ctx.db.RemoveEntry grp
let! _ = ctx.db.SaveChangesAsync ()
addInfo ctx
- s.["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)",
- grp.name, reqs, usrs]
+ s["The group {0} and its {1} prayer request(s) were deleted successfully; revoked access from {2} user(s)",
+ grp.name, reqs, usrs]
return! redirectTo false "/web/small-groups" next ctx
| None -> return! fourOhFour next ctx
- }
+}
/// POST /small-group/member/[member-id]/delete
-let deleteMember memberId : HttpHandler =
- requireAccess [ User ]
- >=> validateCSRF
- >=> fun next ctx -> task {
+let deleteMember memberId : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
let s = Views.I18N.localizer.Force ()
match! ctx.db.TryMemberById memberId with
| Some mbr when mbr.smallGroupId = (currentGroup ctx).smallGroupId ->
ctx.db.RemoveEntry mbr
let! _ = ctx.db.SaveChangesAsync ()
- addHtmlInfo ctx s.["The group member “{0}” was deleted successfully", mbr.memberName]
+ addHtmlInfo ctx s["The group member “{0}” was deleted successfully", mbr.memberName]
return! redirectTo false "/web/small-group/members" next ctx
| Some _
| None -> return! fourOhFour next ctx
- }
+}
/// GET /small-group/[group-id]/edit
-let edit (groupId : SmallGroupId) : HttpHandler =
- requireAccess [ Admin ]
- >=> fun next ctx -> task {
+let edit (groupId : SmallGroupId) : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let! churches = ctx.db.AllChurches ()
- match groupId = Guid.Empty with
- | true ->
+ if groupId = Guid.Empty then
return!
- viewInfo ctx startTicks
- |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
- |> renderHtml next ctx
- | false ->
+ viewInfo ctx startTicks
+ |> Views.SmallGroup.edit EditSmallGroup.empty churches ctx
+ |> renderHtml next ctx
+ else
match! ctx.db.TryGroupById groupId with
| Some grp ->
return!
- viewInfo ctx startTicks
- |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx
- |> renderHtml next ctx
+ viewInfo ctx startTicks
+ |> Views.SmallGroup.edit (EditSmallGroup.fromGroup grp) churches ctx
+ |> renderHtml next ctx
| None -> return! fourOhFour next ctx
- }
+}
/// GET /small-group/member/[member-id]/edit
-let editMember (memberId : MemberId) : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx ->
+let editMember (memberId : MemberId) : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let s = Views.I18N.localizer.Force ()
let grp = currentGroup ctx
let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s
- task {
- match memberId = Guid.Empty with
- | true ->
- return!
+ if memberId = Guid.Empty then
+ return!
viewInfo ctx startTicks
|> Views.SmallGroup.editMember EditMember.empty typs ctx
|> renderHtml next ctx
- | false ->
- match! ctx.db.TryMemberById memberId with
- | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
- return!
+ else
+ match! ctx.db.TryMemberById memberId with
+ | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
+ return!
viewInfo ctx startTicks
|> Views.SmallGroup.editMember (EditMember.fromMember mbr) typs ctx
|> renderHtml next ctx
- | Some _
- | None -> return! fourOhFour next ctx
- }
+ | Some _
+ | None -> return! fourOhFour next ctx
+}
/// GET /small-group/log-on/[group-id?]
-let logOn (groupId : SmallGroupId option) : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx ->
+let logOn (groupId : SmallGroupId option) : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
- task {
- let! grps = ctx.db.ProtectedGroups ()
- let grpId = match groupId with Some gid -> flatGuid gid | None -> ""
- return!
+ let! grps = ctx.db.ProtectedGroups ()
+ let grpId = match groupId with Some gid -> flatGuid gid | None -> ""
+ return!
{ viewInfo ctx startTicks with helpLink = Some Help.logOn }
|> Views.SmallGroup.logOn grps grpId ctx
|> renderHtml next ctx
- }
+}
/// POST /small-group/log-on/submit
-let logOnSubmit : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> validateCSRF
- >=> fun next ctx ->
- task {
- match! ctx.TryBindFormAsync () with
- | Ok m ->
+let logOnSubmit : HttpHandler = requireAccess [ AccessLevel.Public ] >=> validateCSRF >=> fun next ctx -> task {
+ match! ctx.TryBindFormAsync () with
+ | Ok m ->
let s = Views.I18N.localizer.Force ()
match! ctx.db.TryGroupLogOnByPassword m.smallGroupId m.password with
| Some grp ->
@@ -145,241 +123,206 @@ let logOnSubmit : HttpHandler =
match m.rememberMe with
| Some x when x -> (setGroupCookie ctx << sha1Hash) m.password
| _ -> ()
- addInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]]
+ addInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
return! redirectTo false "/web/prayer-requests/view" next ctx
| None ->
- addError ctx s.["Password incorrect - login unsuccessful"]
+ addError ctx s["Password incorrect - login unsuccessful"]
return! redirectTo false $"/web/small-group/log-on/{flatGuid m.smallGroupId}" next ctx
- | Error e -> return! bindError e next ctx
- }
+ | Error e -> return! bindError e next ctx
+}
/// GET /small-groups
-let maintain : HttpHandler =
- requireAccess [ Admin ]
- >=> fun next ctx ->
+let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
- task {
- let! grps = ctx.db.AllGroups ()
- return!
+ let! grps = ctx.db.AllGroups ()
+ return!
viewInfo ctx startTicks
|> Views.SmallGroup.maintain grps ctx
|> renderHtml next ctx
- }
+}
/// GET /small-group/members
-let members : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx ->
+let members : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let grp = currentGroup ctx
let s = Views.I18N.localizer.Force ()
- task {
- let! mbrs = ctx.db.AllMembersForSmallGroup grp.smallGroupId
- let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s |> Map.ofSeq
- return!
+ let! mbrs = ctx.db.AllMembersForSmallGroup grp.smallGroupId
+ let typs = ReferenceList.emailTypeList grp.preferences.defaultEmailType s |> Map.ofSeq
+ return!
{ viewInfo ctx startTicks with helpLink = Some Help.maintainGroupMembers }
|> Views.SmallGroup.members mbrs typs ctx
|> renderHtml next ctx
- }
+}
/// GET /small-group
-let overview : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx ->
- let startTicks = DateTime.Now.Ticks
- let clock = ctx.GetService ()
- task {
- let reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0 |> List.ofSeq
- let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId
- let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId
- let m =
+let overview : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
+ let startTicks = DateTime.Now.Ticks
+ let clock = ctx.GetService ()
+ let! reqs = ctx.db.AllRequestsForSmallGroup (currentGroup ctx) clock None true 0
+ let! reqCount = ctx.db.CountRequestsBySmallGroup (currentGroup ctx).smallGroupId
+ let! mbrCount = ctx.db.CountMembersForSmallGroup (currentGroup ctx).smallGroupId
+ let m =
{ totalActiveReqs = List.length reqs
allReqs = reqCount
totalMbrs = mbrCount
activeReqsByCat =
- (reqs
- |> Seq.ofList
- |> Seq.map (fun req -> req.requestType)
- |> Seq.distinct
- |> Seq.map (fun reqType -> reqType, reqs |> List.filter (fun r -> r.requestType = reqType) |> List.length)
- |> Map.ofSeq)
+ (reqs
+ |> Seq.ofList
+ |> Seq.map (fun req -> req.requestType)
+ |> Seq.distinct
+ |> Seq.map (fun reqType -> reqType, reqs |> List.filter (fun r -> r.requestType = reqType) |> List.length)
+ |> Map.ofSeq)
}
- return!
+ return!
viewInfo ctx startTicks
|> Views.SmallGroup.overview m
|> renderHtml next ctx
- }
+}
/// GET /small-group/preferences
-let preferences : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx ->
- let startTicks = DateTime.Now.Ticks
- task {
- let! tzs = ctx.db.AllTimeZones ()
- return!
+let preferences : HttpHandler = requireAccess [ User ] >=> fun next ctx -> task {
+ let startTicks = DateTime.Now.Ticks
+ let! tzs = ctx.db.AllTimeZones ()
+ return!
{ viewInfo ctx startTicks with helpLink = Some Help.groupPreferences }
|> Views.SmallGroup.preferences (EditPreferences.fromPreferences (currentGroup ctx).preferences) tzs ctx
|> renderHtml next ctx
- }
+}
/// POST /small-group/save
-let save : HttpHandler =
- requireAccess [ Admin ]
- >=> validateCSRF
- >=> fun next ctx ->
- let s = Views.I18N.localizer.Force ()
- task {
- match! ctx.TryBindFormAsync () with
- | Ok m ->
- let! group =
- match m.isNew () with
- | true -> Task.FromResult(Some { SmallGroup.empty with smallGroupId = Guid.NewGuid () })
- | false -> ctx.db.TryGroupById m.smallGroupId
- match group with
- | Some grp ->
- m.populateGroup grp
- |> function
- | grp when m.isNew () ->
- ctx.db.AddEntry grp
- ctx.db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId }
- | grp -> ctx.db.UpdateEntry grp
- let! _ = ctx.db.SaveChangesAsync ()
- let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower ()
- addHtmlInfo ctx s.["Successfully {0} group “{1}”", act, m.name]
- return! redirectTo false "/web/small-groups" next ctx
- | None -> return! fourOhFour next ctx
- | Error e -> return! bindError e next ctx
- }
+let save : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
+ match! ctx.TryBindFormAsync () with
+ | Ok m ->
+ let s = Views.I18N.localizer.Force ()
+ let! group =
+ if m.isNew () then Task.FromResult (Some { SmallGroup.empty with smallGroupId = Guid.NewGuid () })
+ else ctx.db.TryGroupById m.smallGroupId
+ match group with
+ | Some grp ->
+ m.populateGroup grp
+ |> function
+ | grp when m.isNew () ->
+ ctx.db.AddEntry grp
+ ctx.db.AddEntry { grp.preferences with smallGroupId = grp.smallGroupId }
+ | grp -> ctx.db.UpdateEntry grp
+ let! _ = ctx.db.SaveChangesAsync ()
+ let act = s[if m.isNew () then "Added" else "Updated"].Value.ToLower ()
+ addHtmlInfo ctx s["Successfully {0} group “{1}”", act, m.name]
+ return! redirectTo false "/web/small-groups" next ctx
+ | None -> return! fourOhFour next ctx
+ | Error e -> return! bindError e next ctx
+}
/// POST /small-group/member/save
-let saveMember : HttpHandler =
- requireAccess [ User ]
- >=> validateCSRF
- >=> fun next ctx ->
- task {
- match! ctx.TryBindFormAsync () with
- | Ok m ->
- let grp = currentGroup ctx
- let! mMbr =
- match m.isNew () with
- | true ->
- Task.FromResult
- (Some
- { Member.empty with
- memberId = Guid.NewGuid ()
- smallGroupId = grp.smallGroupId
- })
- | false -> ctx.db.TryMemberById m.memberId
- match mMbr with
- | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
- { mbr with
- memberName = m.memberName
- email = m.emailAddress
- format = match m.emailType with "" | null -> None | _ -> Some m.emailType
- }
- |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
- let! _ = ctx.db.SaveChangesAsync ()
- let s = Views.I18N.localizer.Force ()
- let act = s.[match m.isNew () with true -> "Added" | false -> "Updated"].Value.ToLower ()
- addInfo ctx s.["Successfully {0} group member", act]
- return! redirectTo false "/web/small-group/members" next ctx
- | Some _
- | None -> return! fourOhFour next ctx
- | Error e -> return! bindError e next ctx
- }
+let saveMember : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
+ match! ctx.TryBindFormAsync () with
+ | Ok m ->
+ let grp = currentGroup ctx
+ let! mMbr =
+ if m.isNew () then
+ Task.FromResult (Some { Member.empty with memberId = Guid.NewGuid (); smallGroupId = grp.smallGroupId })
+ else ctx.db.TryMemberById m.memberId
+ match mMbr with
+ | Some mbr when mbr.smallGroupId = grp.smallGroupId ->
+ { mbr with
+ memberName = m.memberName
+ email = m.emailAddress
+ format = match m.emailType with "" | null -> None | _ -> Some m.emailType
+ }
+ |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
+ let! _ = ctx.db.SaveChangesAsync ()
+ let s = Views.I18N.localizer.Force ()
+ let act = s[if m.isNew () then "Added" else "Updated"].Value.ToLower ()
+ addInfo ctx s["Successfully {0} group member", act]
+ return! redirectTo false "/web/small-group/members" next ctx
+ | Some _
+ | None -> return! fourOhFour next ctx
+ | Error e -> return! bindError e next ctx
+}
/// POST /small-group/preferences/save
-let savePreferences : HttpHandler =
- requireAccess [ User ]
- >=> validateCSRF
- >=> fun next ctx ->
- task {
- match! ctx.TryBindFormAsync () with
- | Ok m ->
- // Since the class is stored in the session, we'll use an intermediate instance to persist it; once that
- // works, we can repopulate the session instance. That way, if the update fails, the page should still show
- // the database values, not the then out-of-sync session ones.
- match! ctx.db.TryGroupById (currentGroup ctx).smallGroupId with
- | Some grp ->
- let prefs = m.populatePreferences grp.preferences
- ctx.db.UpdateEntry prefs
- let! _ = ctx.db.SaveChangesAsync ()
- // Refresh session instance
- ctx.Session.smallGroup <- Some { grp with preferences = prefs }
- let s = Views.I18N.localizer.Force ()
- addInfo ctx s.["Group preferences updated successfully"]
- return! redirectTo false "/web/small-group/preferences" next ctx
- | None -> return! fourOhFour next ctx
- | Error e -> return! bindError e next ctx
- }
+let savePreferences : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
+ match! ctx.TryBindFormAsync () with
+ | Ok m ->
+ // Since the class is stored in the session, we'll use an intermediate instance to persist it; once that works,
+ // we can repopulate the session instance. That way, if the update fails, the page should still show the
+ // database values, not the then out-of-sync session ones.
+ match! ctx.db.TryGroupById (currentGroup ctx).smallGroupId with
+ | Some grp ->
+ let prefs = m.populatePreferences grp.preferences
+ ctx.db.UpdateEntry prefs
+ let! _ = ctx.db.SaveChangesAsync ()
+ // Refresh session instance
+ ctx.Session.smallGroup <- Some { grp with preferences = prefs }
+ let s = Views.I18N.localizer.Force ()
+ addInfo ctx s["Group preferences updated successfully"]
+ return! redirectTo false "/web/small-group/preferences" next ctx
+ | None -> return! fourOhFour next ctx
+ | Error e -> return! bindError e next ctx
+}
/// POST /small-group/announcement/send
-let sendAnnouncement : HttpHandler =
- requireAccess [ User ]
- >=> validateCSRF
- >=> fun next ctx ->
+let sendAnnouncement : HttpHandler = requireAccess [ User ] >=> validateCSRF >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
- task {
- match! ctx.TryBindFormAsync () with
- | Ok m ->
- let grp = currentGroup ctx
- let usr = currentUser ctx
- let now = grp.localTimeNow (ctx.GetService ())
- let s = Views.I18N.localizer.Force ()
- // Reformat the text to use the class's font stylings
- let requestText = ckEditorToText m.text
- let htmlText =
+ match! ctx.TryBindFormAsync () with
+ | Ok m ->
+ let grp = currentGroup ctx
+ let usr = currentUser ctx
+ let now = grp.localTimeNow (ctx.GetService ())
+ let s = Views.I18N.localizer.Force ()
+ // Reformat the text to use the class's font stylings
+ let requestText = ckEditorToText m.text
+ let htmlText =
p [ _style $"font-family:{grp.preferences.listFonts};font-size:%d{grp.preferences.textFontSize}pt;" ]
[ rawText requestText ]
|> renderHtmlNode
- let plainText = (htmlToPlainText >> wordWrap 74) htmlText
- // Send the e-mails
- let! recipients =
+ let plainText = (htmlToPlainText >> wordWrap 74) htmlText
+ // Send the e-mails
+ let! recipients =
match m.sendToClass with
| "N" when usr.isAdmin -> ctx.db.AllUsersAsMembers ()
| _ -> ctx.db.AllMembersForSmallGroup grp.smallGroupId
- use! client = Email.getConnection ()
- do! Email.sendEmails client recipients grp
- s.["Announcement for {0} - {1:MMMM d, yyyy} {2}",
- grp.name, now.Date, (now.ToString "h:mm tt").ToLower ()].Value
+ use! client = Email.getConnection ()
+ do! Email.sendEmails client recipients grp
+ s["Announcement for {0} - {1:MMMM d, yyyy} {2}", grp.name, now.Date,
+ (now.ToString "h:mm tt").ToLower ()].Value
htmlText plainText s
- // Add to the request list if desired
- match m.sendToClass, m.addToRequestList with
- | "N", _
- | _, None -> ()
- | _, Some x when not x -> ()
- | _, _ ->
- { PrayerRequest.empty with
- prayerRequestId = Guid.NewGuid ()
- smallGroupId = grp.smallGroupId
- userId = usr.userId
- requestType = (Option.get >> PrayerRequestType.fromCode) m.requestType
- text = requestText
- enteredDate = now
- updatedDate = now
- }
- |> ctx.db.AddEntry
- let! _ = ctx.db.SaveChangesAsync ()
- ()
- // Tell 'em what they've won, Johnny!
- let toWhom =
+ // Add to the request list if desired
+ match m.sendToClass, m.addToRequestList with
+ | "N", _
+ | _, None -> ()
+ | _, Some x when not x -> ()
+ | _, _ ->
+ { PrayerRequest.empty with
+ prayerRequestId = Guid.NewGuid ()
+ smallGroupId = grp.smallGroupId
+ userId = usr.userId
+ requestType = (Option.get >> PrayerRequestType.fromCode) m.requestType
+ text = requestText
+ enteredDate = now
+ updatedDate = now
+ }
+ |> ctx.db.AddEntry
+ let! _ = ctx.db.SaveChangesAsync ()
+ ()
+ // Tell 'em what they've won, Johnny!
+ let toWhom =
match m.sendToClass with
- | "N" -> s.["{0} users", s.["PrayerTracker"]].Value
- | _ -> s.["Group Members"].Value.ToLower ()
- let andAdded = match m.addToRequestList with Some x when x -> "and added it to the request list" | _ -> ""
- addInfo ctx s.["Successfully sent announcement to all {0} {1}", toWhom, s.[andAdded]]
- return!
+ | "N" -> s["{0} users", s["PrayerTracker"]].Value
+ | _ -> s["Group Members"].Value.ToLower ()
+ let andAdded = match m.addToRequestList with Some x when x -> "and added it to the request list" | _ -> ""
+ addInfo ctx s["Successfully sent announcement to all {0} {1}", toWhom, s[andAdded]]
+ return!
viewInfo ctx startTicks
|> Views.SmallGroup.announcementSent { m with text = htmlText }
|> renderHtml next ctx
- | Error e -> return! bindError e next ctx
- }
+ | Error e -> return! bindError e next ctx
+}
diff --git a/src/PrayerTracker/User.fs b/src/PrayerTracker/User.fs
index 39390d9..f73d783 100644
--- a/src/PrayerTracker/User.fs
+++ b/src/PrayerTracker/User.fs
@@ -1,5 +1,9 @@
module PrayerTracker.Handlers.User
+open System
+open System.Collections.Generic
+open System.Net
+open System.Threading.Tasks
open Giraffe
open Microsoft.AspNetCore.Html
open Microsoft.AspNetCore.Http
@@ -8,275 +12,244 @@ open PrayerTracker.Cookies
open PrayerTracker.Entities
open PrayerTracker.ViewModels
open PrayerTracker.Views.CommonFunctions
-open System
-open System.Collections.Generic
-open System.Net
-open System.Threading.Tasks
/// Set the user's "remember me" cookie
let private setUserCookie (ctx : HttpContext) pwHash =
- ctx.Response.Cookies.Append (
- Key.Cookie.user,
- { Id = (currentUser ctx).userId; GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (),
- autoRefresh)
+ ctx.Response.Cookies.Append (
+ Key.Cookie.user,
+ { Id = (currentUser ctx).userId; GroupId = (currentGroup ctx).smallGroupId; PasswordHash = pwHash }.toPayload (),
+ autoRefresh)
/// Retrieve a user from the database by password
// If the hashes do not match, determine if it matches a previous scheme, and upgrade them if it does
let private findUserByPassword m (db : AppDbContext) = task {
- match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with
- | Some u when Option.isSome u.salt ->
- // Already upgraded; match = success
- let pwHash = pbkdf2Hash (Option.get u.salt) m.password
- match u.passwordHash = pwHash with
- | true -> return Some { u with passwordHash = ""; salt = None; smallGroups = List() }, pwHash
- | _ -> return None, ""
- | Some u when u.passwordHash = sha1Hash m.password ->
- // Not upgraded, but password is good; upgrade 'em!
- // Upgrade 'em!
- let salt = Guid.NewGuid ()
- let pwHash = pbkdf2Hash salt m.password
- let upgraded = { u with salt = Some salt; passwordHash = pwHash }
- db.UpdateEntry upgraded
- let! _ = db.SaveChangesAsync ()
- return Some { u with passwordHash = ""; salt = None; smallGroups = List() }, pwHash
- | _ -> return None, ""
- }
+ match! db.TryUserByEmailAndGroup m.emailAddress m.smallGroupId with
+ | Some u when Option.isSome u.salt ->
+ // Already upgraded; match = success
+ let pwHash = pbkdf2Hash (Option.get u.salt) m.password
+ if u.passwordHash = pwHash then
+ return Some { u with passwordHash = ""; salt = None; smallGroups = List() }, pwHash
+ else return None, ""
+ | Some u when u.passwordHash = sha1Hash m.password ->
+ // Not upgraded, but password is good; upgrade 'em!
+ // Upgrade 'em!
+ let salt = Guid.NewGuid ()
+ let pwHash = pbkdf2Hash salt m.password
+ let upgraded = { u with salt = Some salt; passwordHash = pwHash }
+ db.UpdateEntry upgraded
+ let! _ = db.SaveChangesAsync ()
+ return Some { u with passwordHash = ""; salt = None; smallGroups = List() }, pwHash
+ | _ -> return None, ""
+}
/// 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 () with
| Ok m ->
let s = Views.I18N.localizer.Force ()
let curUsr = currentUser ctx
let! dbUsr = ctx.db.TryUserById curUsr.userId
let! user =
- match dbUsr with
- | Some usr ->
- // Check the old password against a possibly non-salted hash
- (match usr.salt with | Some salt -> pbkdf2Hash salt | _ -> sha1Hash) m.oldPassword
- |> ctx.db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId
- | _ -> Task.FromResult None
+ match dbUsr with
+ | Some usr ->
+ // Check the old password against a possibly non-salted hash
+ (match usr.salt with Some salt -> pbkdf2Hash salt | None -> sha1Hash) m.oldPassword
+ |> ctx.db.TryUserLogOnByCookie curUsr.userId (currentGroup ctx).smallGroupId
+ | _ -> Task.FromResult None
match user with
| Some _ when m.newPassword = m.newPasswordConfirm ->
match dbUsr with
| Some usr ->
- // Generate salt if it has not been already
- let salt = match usr.salt with Some s -> s | _ -> Guid.NewGuid ()
+ // Generate new salt whenever the password is changed
+ let salt = Guid.NewGuid ()
ctx.db.UpdateEntry { usr with passwordHash = pbkdf2Hash salt m.newPassword; salt = Some salt }
let! _ = ctx.db.SaveChangesAsync ()
// If the user is remembered, update the cookie with the new hash
- match ctx.Request.Cookies.Keys.Contains Key.Cookie.user with
- | true -> setUserCookie ctx usr.passwordHash
- | _ -> ()
- addInfo ctx s.["Your password was changed successfully"]
- | None -> addError ctx s.["Unable to change password"]
+ if ctx.Request.Cookies.Keys.Contains Key.Cookie.user then setUserCookie ctx usr.passwordHash
+ addInfo ctx s["Your password was changed successfully"]
+ | None -> addError ctx s["Unable to change password"]
return! redirectTo false "/web/" next ctx
| Some _ ->
- addError ctx s.["The new passwords did not match - your password was NOT changed"]
+ addError ctx s["The new passwords did not match - your password was NOT changed"]
return! redirectTo false "/web/user/password" next ctx
| None ->
- addError ctx s.["The old password was incorrect - your password was NOT changed"]
+ addError ctx s["The old password was incorrect - your password was NOT changed"]
return! redirectTo false "/web/user/password" next ctx
| Error e -> return! bindError e next ctx
- }
+}
/// POST /user/[user-id]/delete
-let delete userId : HttpHandler =
- requireAccess [ Admin ]
- >=> validateCSRF
- >=> fun next ctx -> task {
+let delete userId : HttpHandler = requireAccess [ Admin ] >=> validateCSRF >=> fun next ctx -> task {
match! ctx.db.TryUserById userId with
| Some user ->
ctx.db.RemoveEntry user
let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
- addInfo ctx s.["Successfully deleted user {0}", user.fullName]
+ addInfo ctx s["Successfully deleted user {0}", user.fullName]
return! redirectTo false "/web/users" next ctx
| _ -> return! fourOhFour next ctx
- }
+}
/// 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 () with
| Ok m ->
let s = Views.I18N.localizer.Force ()
let! usr, pwHash = findUserByPassword m ctx.db
let! grp = ctx.db.TryGroupById m.smallGroupId
let nextUrl =
- match usr with
- | Some _ ->
- ctx.Session.user <- usr
- ctx.Session.smallGroup <- grp
- match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> ()
- addHtmlInfo ctx s.["Log On Successful • Welcome to {0}", s.["PrayerTracker"]]
- match m.redirectUrl with
- | None -> "/web/small-group"
- | Some x when x = "" -> "/web/small-group"
- | Some x -> x
- | _ ->
- let grpName = match grp with Some g -> g.name | _ -> "N/A"
- { UserMessage.error with
- text = htmlLocString s.["Invalid credentials - log on unsuccessful"]
- description =
- [ s.["This is likely due to one of the following reasons"].Value
- ":- "
- s.["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode m.emailAddress].Value
- "
- "
- s.["The password entered does not match the password for the given e-mail address."].Value
- "
- "
- s.["You are not authorized to administer the group “{0}”.", WebUtility.HtmlEncode grpName].Value
- "
"
- ]
- |> String.concat ""
- |> (HtmlString >> Some)
+ match usr with
+ | Some _ ->
+ ctx.Session.user <- usr
+ ctx.Session.smallGroup <- grp
+ match m.rememberMe with Some x when x -> setUserCookie ctx pwHash | _ -> ()
+ addHtmlInfo ctx s["Log On Successful • Welcome to {0}", s["PrayerTracker"]]
+ match m.redirectUrl with
+ | None -> "/web/small-group"
+ | Some x when x = "" -> "/web/small-group"
+ | Some x -> x
+ | _ ->
+ let grpName = match grp with Some g -> g.name | _ -> "N/A"
+ { UserMessage.error with
+ text = htmlLocString s["Invalid credentials - log on unsuccessful"]
+ description =
+ [ s["This is likely due to one of the following reasons"].Value
+ ":- "
+ s["The e-mail address “{0}” is invalid.", WebUtility.HtmlEncode m.emailAddress].Value
+ "
- "
+ s["The password entered does not match the password for the given e-mail address."].Value
+ "
- "
+ s["You are not authorized to administer the group “{0}”.",
+ WebUtility.HtmlEncode grpName].Value
+ "
"
+ ]
+ |> String.concat ""
+ |> (HtmlString >> Some)
}
- |> addUserMessage ctx
- "/web/user/log-on"
+ |> addUserMessage ctx
+ "/web/user/log-on"
return! redirectTo false nextUrl next ctx
| Error e -> return! bindError e next ctx
- }
+}
/// GET /user/[user-id]/edit
-let edit (userId : UserId) : HttpHandler =
- requireAccess [ Admin ]
- >=> fun next ctx -> task {
+let edit (userId : UserId) : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
- match userId = Guid.Empty with
- | true ->
+ if userId = Guid.Empty then
return!
- viewInfo ctx startTicks
- |> Views.User.edit EditUser.empty ctx
- |> renderHtml next ctx
- | false ->
+ viewInfo ctx startTicks
+ |> Views.User.edit EditUser.empty ctx
+ |> renderHtml next ctx
+ else
match! ctx.db.TryUserById userId with
| Some user ->
return!
- viewInfo ctx startTicks
- |> Views.User.edit (EditUser.fromUser user) ctx
- |> renderHtml next ctx
+ viewInfo ctx startTicks
+ |> Views.User.edit (EditUser.fromUser user) ctx
+ |> renderHtml next ctx
| _ -> return! fourOhFour next ctx
- }
+}
/// GET /user/log-on
-let logOn : HttpHandler =
- requireAccess [ AccessLevel.Public ]
- >=> fun next ctx -> task {
- let startTicks = DateTime.Now.Ticks
- let s = Views.I18N.localizer.Force ()
- let! groups = ctx.db.GroupList ()
- let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
+let logOn : HttpHandler = requireAccess [ AccessLevel.Public ] >=> fun next ctx -> task {
+ let startTicks = DateTime.Now.Ticks
+ let s = Views.I18N.localizer.Force ()
+ let! groups = ctx.db.GroupList ()
+ let url = Option.ofObj <| ctx.Session.GetString Key.Session.redirectUrl
match url with
| Some _ ->
ctx.Session.Remove Key.Session.redirectUrl
- addWarning ctx s.["The page you requested requires authentication; please log on below."]
+ addWarning ctx s["The page you requested requires authentication; please log on below."]
| None -> ()
return!
- { viewInfo ctx startTicks with helpLink = Some Help.logOn }
- |> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx
- |> renderHtml next ctx
- }
+ { viewInfo ctx startTicks with helpLink = Some Help.logOn }
+ |> Views.User.logOn { UserLogOn.empty with redirectUrl = url } groups ctx
+ |> renderHtml next ctx
+}
/// GET /users
-let maintain : HttpHandler =
- requireAccess [ Admin ]
- >=> fun next ctx -> task {
+let maintain : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
let! users = ctx.db.AllUsers ()
return!
- viewInfo ctx startTicks
- |> Views.User.maintain users ctx
- |> renderHtml next ctx
- }
+ viewInfo ctx startTicks
+ |> Views.User.maintain users ctx
+ |> renderHtml next ctx
+}
/// GET /user/password
-let password : HttpHandler =
- requireAccess [ User ]
- >=> fun next ctx ->
+let password : HttpHandler = requireAccess [ User ] >=> fun next ctx ->
{ viewInfo ctx DateTime.Now.Ticks with helpLink = Some Help.changePassword }
|> Views.User.changePassword ctx
|> renderHtml next ctx
/// 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 () with
| Ok m ->
let! user =
- match m.isNew () with
- | true -> Task.FromResult (Some { User.empty with userId = Guid.NewGuid () })
- | false -> ctx.db.TryUserById m.userId
+ if m.isNew () then Task.FromResult (Some { User.empty with userId = Guid.NewGuid () })
+ else ctx.db.TryUserById m.userId
let saltedUser =
- match user with
- | Some u ->
- match u.salt with
- | None when m.password <> "" ->
- // Generate salt so that a new password hash can be generated
- Some { u with salt = Some (Guid.NewGuid ()) }
- | _ ->
- // Leave the user with no salt, so prior hash can be validated/upgraded
- user
- | _ -> user
+ match user with
+ | Some u ->
+ match u.salt with
+ | None when m.password <> "" ->
+ // Generate salt so that a new password hash can be generated
+ Some { u with salt = Some (Guid.NewGuid ()) }
+ | _ ->
+ // Leave the user with no salt, so prior hash can be validated/upgraded
+ user
+ | _ -> user
match saltedUser with
| Some u ->
let updatedUser = m.populateUser u (pbkdf2Hash (Option.get u.salt))
- updatedUser |> (match m.isNew () with true -> ctx.db.AddEntry | false -> ctx.db.UpdateEntry)
+ updatedUser |> (if m.isNew () then ctx.db.AddEntry else ctx.db.UpdateEntry)
let! _ = ctx.db.SaveChangesAsync ()
let s = Views.I18N.localizer.Force ()
- match m.isNew () with
- | true ->
+ if m.isNew () then
let h = CommonFunctions.htmlString
{ UserMessage.info with
- text = h s.["Successfully {0} user", s.["Added"].Value.ToLower ()]
+ text = h s["Successfully {0} user", s["Added"].Value.ToLower ()]
description =
- h s.["Please select at least one group for which this user ({0}) is authorized",
- updatedUser.fullName]
+ h s["Please select at least one group for which this user ({0}) is authorized",
+ updatedUser.fullName]
|> Some
- }
+ }
|> addUserMessage ctx
return! redirectTo false $"/web/user/{flatGuid u.userId}/small-groups" next ctx
- | false ->
- addInfo ctx s.["Successfully {0} user", s.["Updated"].Value.ToLower ()]
+ else
+ addInfo ctx s["Successfully {0} user", s["Updated"].Value.ToLower ()]
return! redirectTo false "/web/users" next ctx
| None -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx
- }
+}
/// 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 () with
| Ok m ->
let s = Views.I18N.localizer.Force ()
match Seq.length m.smallGroups with
| 0 ->
- addError ctx s.["You must select at least one group to assign"]
+ addError ctx s["You must select at least one group to assign"]
return! redirectTo false $"/web/user/{flatGuid m.userId}/small-groups" next ctx
| _ ->
match! ctx.db.TryUserByIdWithGroups m.userId with
| Some user ->
let grps =
- m.smallGroups.Split ','
- |> Array.map Guid.Parse
- |> List.ofArray
+ m.smallGroups.Split ','
+ |> Array.map Guid.Parse
+ |> List.ofArray
user.smallGroups
|> Seq.filter (fun x -> not (grps |> List.exists (fun y -> y = x.smallGroupId)))
|> ctx.db.UserGroupXref.RemoveRange
@@ -287,25 +260,23 @@ let saveGroups : HttpHandler =
|> List.ofSeq
|> List.iter ctx.db.AddEntry
let! _ = ctx.db.SaveChangesAsync ()
- addInfo ctx s.["Successfully updated group permissions for {0}", m.userName]
+ addInfo ctx s["Successfully updated group permissions for {0}", m.userName]
return! redirectTo false "/web/users" next ctx
| _ -> return! fourOhFour next ctx
| Error e -> return! bindError e next ctx
- }
+}
/// GET /user/[user-id]/small-groups
-let smallGroups userId : HttpHandler =
- requireAccess [ Admin ]
- >=> fun next ctx -> task {
+let smallGroups userId : HttpHandler = requireAccess [ Admin ] >=> fun next ctx -> task {
let startTicks = DateTime.Now.Ticks
match! ctx.db.TryUserByIdWithGroups userId with
| Some user ->
let! grps = ctx.db.GroupList ()
let curGroups = user.smallGroups |> Seq.map (fun g -> flatGuid g.smallGroupId) |> List.ofSeq
return!
- viewInfo ctx startTicks
- |> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx
- |> renderHtml next ctx
+ viewInfo ctx startTicks
+ |> Views.User.assignGroups (AssignGroups.fromUser user) grps curGroups ctx
+ |> renderHtml next ctx
| None -> return! fourOhFour next ctx
- }
+}