bit-badger/myPrayerJournal
1
0
Fork 0
Code Issues 1 Pull Requests Packages Projects Releases 36 Activity

Full request now works

Browse Source 
Also fixed nav issues, added relative date formatter
This commit is contained in:
Daniel J. Summers 2021-10-01 14:57:21 -04:00
parent f86ca395a4
commit 82ab11c727
6 changed files with 206 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
src/MyPrayerJournal/Server/Dates.fs Normal file
View File

@ -0,0 +1,76 @@
/// Date formatting helpers
// Many thanks to date-fns (https://date-fns.org) for this logic
module MyPrayerJournal.Dates
type internal FormatDistanceToken =
| LessThanXMinutes
| XMinutes
| AboutXHours
| XHours
| XDays
| AboutXWeeks
| XWeeks
| AboutXMonths
| XMonths
| AboutXYears
| XYears
| OverXYears
| AlmostXYears
let internal locales =
let format = PrintfFormat<int -> string, unit, string, string>
Map.ofList [
"en-US", Map.ofList [
LessThanXMinutes, ("less than a minute", format "less than %i minutes")
XMinutes, ("a minute", format "%i minutes")
AboutXHours, ("about an hour", format "about %i hours")
XHours, ("an hour", format "%i hours")
XDays, ("a day", format "%i days")
AboutXWeeks, ("about a week", format "about %i weeks")
XWeeks, ("a week", format "%i weeks")
AboutXMonths, ("about a month", format "about %i months")
XMonths, ("a month", format "%i months")
AboutXYears, ("about a year", format "about %i years")
XYears, ("a year", format "%i years")
OverXYears, ("over a year", format "over %i years")
AlmostXYears, ("almost a year", format "almost %i years")
]
]
let aDay = 1_440.
let almostTwoDays = 2_520.
let aMonth = 43_200.
let twoMonths = 86_400.
open System
/// Convert from a JavaScript "ticks" value to a date/time
let fromJs ticks = DateTime.UnixEpoch + TimeSpan.FromTicks (ticks * 10_000L)
let formatDistance (startDate : DateTime) (endDate : DateTime) =
let format (token, number) locale =
let labels = locales |> Map.find locale
match number with 1 -> fst labels.[token] | _ -> sprintf (snd labels.[token]) number
let round (it : float) = Math.Round it |> int
let diff = startDate - endDate
let formatToken =
let months = diff.TotalMinutes / aMonth |> round
let years = months / 12
match true with
| _ when diff.TotalMinutes = 0. -> LessThanXMinutes, 1
| _ when diff.TotalMinutes < 45. -> XMinutes, round diff.TotalMinutes
| _ when diff.TotalMinutes < 90. -> AboutXHours, 1
| _ when diff.TotalMinutes < aDay -> AboutXHours, round (diff.TotalMinutes / 60.)
| _ when diff.TotalMinutes < almostTwoDays -> XDays, 1
| _ when diff.TotalMinutes < aMonth -> XDays, round (diff.TotalMinutes / aDay)
| _ when diff.TotalMinutes < twoMonths -> AboutXMonths, round (diff.TotalMinutes / aMonth)
| _ when months < 12 -> XMonths, round (diff.TotalMinutes / aMonth)
| _ when months % 12 < 3 -> AboutXYears, years
| _ when months % 12 < 9 -> OverXYears, years
| _ -> AlmostXYears, years + 1
let words = format formatToken "en-US"
match startDate > endDate with true -> $"{words} ago" | false -> $"in {words}"

43
src/MyPrayerJournal/Server/Domain.fs
View File

@ -81,24 +81,6 @@ type RequestAction =
| Updated
| Answered
/// Functions to manipulate request actions
module RequestAction =
/// Create a string representation of an action
let toString =
function
| Created -> "Created"
| Prayed -> "Prayed"
| Updated -> "Updated"
| Answered -> "Answered"
/// Create a RequestAction from a string
let fromString =
function
| "Created" -> Created
| "Prayed" -> Prayed
| "Updated" -> Updated
| "Answered" -> Answered
| it -> invalidOp $"Bad request action {it}"
/// History is a record of action taken on a prayer request, including updates to its text
[<CLIMutable; NoComparison; NoEquality>]
@ -183,3 +165,28 @@ type JournalRequest =
/// Note entries for the request
notes : Note list
}
/// Functions to manipulate request actions
module RequestAction =
/// Create a string representation of an action
let toString =
function
| Created -> "Created"
| Prayed -> "Prayed"
| Updated -> "Updated"
| Answered -> "Answered"
/// Create a RequestAction from a string
let fromString =
function
| "Created" -> Created
| "Prayed" -> Prayed
| "Updated" -> Updated
| "Answered" -> Answered
| it -> invalidOp $"Bad request action {it}"
/// Determine if a history's status is `Created`
let isCreated hist = hist.status = Created
/// Determine if a history's status is `Prayed`
let isPrayed hist = hist.status = Prayed
/// Determine if a history's status is `Answered`
let isAnswered hist = hist.status = Answered

