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

WIP on request sorting (#34, #70)

Browse Source 
- Do not store snoozed until and show after dates for immediate recurrence
- Map Instants using ISO-8601 formats
- Change lists in request to arrays (LiteDB didn't like deserializing them)
- Declutter handler definitions
This commit is contained in:
Daniel J. Summers 2022-07-29 23:57:26 -04:00
parent 9b85ac2412
commit bdf870343d
7 changed files with 406 additions and 378 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/MyPrayerJournal.ConvertRecurrence/Program.fs
View File

@ -81,13 +81,19 @@ let convertNote (old : OldNote) =
Notes = old.notes
}
/// Convert items that may be Instant.MinValue or Instant(0) to None
let noneIfOld ms =
match Instant.FromUnixTimeMilliseconds ms with
| instant when instant > Instant.FromUnixTimeMilliseconds 0 -> Some instant
| _ -> None
/// Map the old request to the new request
let convert old =
{ Id = old.id
EnteredOn = Instant.FromUnixTimeMilliseconds old.enteredOn
UserId = old.userId
SnoozedUntil = Instant.FromUnixTimeMilliseconds old.snoozedUntil
ShowAfter = Instant.FromUnixTimeMilliseconds old.showAfter
SnoozedUntil = noneIfOld old.snoozedUntil
ShowAfter = noneIfOld old.showAfter
Recurrence = mapRecurrence old
History = old.history |> Array.map convertHistory |> List.ofArray
Notes = old.notes |> Array.map convertNote |> List.ofArray
@ -95,8 +101,8 @@ let convert old =
/// Remove the old request, add the converted one (removes recurType / recurCount fields)
let replace (req : Request) =
db.requests.Delete (Mapping.RequestId.toBson req.Id) |> ignore
db.requests.Insert req |> ignore
db.Requests.Delete (Mapping.RequestId.toBson req.Id) |> ignore
db.Requests.Insert req |> ignore
db.Checkpoint ()
db.GetCollection<OldRequest>("request").FindAll ()

49
src/MyPrayerJournal/Data.fs
View File

@ -2,11 +2,7 @@
open LiteDB
open MyPrayerJournal
open NodaTime
open System.Threading.Tasks
open NodaTime.Text
// fsharplint:disable MemberNames
/// LiteDB extensions
[<AutoOpen>]
@ -16,11 +12,10 @@ module Extensions =
type LiteDatabase with
/// The Request collection
member this.requests
with get () = this.GetCollection<Request> "request"
member this.Requests = this.GetCollection<Request> "request"
/// Async version of the checkpoint command (flushes log)
member this.saveChanges () =
member this.SaveChanges () =
this.Checkpoint ()
Task.CompletedTask
@ -30,6 +25,9 @@ module Extensions =
[<RequireQualifiedAccess>]
module Mapping =
open NodaTime
open NodaTime.Text
/// A NodaTime instant pattern to use for parsing instants from the database
let instantPattern = InstantPattern.CreateWithInvariantCulture "g"
@ -40,6 +38,9 @@ module Mapping =
/// Mapping for option types
module Option =
let instantFromBson (value : BsonValue) = if value.IsNull then None else Some (Instant.fromBson value)
let instantToBson (value : Instant option) = match value with Some it -> Instant.toBson it | None -> null
let stringFromBson (value : BsonValue) = match value.AsString with "" -> None | x -> Some x
let stringToBson (value : string option) : BsonValue = match value with Some txt -> txt | None -> ""
@ -66,6 +67,7 @@ module Mapping =
/// Set up the mapping
let register () =
BsonMapper.Global.RegisterType<Instant>(Instant.toBson, Instant.fromBson)
BsonMapper.Global.RegisterType<Instant option>(Option.instantToBson, Option.instantFromBson)
BsonMapper.Global.RegisterType<Recurrence>(Recurrence.toBson, Recurrence.fromBson)
BsonMapper.Global.RegisterType<RequestAction>(RequestAction.toBson, RequestAction.fromBson)
BsonMapper.Global.RegisterType<RequestId>(RequestId.toBson, RequestId.fromBson)
@ -77,7 +79,7 @@ module Startup =
/// Ensure the database is set up
let ensureDb (db : LiteDatabase) =
db.requests.EnsureIndex (fun it -> it.UserId) |> ignore
db.Requests.EnsureIndex (fun it -> it.UserId) |> ignore
Mapping.register ()
@ -97,39 +99,42 @@ module private Helpers =
/// Async wrapper around a request update
let doUpdate (db : LiteDatabase) (req : Request) =
db.requests.Update req |> ignore
db.Requests.Update req |> ignore
Task.CompletedTask
/// Retrieve a request, including its history and notes, by its ID and user ID
let tryFullRequestById reqId userId (db : LiteDatabase) = backgroundTask {
let! req = db.requests.Find (Query.EQ ("_id", RequestId.toString reqId)) |> firstAsync
let! req = db.Requests.Find (Query.EQ ("_id", RequestId.toString reqId)) |> firstAsync
return match box req with null -> None | _ when req.UserId = userId -> Some req | _ -> None
}
/// Add a history entry
let addHistory reqId userId hist db = backgroundTask {
match! tryFullRequestById reqId userId db with
| Some req -> do! doUpdate db { req with History = hist :: req.History }
| Some req -> do! doUpdate db { req with History = Array.append [| hist |] req.History }
| None -> invalidOp $"{RequestId.toString reqId} not found"
}
/// Add a note
let addNote reqId userId note db = backgroundTask {
match! tryFullRequestById reqId userId db with
| Some req -> do! doUpdate db { req with Notes = note :: req.Notes }
| Some req -> do! doUpdate db { req with Notes = Array.append [| note |] req.Notes }
| None -> invalidOp $"{RequestId.toString reqId} not found"
}
/// Add a request
let addRequest (req : Request) (db : LiteDatabase) =
db.requests.Insert req |> ignore
db.Requests.Insert req |> ignore
// FIXME: make a common function here
/// Find all requests for the given user
let private getRequestsForUser (userId : UserId) (db : LiteDatabase) = backgroundTask {
return! db.Requests.Find (Query.EQ (nameof Request.empty.UserId, Mapping.UserId.toBson userId)) |> toListAsync
}
/// Retrieve all answered requests for the given user
let answeredRequests userId (db : LiteDatabase) = backgroundTask {
let! reqs = db.requests.Find (Query.EQ ("userId", UserId.toString userId)) |> toListAsync
let answeredRequests userId db = backgroundTask {
let! reqs = getRequestsForUser userId db
return
reqs
|> Seq.map JournalRequest.ofRequestFull
@ -139,10 +144,10 @@ let answeredRequests userId (db : LiteDatabase) = backgroundTask {
}
/// Retrieve the user's current journal
let journalByUserId userId (db : LiteDatabase) = backgroundTask {
let! jrnl = db.requests.Find (Query.EQ ("userId", UserId.toString userId)) |> toListAsync
let journalByUserId userId db = backgroundTask {
let! reqs = getRequestsForUser userId db
return
jrnl
reqs
|> Seq.map JournalRequest.ofRequestLite
|> Seq.filter (fun it -> it.LastStatus <> Answered)
|> Seq.sortBy (fun it -> it.AsOf)
@ -152,18 +157,18 @@ let journalByUserId userId (db : LiteDatabase) = backgroundTask {
/// Does the user have any snoozed requests?
let hasSnoozed userId now (db : LiteDatabase) = backgroundTask {
let! jrnl = journalByUserId userId db
return jrnl |> List.exists (fun r -> r.SnoozedUntil > now)
return jrnl |> List.exists (fun r -> defaultArg (r.SnoozedUntil |> Option.map (fun it -> it > now)) false)
}
/// Retrieve a request by its ID and user ID (without notes and history)
let tryRequestById reqId userId db = backgroundTask {
let! req = tryFullRequestById reqId userId db
return req |> Option.map (fun r -> { r with History = []; Notes = [] })
return req |> Option.map (fun r -> { r with History = [||]; Notes = [||] })
}
/// Retrieve notes for a request by its ID and user ID
let notesById reqId userId (db : LiteDatabase) = backgroundTask {
match! tryFullRequestById reqId userId db with | Some req -> return req.Notes | None -> return []
match! tryFullRequestById reqId userId db with | Some req -> return req.Notes | None -> return [||]
}
/// Retrieve a journal request by its ID and user ID

56
src/MyPrayerJournal/Domain.fs
View File

@ -160,19 +160,19 @@ type Request =
UserId : UserId
/// The time at which this request should reappear in the user's journal by manual user choice
SnoozedUntil : Instant
SnoozedUntil : Instant option
/// The time at which this request should reappear in the user's journal by recurrence
ShowAfter : Instant
ShowAfter : Instant option
/// The recurrence for this request
Recurrence : Recurrence
/// The history entries for this request
History : History list
History : History[]
/// The notes for this request
Notes : Note list
Notes : Note[]
}
/// Functions to support requests
@ -183,11 +183,11 @@ module Request =
{ Id = Cuid.generate () |> RequestId
EnteredOn = Instant.MinValue
UserId = UserId ""
SnoozedUntil = Instant.MinValue
ShowAfter = Instant.MinValue
SnoozedUntil = None
ShowAfter = None
Recurrence = Immediate
History = []
Notes = []
History = [||]
Notes = [||]
}
@ -211,10 +211,10 @@ type JournalRequest =
LastStatus : RequestAction
/// The time that this request should reappear in the user's journal
SnoozedUntil : Instant
SnoozedUntil : Instant option
/// The time after which this request should reappear in the user's journal by configured recurrence
ShowAfter : Instant
ShowAfter : Instant option
/// The recurrence for this request
Recurrence : Recurrence
@ -231,17 +231,37 @@ module JournalRequest =
/// Convert a request to the form used for the journal (precomputed values, no notes or history)
let ofRequestLite (req : Request) =
let hist = req.History |> List.sortByDescending (fun it -> it.AsOf) |> List.tryHead
let lastHistory = req.History |> Array.sortByDescending (fun it -> it.AsOf) |> Array.tryHead
// Requests are sorted by the "as of" field in this record; for sorting to work properly, we will put the
// larger of either the last prayed date or the "show after" date; if neither of those are filled, we will use
// the last activity date. This will mean that:
// - Immediately shown requests will be at the top of the list, in order from least recently prayed to most.
// - Non-immediate requests will enter the list as if they were marked as prayed at that time; this will put
// them at the bottom of the list.
// - New requests will go to the bottom of the list, but will rise as others are marked as prayed.
let lastActivity = lastHistory |> Option.map (fun it -> it.AsOf) |> Option.defaultValue Instant.MinValue
let lastPrayed =
req.History
|> Array.sortByDescending (fun it -> it.AsOf)
|> Array.filter History.isPrayed
|> Array.tryHead
|> Option.map (fun it -> it.AsOf)
|> Option.defaultValue Instant.MinValue
let showAfter = defaultArg req.ShowAfter Instant.MinValue
let asOf =
if lastPrayed > showAfter then lastPrayed
elif showAfter > lastPrayed then showAfter
else lastActivity
{ RequestId = req.Id
UserId = req.UserId
Text = req.History
|> List.filter (fun it -> Option.isSome it.Text)
|> List.sortByDescending (fun it -> it.AsOf)
|> List.tryHead
|> Array.filter (fun it -> Option.isSome it.Text)
|> Array.sortByDescending (fun it -> it.AsOf)
|> Array.tryHead
|> Option.map (fun h -> Option.get h.Text)
|> Option.defaultValue ""
AsOf = match hist with Some h -> h.AsOf | None -> Instant.MinValue
LastStatus = match hist with Some h -> h.Status | None -> Created
AsOf = asOf
LastStatus = match lastHistory with Some h -> h.Status | None -> Created
SnoozedUntil = req.SnoozedUntil
ShowAfter = req.ShowAfter
Recurrence = req.Recurrence
@ -252,6 +272,6 @@ module JournalRequest =
/// Same as `ofRequestLite`, but with notes and history
let ofRequestFull req =
{ ofRequestLite req with
History = req.History
Notes = req.Notes
History = List.ofArray req.History
Notes = List.ofArray req.Notes
}

317
src/MyPrayerJournal/Handlers.fs
View File

@ -2,22 +2,18 @@
[<RequireQualifiedAccess>]
module MyPrayerJournal.Handlers
// fsharplint:disable RecordFieldNames
open Giraffe
open Giraffe.Htmx
open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Http
open System
open System.Security.Claims
open NodaTime
/// Helper function to be able to split out log on
[<AutoOpen>]
module private LogOnHelpers =
open Microsoft.AspNetCore.Authentication
/// Log on, optionally specifying a redirected URL once authentication is complete
let logOn url : HttpHandler = fun next ctx -> backgroundTask {
let logOn url : HttpHandler = fun next ctx -> task {
match url with
| Some it ->
do! ctx.ChallengeAsync ("Auth0", AuthenticationProperties (RedirectUri = it))
@ -30,7 +26,6 @@ module private LogOnHelpers =
module Error =
open Microsoft.Extensions.Logging
open System.Threading.Tasks
/// Handle errors
let error (ex : Exception) (log : ILogger) =
@ -42,52 +37,59 @@ module Error =
/// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response
let notAuthorized : HttpHandler = fun next ctx ->
(next, ctx)
||> match ctx.Request.Method with
| "GET" -> logOn None
| _ -> setStatusCode 401 >=> fun _ _ -> Task.FromResult<HttpContext option> None
(if ctx.Request.Method = "GET" then logOn None next else setStatusCode 401 earlyReturn) ctx
/// Handle 404s from the API, sending known URL paths to the Vue app so that they can be handled there
let notFound : HttpHandler =
setStatusCode 404 >=> text "Not found"
/// Handler helpers
[<AutoOpen>]
module private Helpers =
open LiteDB
open Microsoft.Extensions.Logging
open Microsoft.Net.Http.Headers
open System.Security.Claims
open LiteDB
open Microsoft.AspNetCore.Http
open NodaTime
let debug (ctx : HttpContext) message =
let fac = ctx.GetService<ILoggerFactory>()
let log = fac.CreateLogger "Debug"
log.LogInformation message
/// Get the LiteDB database
let db (ctx : HttpContext) = ctx.GetService<LiteDatabase>()
/// Get the user's "sub" claim
let user (ctx : HttpContext) =
ctx.User
/// Extensions on the HTTP context
type HttpContext with
/// The LiteDB database
member this.Db = this.GetService<LiteDatabase> ()
/// The "sub" for the current user (None if no user is authenticated)
member this.CurrentUser =
this.User
|> Option.ofObj
|> Option.map (fun user -> user.Claims |> Seq.tryFind (fun u -> u.Type = ClaimTypes.NameIdentifier))
|> Option.flatten
|> Option.map (fun claim -> claim.Value)
/// The current user's ID
// NOTE: this may raise if you don't run the request through the requireUser handler first
member this.UserId = UserId this.CurrentUser.Value
/// The system clock
member this.Clock = this.GetService<IClock> ()
/// Get the current instant from the system clock
member this.Now = this.Clock.GetCurrentInstant
/// Get the current user's ID
// NOTE: this may raise if you don't run the request through the requiresAuthentication handler first
let userId ctx =
(user >> Option.get) ctx |> UserId
/// Get the system clock
let clock (ctx : HttpContext) =
ctx.GetService<IClock> ()
/// Handler helpers
[<AutoOpen>]
module private Helpers =
/// Get the current instant
let now ctx =
(clock ctx).GetCurrentInstant ()
open Microsoft.Extensions.Logging
open Microsoft.Net.Http.Headers
/// Require a user to be logged on
let requireUser : HttpHandler =
requiresAuthentication Error.notAuthorized
/// Debug logger
let debug (ctx : HttpContext) message =
let fac = ctx.GetService<ILoggerFactory> ()
let log = fac.CreateLogger "Debug"
log.LogInformation message
/// Return a 201 CREATED response
let created =
@ -110,21 +112,21 @@ module private Helpers =
}
open Views.Layout
open System.Threading.Tasks
/// Create a page rendering context
let pageContext (ctx : HttpContext) pageTitle content = backgroundTask {
let! hasSnoozed = backgroundTask {
match user ctx with
| Some _ -> return! Data.hasSnoozed (userId ctx) (now ctx) (db ctx)
| None -> return false
}
return {
isAuthenticated = (user >> Option.isSome) ctx
hasSnoozed = hasSnoozed
currentUrl = ctx.Request.Path.Value
pageTitle = pageTitle
content = content
}
let! hasSnoozed =
match ctx.CurrentUser with
| Some _ -> Data.hasSnoozed ctx.UserId (ctx.Now ()) ctx.Db
| None -> Task.FromResult false
return
{ IsAuthenticated = Option.isSome ctx.CurrentUser
HasSnoozed = hasSnoozed
CurrentUrl = ctx.Request.Path.Value
PageTitle = pageTitle
Content = content
}
}
/// Composable handler to write a view to the output
@ -137,18 +139,18 @@ module private Helpers =
module Messages =
/// The messages being held
let mutable private messages : Map<string, string * string> = Map.empty
let mutable private messages : Map<UserId, string * string> = Map.empty
/// Locked update to prevent updates by multiple threads
let private upd8 = obj ()
/// Push a new message into the list
let push ctx message url = lock upd8 (fun () ->
messages <- messages.Add (ctx |> (user >> Option.get), (message, url)))
let push (ctx : HttpContext) message url = lock upd8 (fun () ->
messages <- messages.Add (ctx.UserId, (message, url)))
/// Add a success message header to the response
let pushSuccess ctx message url =
push ctx $"success|||{message}" url
push ctx $"success|||%s{message}" url
/// Pop the messages for the given user
let pop userId = lock upd8 (fun () ->
@ -157,15 +159,15 @@ module private Helpers =
msg)
/// Send a partial result if this is not a full page load (does not append no-cache headers)
let partialStatic (pageTitle : string) content : HttpHandler = fun next ctx -> backgroundTask {
let partialStatic (pageTitle : string) content : HttpHandler = fun next ctx -> task {
let isPartial = ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
let! pageCtx = pageContext ctx pageTitle content
let view = (match isPartial with true -> partial | false -> view) pageCtx
return!
(next, ctx)
||> match user ctx with
| Some u ->
match Messages.pop u with
||> match ctx.CurrentUser with
| Some _ ->
match Messages.pop ctx.UserId with
| Some (msg, url) -> setHttpHeader "X-Toast" msg >=> withHxPush url >=> writeView view
| None -> writeView view
| None -> writeView view
@ -234,35 +236,40 @@ open NodaTime.Text
module Components =
// GET /components/journal-items
let journalItems : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let now = now ctx
let! jrnl = Data.journalByUserId (userId ctx) (db ctx)
let shown = jrnl |> List.filter (fun it -> now > it.SnoozedUntil && now > it.ShowAfter)
let journalItems : HttpHandler = requireUser >=> fun next ctx -> task {
let now = ctx.Now ()
let shouldBeShown (req : JournalRequest) =
match req.SnoozedUntil, req.ShowAfter with
| None, None -> true
| Some snooze, Some hide when snooze < now && hide < now -> true
| Some snooze, _ when snooze < now -> true
| _, Some hide when hide < now -> true
| _, _ -> false
let! journal = Data.journalByUserId ctx.UserId ctx.Db
let shown = journal |> List.filter shouldBeShown
return! renderComponent [ Views.Journal.journalItems now shown ] next ctx
}
// GET /components/request-item/[req-id]
let requestItem reqId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
match! Data.tryJournalById (RequestId.ofString reqId) (userId ctx) (db ctx) with
| Some req -> return! renderComponent [ Views.Request.reqListItem (now ctx) req ] next ctx
let requestItem reqId : HttpHandler = requireUser >=> fun next ctx -> task {
match! Data.tryJournalById (RequestId.ofString reqId) ctx.UserId ctx.Db with
| Some req -> return! renderComponent [ Views.Request.reqListItem (ctx.Now ()) req ] next ctx
| None -> return! Error.notFound next ctx
}
// GET /components/request/[req-id]/add-notes
let addNotes requestId : HttpHandler =
requiresAuthentication Error.notAuthorized
>=> renderComponent (Views.Journal.notesEdit (RequestId.ofString requestId))
requireUser >=> renderComponent (Views.Journal.notesEdit (RequestId.ofString requestId))
// GET /components/request/[req-id]/notes
let notes requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let! notes = Data.notesById (RequestId.ofString requestId) (userId ctx) (db ctx)
return! renderComponent (Views.Request.notes (now ctx) notes) next ctx
let notes requestId : HttpHandler = requireUser >=> fun next ctx -> task {
let! notes = Data.notesById (RequestId.ofString requestId) ctx.UserId ctx.Db
return! renderComponent (Views.Request.notes (ctx.Now ()) (List.ofArray notes)) next ctx
}
// GET /components/request/[req-id]/snooze
let snooze requestId : HttpHandler =
requiresAuthentication Error.notAuthorized
>=> renderComponent [ RequestId.ofString requestId |> Views.Journal.snooze ]
requireUser >=> renderComponent [ RequestId.ofString requestId |> Views.Journal.snooze ]
/// / URL
@ -277,7 +284,7 @@ module Home =
module Journal =
// GET /journal
let journal : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let journal : HttpHandler = requireUser >=> fun next ctx -> task {
let usr =
ctx.User.Claims
|> Seq.tryFind (fun c -> c.Type = ClaimTypes.GivenName)
@ -304,7 +311,7 @@ module Legal =
module Request =
// GET /request/[req-id]/edit
let edit requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let edit requestId : HttpHandler = requireUser >=> fun next ctx -> task {
let returnTo =
match ctx.Request.Headers.Referer[0] with
| it when it.EndsWith "/active" -> "active"
@ -315,7 +322,7 @@ module Request =
return! partial "Add Prayer Request"
(Views.Request.edit (JournalRequest.ofRequestLite Request.empty) returnTo true) next ctx
| _ ->
match! Data.tryJournalById (RequestId.ofString requestId) (userId ctx) (db ctx) with
match! Data.tryJournalById (RequestId.ofString requestId) ctx.UserId ctx.Db with
| Some req ->
debug ctx "Found - sending view"
return! partial "Edit Prayer Request" (Views.Request.edit req returnTo false) next ctx
@ -325,92 +332,93 @@ module Request =
}
// PATCH /request/[req-id]/prayed
let prayed requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let db = db ctx
let usrId = userId ctx
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId usrId db with
let prayed requestId : HttpHandler = requireUser >=> fun next ctx -> task {
let db = ctx.Db
let userId = ctx.UserId
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId userId db with
| Some req ->
let now = now ctx
do! Data.addHistory reqId usrId { AsOf = now; Status = Prayed; Text = None } db
let now = ctx.Now ()
do! Data.addHistory reqId userId { AsOf = now; Status = Prayed; Text = None } db
let nextShow =
match Recurrence.duration req.Recurrence with
| 0L -> Instant.MinValue
| duration -> now.Plus (Duration.FromSeconds duration)
do! Data.updateShowAfter reqId usrId nextShow db
do! db.saveChanges ()
| 0L -> None
| duration -> Some <| now.Plus (Duration.FromSeconds duration)
do! Data.updateShowAfter reqId userId nextShow db
do! db.SaveChanges ()
return! (withSuccessMessage "Request marked as prayed" >=> Components.journalItems) next ctx
| None -> return! Error.notFound next ctx
}
/// POST /request/[req-id]/note
let addNote requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let db = db ctx
let usrId = userId ctx
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId usrId db with
let addNote requestId : HttpHandler = requireUser >=> fun next ctx -> task {
let db = ctx.Db
let userId = ctx.UserId
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId userId db with
| Some _ ->
let! notes = ctx.BindFormAsync<Models.NoteEntry> ()
do! Data.addNote reqId usrId { AsOf = now ctx; Notes = notes.notes } db
do! db.saveChanges ()
do! Data.addNote reqId userId { AsOf = ctx.Now (); Notes = notes.notes } db
do! db.SaveChanges ()
return! (withSuccessMessage "Added Notes" >=> hideModal "notes" >=> created) next ctx
| None -> return! Error.notFound next ctx
}
// GET /requests/active
let active : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let! reqs = Data.journalByUserId (userId ctx) (db ctx)
return! partial "Active Requests" (Views.Request.active (now ctx) reqs) next ctx
let active : HttpHandler = requireUser >=> fun next ctx -> task {
let! reqs = Data.journalByUserId ctx.UserId ctx.Db
return! partial "Active Requests" (Views.Request.active (ctx.Now ()) reqs) next ctx
}
// GET /requests/snoozed
let snoozed : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let! reqs = Data.journalByUserId (userId ctx) (db ctx)
let now = now ctx
let snoozed = reqs |> List.filter (fun it -> it.SnoozedUntil > now)
return! partial "Active Requests" (Views.Request.snoozed now snoozed) next ctx
let snoozed : HttpHandler = requireUser >=> fun next ctx -> task {
let! reqs = Data.journalByUserId ctx.UserId ctx.Db
let now = ctx.Now ()
let snoozed = reqs
|> List.filter (fun it -> defaultArg (it.SnoozedUntil |> Option.map (fun it -> it > now)) false)
return! partial "Snoozed Requests" (Views.Request.snoozed now snoozed) next ctx
}
// GET /requests/answered
let answered : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let! reqs = Data.answeredRequests (userId ctx) (db ctx)
return! partial "Answered Requests" (Views.Request.answered (now ctx) reqs) next ctx
let answered : HttpHandler = requireUser >=> fun next ctx -> task {
let! reqs = Data.answeredRequests ctx.UserId ctx.Db
return! partial "Answered Requests" (Views.Request.answered (ctx.Now ()) reqs) next ctx
}
// GET /request/[req-id]/full
let getFull requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
match! Data.tryFullRequestById (RequestId.ofString requestId) (userId ctx) (db ctx) with
| Some req -> return! partial "Prayer Request" (Views.Request.full (clock ctx) req) next ctx
let getFull requestId : HttpHandler = requireUser >=> fun next ctx -> task {
match! Data.tryFullRequestById (RequestId.ofString requestId) ctx.UserId ctx.Db with
| Some req -> return! partial "Prayer Request" (Views.Request.full ctx.Clock req) next ctx
| None -> return! Error.notFound next ctx
}
// PATCH /request/[req-id]/show
let show requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let db = db ctx
let usrId = userId ctx
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId usrId db with
let show requestId : HttpHandler = requireUser >=> fun next ctx -> task {
let db = ctx.Db
let userId = ctx.UserId
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId userId db with
| Some _ ->
do! Data.updateShowAfter reqId usrId Instant.MinValue db
do! db.saveChanges ()
do! Data.updateShowAfter reqId userId None db
do! db.SaveChanges ()
return! (withSuccessMessage "Request now shown" >=> Components.requestItem requestId) next ctx
| None -> return! Error.notFound next ctx
}
// PATCH /request/[req-id]/snooze
let snooze requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let db = db ctx
let usrId = userId ctx
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId usrId db with
let snooze requestId : HttpHandler = requireUser >=> fun next ctx -> task {
let db = ctx.Db
let userId = ctx.UserId
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId userId db with
| Some _ ->
let! until = ctx.BindFormAsync<Models.SnoozeUntil> ()
let date =
LocalDatePattern.CreateWithInvariantCulture("yyyy-MM-dd").Parse(until.until).Value
.AtStartOfDayInZone(DateTimeZone.Utc)
.ToInstant ()
do! Data.updateSnoozed reqId usrId date db
do! db.saveChanges ()
do! Data.updateSnoozed reqId userId (Some date) db
do! db.SaveChanges ()
return!
(withSuccessMessage $"Request snoozed until {until.until}"
>=> hideModal "snooze"
@ -419,14 +427,14 @@ module Request =
}
// PATCH /request/[req-id]/cancel-snooze
let cancelSnooze requestId : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let db = db ctx
let usrId = userId ctx
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId usrId db with
let cancelSnooze requestId : HttpHandler = requireUser >=> fun next ctx -> task {
let db = ctx.Db
let userId = ctx.UserId
let reqId = RequestId.ofString requestId
match! Data.tryRequestById reqId userId db with
| Some _ ->
do! Data.updateSnoozed reqId usrId Instant.MinValue db
do! db.saveChanges ()
do! Data.updateSnoozed reqId userId None db
do! db.SaveChanges ()
return! (withSuccessMessage "Request unsnoozed" >=> Components.requestItem requestId) next ctx
| None -> return! Error.notFound next ctx
}
@ -437,52 +445,52 @@ module Request =
|> Recurrence.ofString
// POST /request
let add : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let! form = ctx.BindModelAsync<Models.Request> ()
let db = db ctx
let usrId = userId ctx
let now = now ctx
let req =
let add : HttpHandler = requireUser >=> fun next ctx -> task {
let! form = ctx.BindModelAsync<Models.Request> ()
let db = ctx.Db
let userId = ctx.UserId
let now = ctx.Now ()
let req =
{ Request.empty with
UserId = usrId
UserId = userId
EnteredOn = now
ShowAfter = Instant.MinValue
ShowAfter = None
Recurrence = parseRecurrence form
History = [
History = [|
{ AsOf = now
Status = Created
Text = Some form.requestText
}
]
|]
}
Data.addRequest req db
do! db.saveChanges ()
do! db.SaveChanges ()
Messages.pushSuccess ctx "Added prayer request" "/journal"
return! seeOther "/journal" next ctx
}
// PATCH /request
let update : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> backgroundTask {
let! form = ctx.BindModelAsync<Models.Request> ()
let db = db ctx
let usrId = userId ctx
match! Data.tryJournalById (RequestId.ofString form.requestId) usrId db with
let update : HttpHandler = requireUser >=> fun next ctx -> task {
let! form = ctx.BindModelAsync<Models.Request> ()
let db = ctx.Db
let userId = ctx.UserId
match! Data.tryJournalById (RequestId.ofString form.requestId) userId db with
| Some req ->
// update recurrence if changed
let recur = parseRecurrence form
match recur = req.Recurrence with
| true -> ()
| false ->
do! Data.updateRecurrence req.RequestId usrId recur db
do! Data.updateRecurrence req.RequestId userId recur db
match recur with
| Immediate -> do! Data.updateShowAfter req.RequestId usrId Instant.MinValue db
| Immediate -> do! Data.updateShowAfter req.RequestId userId None db
| _ -> ()
// append history
let upd8Text = form.requestText.Trim ()
let text = match upd8Text = req.Text with true -> None | false -> Some upd8Text
do! Data.addHistory req.RequestId usrId
{ AsOf = now ctx; Status = (Option.get >> RequestAction.ofString) form.status; Text = text } db
do! db.saveChanges ()
let text = if upd8Text = req.Text then None else Some upd8Text
do! Data.addHistory req.RequestId userId
{ AsOf = ctx.Now (); Status = (Option.get >> RequestAction.ofString) form.status; Text = text } db
do! db.SaveChanges ()
let nextUrl =
match form.returnTo with
| "active" -> "/requests/active"
@ -497,6 +505,7 @@ module Request =
/// Handlers for /user URLs
module User =
open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Authentication.Cookies
// GET /user/log-on
@ -504,7 +513,7 @@ module User =
logOn (Some "/journal")
// GET /user/log-off
let logOff : HttpHandler = requiresAuthentication Error.notAuthorized >=> fun next ctx -> task {
let logOff : HttpHandler = requireUser >=> fun next ctx -> task {
do! ctx.SignOutAsync ("Auth0", AuthenticationProperties (RedirectUri = "/"))
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
return! next ctx

284
src/MyPrayerJournal/Program.fs
View File

@ -7,174 +7,162 @@ open System.IO
/// Configuration functions for the application
module Configure =
/// Configure the content root
let contentRoot root =
WebApplicationOptions (ContentRootPath = root) |> WebApplication.CreateBuilder
/// Configure the content root
let contentRoot root =
WebApplicationOptions (ContentRootPath = root) |> WebApplication.CreateBuilder
open Microsoft.Extensions.Configuration
open Microsoft.Extensions.Configuration
/// Configure the application configuration
let appConfiguration (bldr : WebApplicationBuilder) =
bldr.Configuration
.SetBasePath(bldr.Environment.ContentRootPath)
.AddJsonFile("appsettings.json", optional = false, reloadOnChange = true)
.AddJsonFile($"appsettings.{bldr.Environment.EnvironmentName}.json", optional = true, reloadOnChange = true)
.AddEnvironmentVariables ()
|> ignore
bldr
/// Configure the application configuration
let appConfiguration (bldr : WebApplicationBuilder) =
bldr.Configuration
.SetBasePath(bldr.Environment.ContentRootPath)
.AddJsonFile("appsettings.json", optional = false, reloadOnChange = true)
.AddJsonFile($"appsettings.{bldr.Environment.EnvironmentName}.json", optional = true, reloadOnChange = true)
.AddEnvironmentVariables ()
|> ignore
bldr
open Microsoft.AspNetCore.Server.Kestrel.Core
open Microsoft.AspNetCore.Server.Kestrel.Core
/// Configure Kestrel from appsettings.json
let kestrel (bldr : WebApplicationBuilder) =
let kestrelOpts (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
(ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
bldr.WebHost.UseKestrel().ConfigureKestrel kestrelOpts |> ignore
bldr
/// Configure Kestrel from appsettings.json
let kestrel (bldr : WebApplicationBuilder) =
let kestrelOpts (ctx : WebHostBuilderContext) (opts : KestrelServerOptions) =
(ctx.Configuration.GetSection >> opts.Configure >> ignore) "Kestrel"
bldr.WebHost.UseKestrel().ConfigureKestrel kestrelOpts |> ignore
bldr
/// Configure the web root directory
let webRoot pathSegments (bldr : WebApplicationBuilder) =
Array.concat [ [| bldr.Environment.ContentRootPath |]; pathSegments ]
|> (Path.Combine >> bldr.WebHost.UseWebRoot >> ignore)
bldr
/// Configure the web root directory
let webRoot pathSegments (bldr : WebApplicationBuilder) =
Array.concat [ [| bldr.Environment.ContentRootPath |]; pathSegments ]
|> (Path.Combine >> bldr.WebHost.UseWebRoot >> ignore)
bldr
open Microsoft.Extensions.Logging
open Microsoft.Extensions.Hosting
open Microsoft.Extensions.Logging
open Microsoft.Extensions.Hosting
/// Configure logging
let logging (bldr : WebApplicationBuilder) =
match bldr.Environment.IsDevelopment () with
| true -> ()
| false -> bldr.Logging.AddFilter (fun l -> l > LogLevel.Information) |> ignore
bldr.Logging.AddConsole().AddDebug() |> ignore
bldr
/// Configure logging
let logging (bldr : WebApplicationBuilder) =
if bldr.Environment.IsDevelopment () then bldr.Logging.AddFilter (fun l -> l > LogLevel.Information) |> ignore
bldr.Logging.AddConsole().AddDebug() |> ignore
bldr
open Giraffe
open LiteDB
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Authentication.OpenIdConnect
open Microsoft.AspNetCore.Http
open Microsoft.Extensions.DependencyInjection
open Microsoft.IdentityModel.Protocols.OpenIdConnect
open NodaTime
open System
open System.Text.Json
open System.Text.Json.Serialization
open System.Threading.Tasks
open Giraffe
open LiteDB
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Authentication.OpenIdConnect
open Microsoft.AspNetCore.Http
open Microsoft.Extensions.DependencyInjection
open Microsoft.IdentityModel.Protocols.OpenIdConnect
open NodaTime
open System
open System.Text.Json
open System.Text.Json.Serialization
open System.Threading.Tasks
/// Configure dependency injection
let services (bldr : WebApplicationBuilder) =
let sameSite (opts : CookieOptions) =
match opts.SameSite, opts.Secure with
| SameSiteMode.None, false -> opts.SameSite <- SameSiteMode.Unspecified
| _, _ -> ()
/// Configure dependency injection
let services (bldr : WebApplicationBuilder) =
let sameSite (opts : CookieOptions) =
match opts.SameSite, opts.Secure with
| SameSiteMode.None, false -> opts.SameSite <- SameSiteMode.Unspecified
| _, _ -> ()
bldr.Services
.AddRouting()
.AddGiraffe()
.AddSingleton<IClock>(SystemClock.Instance)
.Configure<CookiePolicyOptions>(
fun (opts : CookiePolicyOptions) ->
opts.MinimumSameSitePolicy <- SameSiteMode.Unspecified
opts.OnAppendCookie <- fun ctx -> sameSite ctx.CookieOptions
opts.OnDeleteCookie <- fun ctx -> sameSite ctx.CookieOptions)
.AddAuthentication(
// Use HTTP "Bearer" authentication with JWTs
fun opts ->
opts.DefaultAuthenticateScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultSignInScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultChallengeScheme <- CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie()
.AddOpenIdConnect("Auth0",
// Configure OIDC with Auth0 options from configuration
fun opts ->
let cfg = bldr.Configuration.GetSection "Auth0"
opts.Authority <- $"""https://{cfg["Domain"]}/"""
opts.ClientId <- cfg["Id"]
opts.ClientSecret <- cfg["Secret"]
opts.ResponseType <- OpenIdConnectResponseType.Code
opts.Scope.Clear ()
opts.Scope.Add "openid"
opts.Scope.Add "profile"
opts.CallbackPath <- PathString "/user/log-on/success"
opts.ClaimsIssuer <- "Auth0"
opts.SaveTokens <- true
opts.Events <- OpenIdConnectEvents ()
opts.Events.OnRedirectToIdentityProviderForSignOut <- fun ctx ->
let returnTo =
match ctx.Properties.RedirectUri with
| it when isNull it || it = "" -> ""
| redirUri ->
let finalRedirUri =
match redirUri.StartsWith "/" with
| true ->
// transform to absolute
let request = ctx.Request
$"{request.Scheme}://{request.Host.Value}{request.PathBase.Value}{redirUri}"
| false -> redirUri
Uri.EscapeDataString $"&returnTo={finalRedirUri}"
ctx.Response.Redirect $"""https://{cfg["Domain"]}/v2/logout?client_id={cfg["Id"]}{returnTo}"""
ctx.HandleResponse ()
Task.CompletedTask
opts.Events.OnRedirectToIdentityProvider <- fun ctx ->
let bldr = UriBuilder ctx.ProtocolMessage.RedirectUri
bldr.Scheme <- cfg["Scheme"]
bldr.Port <- int cfg["Port"]
ctx.ProtocolMessage.RedirectUri <- string bldr
Task.CompletedTask
)
|> ignore
let jsonOptions = JsonSerializerOptions ()
jsonOptions.Converters.Add (JsonFSharpConverter ())
let db = new LiteDatabase (bldr.Configuration.GetConnectionString "db")
Data.Startup.ensureDb db
bldr.Services.AddSingleton(jsonOptions)
.AddSingleton<Json.ISerializer, SystemTextJson.Serializer>()
.AddSingleton<LiteDatabase> db
|> ignore
bldr.Build ()
let _ = bldr.Services.AddRouting ()
let _ = bldr.Services.AddGiraffe ()
let _ = bldr.Services.AddSingleton<IClock>(SystemClock.Instance)
let _ =
bldr.Services.Configure<CookiePolicyOptions>(fun (opts : CookiePolicyOptions) ->
opts.MinimumSameSitePolicy <- SameSiteMode.Unspecified
opts.OnAppendCookie <- fun ctx -> sameSite ctx.CookieOptions
opts.OnDeleteCookie <- fun ctx -> sameSite ctx.CookieOptions)
let _ =
bldr.Services.AddAuthentication(fun opts ->
opts.DefaultAuthenticateScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultSignInScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultChallengeScheme <- CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie()
.AddOpenIdConnect("Auth0", fun opts ->
// Configure OIDC with Auth0 options from configuration
let cfg = bldr.Configuration.GetSection "Auth0"
opts.Authority <- $"""https://{cfg["Domain"]}/"""
opts.ClientId <- cfg["Id"]
opts.ClientSecret <- cfg["Secret"]
opts.ResponseType <- OpenIdConnectResponseType.Code
opts.Scope.Clear ()
opts.Scope.Add "openid"
opts.Scope.Add "profile"
opts.CallbackPath <- PathString "/user/log-on/success"
opts.ClaimsIssuer <- "Auth0"
opts.SaveTokens <- true
opts.Events <- OpenIdConnectEvents ()
opts.Events.OnRedirectToIdentityProviderForSignOut <- fun ctx ->
let returnTo =
match ctx.Properties.RedirectUri with
| it when isNull it || it = "" -> ""
| redirUri ->
let finalRedirUri =
match redirUri.StartsWith "/" with
| true ->
// transform to absolute
let request = ctx.Request
$"{request.Scheme}://{request.Host.Value}{request.PathBase.Value}{redirUri}"
| false -> redirUri
Uri.EscapeDataString $"&returnTo={finalRedirUri}"
ctx.Response.Redirect $"""https://{cfg["Domain"]}/v2/logout?client_id={cfg["Id"]}{returnTo}"""
ctx.HandleResponse ()
Task.CompletedTask
opts.Events.OnRedirectToIdentityProvider <- fun ctx ->
let bldr = UriBuilder ctx.ProtocolMessage.RedirectUri
bldr.Scheme <- cfg["Scheme"]
bldr.Port <- int cfg["Port"]
ctx.ProtocolMessage.RedirectUri <- string bldr
Task.CompletedTask)
let jsonOptions = JsonSerializerOptions ()
jsonOptions.Converters.Add (JsonFSharpConverter ())
let db = new LiteDatabase (bldr.Configuration.GetConnectionString "db")
Data.Startup.ensureDb db
let _ = bldr.Services.AddSingleton jsonOptions
let _ = bldr.Services.AddSingleton<Json.ISerializer, SystemTextJson.Serializer> ()
let _ = bldr.Services.AddSingleton<LiteDatabase> db
bldr.Build ()
open Giraffe.EndpointRouting
open Giraffe.EndpointRouting
/// Configure the web application
let application (app : WebApplication) =
// match app.Environment.IsDevelopment () with
// | true -> app.UseDeveloperExceptionPage ()
// | false -> app.UseGiraffeErrorHandler Handlers.Error.error
// |> ignore
app
.UseStaticFiles()
.UseCookiePolicy()
.UseRouting()
.UseAuthentication()
.UseGiraffeErrorHandler(Handlers.Error.error)
.UseEndpoints (fun e -> e.MapGiraffeEndpoints Handlers.routes)
|> ignore
app
/// Configure the web application
let application (app : WebApplication) =
let _ = app.UseStaticFiles ()
let _ = app.UseCookiePolicy ()
let _ = app.UseRouting ()
let _ = app.UseAuthentication ()
let _ = app.UseGiraffeErrorHandler Handlers.Error.error
let _ = app.UseEndpoints (fun e -> e.MapGiraffeEndpoints Handlers.routes)
app
/// Compose all the configurations into one
let webHost pathSegments =
contentRoot
>> appConfiguration
>> kestrel
>> webRoot pathSegments
>> logging
>> services
>> application
/// Compose all the configurations into one
let webHost pathSegments =
contentRoot
>> appConfiguration
>> kestrel
>> webRoot pathSegments
>> logging
>> services
>> application
[<EntryPoint>]
let main _ =
use host = Configure.webHost [| "wwwroot" |] (Directory.GetCurrentDirectory ())
host.Run ()
0
use host = Configure.webHost [| "wwwroot" |] (Directory.GetCurrentDirectory ())
host.Run ()
0

24
src/MyPrayerJournal/Views/Layout.fs
View File

@ -1,27 +1,25 @@
/// Layout / home views
module MyPrayerJournal.Views.Layout
// fsharplint:disable RecordFieldNames
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility
/// The data needed to render a page-level view
type PageRenderContext =
{ /// Whether the user is authenticated
isAuthenticated : bool
IsAuthenticated : bool
/// Whether the user has snoozed requests
hasSnoozed : bool
HasSnoozed : bool
/// The current URL
currentUrl : string
CurrentUrl : string
/// The title for the page to be rendered
pageTitle : string
PageTitle : string
/// The content of the page
content : XmlNode
Content : XmlNode
}
/// The home page
@ -51,12 +49,12 @@ let private navBar ctx =
]
seq {
let navLink (matchUrl : string) =
match ctx.currentUrl.StartsWith matchUrl with true -> [ _class "is-active-route" ] | false -> []
match ctx.CurrentUrl.StartsWith matchUrl with true -> [ _class "is-active-route" ] | false -> []
|> pageLink matchUrl
if ctx.isAuthenticated then
if ctx.IsAuthenticated then
li [ _class "nav-item" ] [ navLink "/journal" [ str "Journal" ] ]
li [ _class "nav-item" ] [ navLink "/requests/active" [ str "Active" ] ]
if ctx.hasSnoozed then li [ _class "nav-item" ] [ navLink "/requests/snoozed" [ str "Snoozed" ] ]
if ctx.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" ] [ str "Log Off" ] ]
else li [ _class "nav-item"] [ a [ _href "/user/log-on" ] [ str "Log On" ] ]
@ -71,7 +69,7 @@ let private navBar ctx =
/// The title tag with the application name appended
let titleTag ctx =
title [] [ str ctx.pageTitle; rawText " &#xab; myPrayerJournal" ]
title [] [ str ctx.PageTitle; rawText " &#xab; myPrayerJournal" ]
/// The HTML `head` element
let htmlHead ctx =
@ -136,7 +134,7 @@ let view ctx =
html [ _lang "en" ] [
htmlHead ctx
body [] [
section [ _id "top"; _ariaLabel "Top navigation" ] [ navBar ctx; main [ _roleMain ] [ ctx.content ] ]
section [ _id "top"; _ariaLabel "Top navigation" ] [ navBar ctx; main [ _roleMain ] [ ctx.Content ] ]
toaster
htmlFoot
]
@ -146,5 +144,5 @@ let view ctx =
let partial ctx =
html [ _lang "en" ] [
head [] [ titleTag ctx ]
body [] [ navBar ctx; main [ _roleMain ] [ ctx.content ] ]
body [] [ navBar ctx; main [ _roleMain ] [ ctx.Content ] ]
]

40
src/MyPrayerJournal/Views/Request.fs
View File

@ -8,10 +8,11 @@ open NodaTime
/// Create a request within the list
let reqListItem now req =
let isFuture instant = defaultArg (instant |> Option.map (fun it -> it > now)) false
let reqId = RequestId.toString req.RequestId
let isAnswered = req.LastStatus = Answered
let isSnoozed = req.SnoozedUntil > now
let isPending = (not isSnoozed) && req.ShowAfter > now
let isSnoozed = isFuture req.SnoozedUntil
let isPending = (not isSnoozed) && isFuture req.ShowAfter
let btnClass = _class "btn btn-light mx-2"
let restoreBtn (link : string) title =
button [ btnClass; _hxPatch $"/request/{reqId}/{link}"; _title title ] [ icon "restore" ]
@ -27,9 +28,9 @@ let reqListItem now req =
if isSnoozed || isPending || isAnswered then
br []
small [ _class "text-muted" ] [
if isSnoozed then [ str "Snooze expires "; relativeDate req.SnoozedUntil now ]
elif isPending then [ str "Request appears next "; relativeDate req.ShowAfter now ]
else (* isAnswered *) [ str "Answered "; relativeDate req.AsOf now ]
if isSnoozed then [ str "Snooze expires "; relativeDate req.SnoozedUntil.Value now ]
elif isPending then [ str "Request appears next "; relativeDate req.ShowAfter.Value now ]
else (* isAnswered *) [ str "Answered "; relativeDate req.AsOf now ]
|> em []
]
]
@ -56,7 +57,7 @@ let answered now reqs =
article [ _class "container mt-3" ] [
h2 [ _class "pb-3" ] [ str "Answered Requests" ]
if List.isEmpty reqs then
noResults "No Active Requests" "/journal" "Return to your journal" [
noResults "No Answered Requests" "/journal" "Return to your journal" [
str "Your prayer journal has no answered requests; once you have marked one as "
rawText "&ldquo;Answered&rdquo;, it will appear here"
]
@ -75,29 +76,30 @@ let full (clock : IClock) (req : Request) =
let now = clock.GetCurrentInstant ()
let answered =
req.History
|> List.filter History.isAnswered
|> List.tryHead
|> Array.filter History.isAnswered
|> Array.tryHead
|> Option.map (fun x -> x.AsOf)
let prayed = (req.History |> List.filter History.isPrayed |> List.length).ToString "N0"
let prayed = (req.History |> Array.filter History.isPrayed |> Array.length).ToString "N0"
let daysOpen =
let asOf = defaultArg answered now
((asOf - (req.History |> List.filter History.isCreated |> List.head).AsOf).TotalDays |> int).ToString "N0"
((asOf - (req.History |> Array.filter History.isCreated |> Array.head).AsOf).TotalDays |> int).ToString "N0"
let lastText =
req.History
|> List.filter (fun h -> Option.isSome h.Text)
|> List.sortByDescending (fun h -> h.AsOf)
|> List.map (fun h -> Option.get h.Text)
|> List.head
|> Array.filter (fun h -> Option.isSome h.Text)
|> Array.sortByDescending (fun h -> h.AsOf)
|> Array.map (fun h -> Option.get h.Text)
|> Array.head
// The history log including notes (and excluding the final entry for answered requests)
let log =
let toDisp (h : History) = {| asOf = h.AsOf; text = h.Text; status = RequestAction.toString h.Status |}
let all =
req.Notes
|> List.map (fun n -> {| asOf = n.AsOf; text = Some n.Notes; status = "Notes" |})
|> List.append (req.History |> List.map toDisp)
|> List.sortByDescending (fun it -> it.asOf)
|> Array.map (fun n -> {| asOf = n.AsOf; text = Some n.Notes; status = "Notes" |})
|> Array.append (req.History |> Array.map toDisp)
|> Array.sortByDescending (fun it -> it.asOf)
|> List.ofArray
// Skip the first entry for answered requests; that info is already displayed
match answered with Some _ -> all |> List.skip 1 | None -> all
match answered with Some _ -> all.Tail | None -> all
article [ _class "container mt-3" ] [
div [_class "card" ] [
h5 [ _class "card-header" ] [ str "Full Prayer Request" ]
@ -111,7 +113,7 @@ let full (clock : IClock) (req : Request) =
relativeDate date now
rawText ") &bull; "
| None -> ()
sprintf "Prayed %s times &bull; Open %s days" prayed daysOpen |> rawText
rawText $"Prayed %s{prayed} times &bull; Open %s{daysOpen} days"
]
p [ _class "card-text" ] [ str lastText ]
]