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
}

291
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 System.Security.Claims
open LiteDB
open Microsoft.Extensions.Logging
open Microsoft.Net.Http.Headers
open Microsoft.AspNetCore.Http
open NodaTime
let debug (ctx : HttpContext) message =
let fac = ctx.GetService<ILoggerFactory>()
let log = fac.CreateLogger "Debug"
log.LogInformation message
/// Extensions on the HTTP context
type HttpContext with
/// Get the LiteDB database
let db (ctx : HttpContext) = ctx.GetService<LiteDatabase>()
/// The LiteDB database
member this.Db = this.GetService<LiteDatabase> ()
/// Get the user's "sub" claim
let user (ctx : HttpContext) =
ctx.User
/// 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)
/// 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
/// 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
/// Get the system clock
let clock (ctx : HttpContext) =
ctx.GetService<IClock> ()
/// The system clock
member this.Clock = this.GetService<IClock> ()
/// Get the current instant
let now ctx =
(clock ctx).GetCurrentInstant ()
/// Get the current instant from the system clock
member this.Now = this.Clock.GetCurrentInstant
/// Handler helpers
[<AutoOpen>]
module private Helpers =
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,20 +112,20 @@ 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
}
}
@ -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 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 usrId db with
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 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 usrId db with
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 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 usrId db with
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 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 usrId db with
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 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 usrId db with
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 add : HttpHandler = requireUser >=> fun next ctx -> task {
let! form = ctx.BindModelAsync<Models.Request> ()
let db = db ctx
let usrId = userId ctx
let now = now ctx
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 update : HttpHandler = requireUser >=> fun next ctx -> task {
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 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

56
src/MyPrayerJournal/Program.fs
View File

@ -47,9 +47,7 @@ module Configure =
/// Configure logging
let logging (bldr : WebApplicationBuilder) =
match bldr.Environment.IsDevelopment () with
| true -> ()
| false -> bldr.Logging.AddFilter (fun l -> l > LogLevel.Information) |> ignore
if bldr.Environment.IsDevelopment () then bldr.Logging.AddFilter (fun l -> l > LogLevel.Information) |> ignore
bldr.Logging.AddConsole().AddDebug() |> ignore
bldr
@ -74,25 +72,23 @@ module Configure =
| SameSiteMode.None, false -> opts.SameSite <- SameSiteMode.Unspecified
| _, _ -> ()
bldr.Services
.AddRouting()
.AddGiraffe()
.AddSingleton<IClock>(SystemClock.Instance)
.Configure<CookiePolicyOptions>(
fun (opts : CookiePolicyOptions) ->
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)
.AddAuthentication(
// Use HTTP "Bearer" authentication with JWTs
fun opts ->
let _ =
bldr.Services.AddAuthentication(fun opts ->
opts.DefaultAuthenticateScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultSignInScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultChallengeScheme <- CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie()
.AddOpenIdConnect("Auth0",
.AddOpenIdConnect("Auth0", fun opts ->
// Configure OIDC with Auth0 options from configuration
fun opts ->
let cfg = bldr.Configuration.GetSection "Auth0"
opts.Authority <- $"""https://{cfg["Domain"]}/"""
opts.ClientId <- cfg["Id"]
@ -123,24 +119,22 @@ module Configure =
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
Task.CompletedTask)
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
let _ = bldr.Services.AddSingleton jsonOptions
let _ = bldr.Services.AddSingleton<Json.ISerializer, SystemTextJson.Serializer> ()
let _ = bldr.Services.AddSingleton<LiteDatabase> db
bldr.Build ()
@ -148,18 +142,12 @@ module Configure =
/// 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
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

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 ] ]
]

38
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,8 +28,8 @@ 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 ]
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 ]
]