7
src/MyPrayerJournal/Server/Handlers.fs
View File

@ -329,12 +329,13 @@ module Request =
| None -> return! Error.notFound next ctx
}
/// GET /api/request/[req-id]/full
/// GET /request/[req-id]/full
let getFull requestId : HttpHandler =
authorize
>=> withMenuRefresh
>=> fun next ctx -> task {
match! Data.tryFullRequestById (toReqId requestId) (userId ctx) (db ctx) with
| Some req -> return! json req next ctx
| Some req -> return! partialIfNotRefresh (Views.Request.full req) next ctx
| None -> return! Error.notFound next ctx
}
@ -415,11 +416,11 @@ let routes =
subRoute "/request" [
route "s/active" Request.active
route "s/answered" Request.answered
routef "/%s/full" Request.getFull
]
subRoute "/api/" [
GET [
subRoute "request" [
routef "/%s/full" Request.getFull
routef "/%s/notes" Request.getNotes
routef "/%s" Request.get
]

1
src/MyPrayerJournal/Server/MyPrayerJournal.Server.fsproj
View File

@ -8,6 +8,7 @@
<Compile Include="Htmx.fs" />
<Compile Include="Domain.fs" />
<Compile Include="Data.fs" />
<Compile Include="Dates.fs" />
<Compile Include="Views.fs" />
<Compile Include="Handlers.fs" />
<Compile Include="Program.fs" />

2
src/MyPrayerJournal/Server/ViewEngine.Htmx.fs
View File

@ -112,7 +112,7 @@ module HtmxAttrs =
/// Shows a prompt before submitting a request
let _hxPrompt = attr "hx-prompt"
/// Pushes the URL into the location bar, creating a new history entry
let _hxPushUrl = attr "hx-push-url"
let _hxPushUrl = flag "hx-push-url"
/// Issues a PUT to the specified URL
let _hxPut = attr "hx-put"
/// Configures various aspects of the request

129
src/MyPrayerJournal/Server/Views.fs
View File

@ -6,8 +6,9 @@ open System
[<AutoOpen>]
module Helpers =
/// Target the `main` tag with boosted links
let toMain = _hxTarget "main"
/// Create a link that targets the `main` element and pushes a URL to history
let pageLink href attrs = a (attrs |> List.append [ _href href; _hxBoost; _hxTarget "main"; _hxPushUrl ])
/// Create a Material icon
let icon name = span [ _class "material-icons" ] [ str name ]
@ -18,10 +19,18 @@ module Helpers =
h5 [ _class "card-header"] [ str heading ]
div [ _class "card-body text-center" ] [
p [ _class "card-text" ] text
a [ _class "btn btn-primary"; _href link; _hxBoost; toMain ] [ str buttonText ]
pageLink link [ _class "btn btn-primary" ] [ str buttonText ]
]
]
/// Convert `Ticks` to `DateTime`
let fromJs = Ticks.toLong >> Dates.fromJs
/// Create a date with a span tag, displaying the relative date with the full date/time in the tooltip
let relativeDate jsDate =
let date = fromJs jsDate
span [ _title (date.ToString "f") ] [ Dates.formatDistance DateTime.Now date |> str ]
/// View for home page
module Home =
@ -144,7 +153,7 @@ module Legal =
str "myPrayerJournal is a service that allows individuals to enter and amend their prayer requests. It "
str "requires no registration by itself, but access is granted based on a successful login with an external "
str "identity provider. See "
a [ _href "/legal/privacy-policy"; _hxBoost; toMain ] [ str "our privacy policy" ]
pageLink "/legal/privacy-policy" [] [ str "our privacy policy" ]
str " for details on how that information is accessed and stored."
]
h3 [] [ str "3. Third Party Services" ]
@ -173,7 +182,7 @@ module Legal =
hr []
p [ _class "card-text" ] [
str "You may also wish to review our "
a [ _href "/legal/privacy-policy"; _hxBoost; toMain ] [ str "privacy policy" ]
pageLink "/legal/privacy-policy" [] [ str "privacy policy" ]
str " to learn how we handle your data."
]
]
@ -188,7 +197,7 @@ module Navigation =
let navBar =
nav [ _class "navbar navbar-dark" ] [
div [ _class "container-fluid" ] [
a [ _href "/"; _class "navbar-brand"; _hxBoost; toMain ] [
pageLink "/" [ _class "navbar-brand" ] [
span [ _class "m" ] [ str "my" ]
span [ _class "p" ] [ str "Prayer" ]
span [ _class "j" ] [ str "Journal" ]
@ -208,17 +217,13 @@ module Navigation =
match isAuthenticated with
| true ->
let currUrl = match url with Some u -> (u.PathAndQuery.Split '?').[0] | None -> ""
let attrs (matchUrl : string) =
[ _href matchUrl
match currUrl.StartsWith matchUrl with
| true -> _class "is-active-route"
| false -> ()
_hxBoost; toMain
]
li [ _class "nav-item" ] [ a (attrs "/journal") [ str "Journal" ] ]
li [ _class "nav-item" ] [ a (attrs "/requests/active") [ str "Active" ] ]
if hasSnoozed then li [ _class "nav-item" ] [ a (attrs "/requests/snoozed") [ str "Snoozed" ] ]
li [ _class "nav-item" ] [ a (attrs "/requests/answered") [ str "Answered" ] ]
let navLink (matchUrl : string) =
match currUrl.StartsWith matchUrl with true -> [ _class "is-active-route" ] | false -> []
|> pageLink matchUrl
li [ _class "nav-item" ] [ navLink "/journal" [ str "Journal" ] ]
li [ _class "nav-item" ] [ navLink "/requests/active" [ str "Active" ] ]
if hasSnoozed then li [ _class "nav-item" ] [ navLink "/requests/snoozed" [ str "Snoozed" ] ]
li [ _class "nav-item" ] [ navLink "/requests/answered" [ str "Answered" ] ]
li [ _class "nav-item" ] [ a [ _href "/user/log-off"; _onclick "mpj.logOff(event)" ] [ str "Log Off" ] ]
| false -> li [ _class "nav-item"] [ a [ _href "/user/log-on"; _onclick "mpj.logOn(event)"] [ str "Log On" ] ]
li [ _class "nav-item" ] [ a [ _href "https://docs.prayerjournal.me"; _target "_blank" ] [ str "Docs" ] ]
@ -264,14 +269,14 @@ module Request =
tr [] [
td [ _class "action-cell" ] [
div [ _class "btn-group btn-group-sm"; Accessibility._roleGroup ] [
a [ btnClass; _href $"/request/{reqId}/full"; _title "View Full Request" ] [ icon "description" ]
pageLink $"/request/{reqId}/full" [ btnClass; _title "View Full Request" ] [ icon "description" ]
if not isAnswered then
a [ btnClass; _href $"/request/{reqId}/edit"; _title "Edit Request" ] [ icon "edit" ]
pageLink $"/request/{reqId}/edit" [ btnClass; _title "Edit Request" ] [ icon "edit" ]
// TODO: these next two should use hx-patch, targeting replacement of this tr when complete
if isSnoozed then
a [ btnClass; _href $"/request/{reqId}/cancel-snooze"; _title "Cancel Snooze" ] [ icon "restore" ]
pageLink $"/request/{reqId}/cancel-snooze" [ btnClass; _title "Cancel Snooze" ] [ icon "restore" ]
if isPending then
a [ btnClass; _href $"/request/{reqId}/show-now"; _title "Show Now" ] [ icon "restore" ]
pageLink $"/request/{reqId}/show-now" [ btnClass; _title "Show Now" ] [ icon "restore" ]
]
]
td [] [
@ -281,9 +286,15 @@ module Request =
br []
small [ _class "text-muted" ] [
em [] [
if isSnoozed then str "Snooze expires date-from-now(value='request.snoozedUntil')"
if isPending then str "Request appears next date-from-now(:value='request.showAfter')"
if isAnswered then str "Answered date-from-now(:value='request.asOf')"
if isSnoozed then
str "Snooze expires "
relativeDate req.snoozedUntil
if isPending then
str "Request appears next "
relativeDate req.showAfter
if isAnswered then
str "Answered "
relativeDate req.asOf
]
]
]
@ -305,7 +316,7 @@ module Request =
]
/// View for Active Requests page
let active reqs = article [] [
let active reqs = article [ _class "container mt-3" ] [
h2 [] [ str "Active Requests" ]
match reqs |> List.isEmpty with
| true ->
@ -315,7 +326,7 @@ module Request =
]
/// View for Answered Requests page
let answered reqs = article [] [
let answered reqs = article [ _class "container mt-3" ] [
h2 [] [ str "Answered Requests" ]
match reqs |> List.isEmpty with
| true ->
@ -327,11 +338,69 @@ module Request =
]
/// View for Snoozed Requests page
let snoozed reqs = article [] [
let snoozed reqs = article [ _class "container mt-3" ] [
h2 [] [ str "Snoozed Requests" ]
reqList reqs
]
/// View for Full Request page
let full (req : Request) =
let answered =
req.history
|> List.filter RequestAction.isAnswered
|> List.tryHead
|> Option.map (fun x -> x.asOf)
let prayed = req.history |> List.filter RequestAction.isPrayed |> List.length
let daysOpen =
let asOf = answered |> Option.map fromJs |> Option.defaultValue DateTime.Now
(asOf - fromJs (req.history |> List.filter RequestAction.isCreated |> List.head).asOf).TotalDays |> int
let lastText =
req.history
|> List.filter (fun h -> Option.isSome h.text)
|> List.sortByDescending (fun h -> Ticks.toLong h.asOf)
|> List.map (fun h -> Option.get h.text)
|> List.head
// The history log including notes (and excluding the final entry for answered requests)
let log =
let toDisp (h : History) = {| asOf = fromJs h.asOf; text = h.text; status = RequestAction.toString h.status |}
let all =
req.notes
|> List.map (fun n -> {| asOf = fromJs n.asOf; text = Some n.notes; status = "Notes" |})
|> List.append (req.history |> List.map toDisp)
|> List.sortByDescending (fun it -> it.asOf)
// Skip the first entry for answered requests; that info is already displayed
match answered with Some _ -> all |> List.skip 1 | None -> all
article [ _class "container mt-3" ] [
div [_class "card" ] [
h5 [ _class "card-header" ] [ str "Full Prayer Request" ]
div [ _class "card-body" ] [
h6 [ _class "card-subtitle text-muted mb-2"] [
match answered with
| Some ticks ->
str "Answered "
(fromJs ticks).ToString "D" |> str
str " ("
relativeDate ticks
rawText ") &bull; "
| None -> ()
sprintf "Prayed %i times &bull; Open %i days" prayed daysOpen |> rawText
]
p [ _class "card-text" ] [ str lastText ]
]
log
|> List.map (fun it -> li [ _class "list-group-item" ] [
p [ _class "m-0" ] [
str it.status
rawText "&nbsp; "
small [] [ em [] [ it.asOf.ToString "D" |> str ] ]
]
match it.text with
| Some txt -> p [ _class "mt-2 mb-0" ] [ str txt ]
| None -> ()
])
|> ul [ _class "list-group list-group-flush" ]
]
]
/// Layout views
@ -355,15 +424,15 @@ module Layout =
]
let htmlFoot =
footer [ _class "container-fluid"; _hxBoost; toMain ] [
footer [ _class "container-fluid" ] [
p [ _class "text-muted text-end" ] [
str "myPrayerJournal v3"
br []
em [] [
small [] [
a [ _href "/legal/privacy-policy" ] [ str "Privacy Policy" ]
pageLink "/legal/privacy-policy" [] [ str "Privacy Policy" ]
rawText " &bull; "
a [ _href "/legal/terms-of-service" ] [ str "Terms of Service" ]
pageLink "/legal/terms-of-service" [] [ str "Terms of Service" ]
rawText " &bull; "
a [ _href "https://github.com/bit-badger/myprayerjournal"; _target "_blank" ] [ str "Developed" ]
str " and hosted by "