From 82ab11c727c803fb9407f20bdd25434c34422019 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 1 Oct 2021 14:57:21 -0400 Subject: [PATCH] Full request now works Also fixed nav issues, added relative date formatter --- src/MyPrayerJournal/Server/Dates.fs | 76 +++++++++++ src/MyPrayerJournal/Server/Domain.fs | 43 +++--- src/MyPrayerJournal/Server/Handlers.fs | 7 +- .../Server/MyPrayerJournal.Server.fsproj | 1 + src/MyPrayerJournal/Server/ViewEngine.Htmx.fs | 2 +- src/MyPrayerJournal/Server/Views.fs | 129 ++++++++++++++---- 6 files changed, 206 insertions(+), 52 deletions(-) create mode 100644 src/MyPrayerJournal/Server/Dates.fs diff --git a/src/MyPrayerJournal/Server/Dates.fs b/src/MyPrayerJournal/Server/Dates.fs new file mode 100644 index 0000000..6a6a940 --- /dev/null +++ b/src/MyPrayerJournal/Server/Dates.fs @@ -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 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}" + diff --git a/src/MyPrayerJournal/Server/Domain.fs b/src/MyPrayerJournal/Server/Domain.fs index 02f25b0..2e082d6 100644 --- a/src/MyPrayerJournal/Server/Domain.fs +++ b/src/MyPrayerJournal/Server/Domain.fs @@ -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 [] @@ -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 diff --git a/src/MyPrayerJournal/Server/Handlers.fs b/src/MyPrayerJournal/Server/Handlers.fs index 3a151aa..37f47ba 100644 --- a/src/MyPrayerJournal/Server/Handlers.fs +++ b/src/MyPrayerJournal/Server/Handlers.fs @@ -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 ] diff --git a/src/MyPrayerJournal/Server/MyPrayerJournal.Server.fsproj b/src/MyPrayerJournal/Server/MyPrayerJournal.Server.fsproj index 99c4d48..3d241bc 100644 --- a/src/MyPrayerJournal/Server/MyPrayerJournal.Server.fsproj +++ b/src/MyPrayerJournal/Server/MyPrayerJournal.Server.fsproj @@ -8,6 +8,7 @@ + diff --git a/src/MyPrayerJournal/Server/ViewEngine.Htmx.fs b/src/MyPrayerJournal/Server/ViewEngine.Htmx.fs index 49c2f5f..ea911c0 100644 --- a/src/MyPrayerJournal/Server/ViewEngine.Htmx.fs +++ b/src/MyPrayerJournal/Server/ViewEngine.Htmx.fs @@ -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 diff --git a/src/MyPrayerJournal/Server/Views.fs b/src/MyPrayerJournal/Server/Views.fs index cc31a37..67fd1d2 100644 --- a/src/MyPrayerJournal/Server/Views.fs +++ b/src/MyPrayerJournal/Server/Views.fs @@ -6,8 +6,9 @@ open System [] 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,9 +19,17 @@ 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 @@ -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 ") • " + | None -> () + sprintf "Prayed %i times • 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 "  " + 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 " • " - a [ _href "/legal/terms-of-service" ] [ str "Terms of Service" ] + pageLink "/legal/terms-of-service" [] [ str "Terms of Service" ] rawText " • " a [ _href "https://github.com/bit-badger/myprayerjournal"; _target "_blank" ] [ str "Developed" ] str " and hosted by "