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

Version 3.1 #71

Merged
danieljsummers merged 9 commits from v3.1 into main 2022-07-30 21:02:58 +00:00
Conversation 0 Commits 9 Files Changed 19 +406 -378
7 changed files with 406 additions and 378 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit bdf870343d - Show all commits

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

@ -81,13 +81,19 @@ let convertNote (old : OldNote) =
Notes = old.notes 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 /// Map the old request to the new request
let convert old = let convert old =
{ Id = old.id { Id = old.id
EnteredOn = Instant.FromUnixTimeMilliseconds old.enteredOn EnteredOn = Instant.FromUnixTimeMilliseconds old.enteredOn
UserId = old.userId UserId = old.userId
SnoozedUntil = Instant.FromUnixTimeMilliseconds old.snoozedUntil SnoozedUntil = noneIfOld old.snoozedUntil
ShowAfter = Instant.FromUnixTimeMilliseconds old.showAfter ShowAfter = noneIfOld old.showAfter
Recurrence = mapRecurrence old Recurrence = mapRecurrence old
History = old.history |> Array.map convertHistory |> List.ofArray History = old.history |> Array.map convertHistory |> List.ofArray
Notes = old.notes |> Array.map convertNote |> 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) /// Remove the old request, add the converted one (removes recurType / recurCount fields)
let replace (req : Request) = let replace (req : Request) =
db.requests.Delete (Mapping.RequestId.toBson req.Id) |> ignore db.Requests.Delete (Mapping.RequestId.toBson req.Id) |> ignore
db.requests.Insert req |> ignore db.Requests.Insert req |> ignore
db.Checkpoint () db.Checkpoint ()
db.GetCollection<OldRequest>("request").FindAll () db.GetCollection<OldRequest>("request").FindAll ()

49
src/MyPrayerJournal/Data.fs
View File

@ -2,11 +2,7 @@
open LiteDB open LiteDB
open MyPrayerJournal open MyPrayerJournal
open NodaTime
open System.Threading.Tasks open System.Threading.Tasks
open NodaTime.Text
// fsharplint:disable MemberNames
/// LiteDB extensions /// LiteDB extensions
[<AutoOpen>] [<AutoOpen>]
@ -16,11 +12,10 @@ module Extensions =
type LiteDatabase with type LiteDatabase with
/// The Request collection /// The Request collection
member this.requests member this.Requests = this.GetCollection<Request> "request"
with get () = this.GetCollection<Request> "request"
/// Async version of the checkpoint command (flushes log) /// Async version of the checkpoint command (flushes log)
member this.saveChanges () = member this.SaveChanges () =
this.Checkpoint () this.Checkpoint ()
Task.CompletedTask Task.CompletedTask
@ -30,6 +25,9 @@ module Extensions =
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module Mapping = module Mapping =
open NodaTime
open NodaTime.Text
/// A NodaTime instant pattern to use for parsing instants from the database /// A NodaTime instant pattern to use for parsing instants from the database
let instantPattern = InstantPattern.CreateWithInvariantCulture "g" let instantPattern = InstantPattern.CreateWithInvariantCulture "g"
@ -40,6 +38,9 @@ module Mapping =
/// Mapping for option types /// Mapping for option types
module Option = 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 stringFromBson (value : BsonValue) = match value.AsString with "" -> None | x -> Some x
let stringToBson (value : string option) : BsonValue = match value with Some txt -> txt | None -> "" let stringToBson (value : string option) : BsonValue = match value with Some txt -> txt | None -> ""
@ -66,6 +67,7 @@ module Mapping =
/// Set up the mapping /// Set up the mapping
let register () = let register () =
BsonMapper.Global.RegisterType<Instant>(Instant.toBson, Instant.fromBson) 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<Recurrence>(Recurrence.toBson, Recurrence.fromBson)
BsonMapper.Global.RegisterType<RequestAction>(RequestAction.toBson, RequestAction.fromBson) BsonMapper.Global.RegisterType<RequestAction>(RequestAction.toBson, RequestAction.fromBson)
BsonMapper.Global.RegisterType<RequestId>(RequestId.toBson, RequestId.fromBson) BsonMapper.Global.RegisterType<RequestId>(RequestId.toBson, RequestId.fromBson)
@ -77,7 +79,7 @@ module Startup =
/// Ensure the database is set up /// Ensure the database is set up
let ensureDb (db : LiteDatabase) = let ensureDb (db : LiteDatabase) =
db.requests.EnsureIndex (fun it -> it.UserId) |> ignore db.Requests.EnsureIndex (fun it -> it.UserId) |> ignore
Mapping.register () Mapping.register ()
@ -97,39 +99,42 @@ module private Helpers =
/// Async wrapper around a request update /// Async wrapper around a request update
let doUpdate (db : LiteDatabase) (req : Request) = let doUpdate (db : LiteDatabase) (req : Request) =
db.requests.Update req |> ignore db.Requests.Update req |> ignore
Task.CompletedTask Task.CompletedTask
/// Retrieve a request, including its history and notes, by its ID and user ID /// Retrieve a request, including its history and notes, by its ID and user ID
let tryFullRequestById reqId userId (db : LiteDatabase) = backgroundTask { 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 return match box req with null -> None | _ when req.UserId = userId -> Some req | _ -> None
} }
/// Add a history entry /// Add a history entry
let addHistory reqId userId hist db = backgroundTask { let addHistory reqId userId hist db = backgroundTask {
match! tryFullRequestById reqId userId db with 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" | None -> invalidOp $"{RequestId.toString reqId} not found"
} }
/// Add a note /// Add a note
let addNote reqId userId note db = backgroundTask { let addNote reqId userId note db = backgroundTask {
match! tryFullRequestById reqId userId db with 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" | None -> invalidOp $"{RequestId.toString reqId} not found"
} }
/// Add a request /// Add a request
let addRequest (req : Request) (db : LiteDatabase) = 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 /// Retrieve all answered requests for the given user
let answeredRequests userId (db : LiteDatabase) = backgroundTask { let answeredRequests userId db = backgroundTask {
let! reqs = db.requests.Find (Query.EQ ("userId", UserId.toString userId)) |> toListAsync let! reqs = getRequestsForUser userId db
return return
reqs reqs
|> Seq.map JournalRequest.ofRequestFull |> Seq.map JournalRequest.ofRequestFull
@ -139,10 +144,10 @@ let answeredRequests userId (db : LiteDatabase) = backgroundTask {
} }
/// Retrieve the user's current journal /// Retrieve the user's current journal
let journalByUserId userId (db : LiteDatabase) = backgroundTask { let journalByUserId userId db = backgroundTask {
let! jrnl = db.requests.Find (Query.EQ ("userId", UserId.toString userId)) |> toListAsync let! reqs = getRequestsForUser userId db
return return
jrnl reqs
|> Seq.map JournalRequest.ofRequestLite |> Seq.map JournalRequest.ofRequestLite
|> Seq.filter (fun it -> it.LastStatus <> Answered) |> Seq.filter (fun it -> it.LastStatus <> Answered)
|> Seq.sortBy (fun it -> it.AsOf) |> Seq.sortBy (fun it -> it.AsOf)
@ -152,18 +157,18 @@ let journalByUserId userId (db : LiteDatabase) = backgroundTask {
/// Does the user have any snoozed requests? /// Does the user have any snoozed requests?
let hasSnoozed userId now (db : LiteDatabase) = backgroundTask { let hasSnoozed userId now (db : LiteDatabase) = backgroundTask {
let! jrnl = journalByUserId userId db 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) /// Retrieve a request by its ID and user ID (without notes and history)
let tryRequestById reqId userId db = backgroundTask { let tryRequestById reqId userId db = backgroundTask {
let! req = tryFullRequestById reqId userId db 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 /// Retrieve notes for a request by its ID and user ID
let notesById reqId userId (db : LiteDatabase) = backgroundTask { 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 /// 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 UserId : UserId
/// The time at which this request should reappear in the user's journal by manual user choice /// 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 /// 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 /// The recurrence for this request
Recurrence : Recurrence Recurrence : Recurrence
/// The history entries for this request /// The history entries for this request
History : History list History : History[]
/// The notes for this request /// The notes for this request
Notes : Note list Notes : Note[]
} }
/// Functions to support requests /// Functions to support requests
@ -183,11 +183,11 @@ module Request =
{ Id = Cuid.generate () |> RequestId { Id = Cuid.generate () |> RequestId
EnteredOn = Instant.MinValue EnteredOn = Instant.MinValue
UserId = UserId "" UserId = UserId ""
SnoozedUntil = Instant.MinValue SnoozedUntil = None
ShowAfter = Instant.MinValue ShowAfter = None
Recurrence = Immediate Recurrence = Immediate
History = [] History = [||]
Notes = [] Notes = [||]
} }
@ -211,10 +211,10 @@ type JournalRequest =
LastStatus : RequestAction LastStatus : RequestAction
/// The time that this request should reappear in the user's journal /// 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 /// 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 /// The recurrence for this request
Recurrence : Recurrence Recurrence : Recurrence
@ -231,17 +231,37 @@ module JournalRequest =
/// Convert a request to the form used for the journal (precomputed values, no notes or history) /// Convert a request to the form used for the journal (precomputed values, no notes or history)
let ofRequestLite (req : Request) = 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 { RequestId = req.Id
UserId = req.UserId UserId = req.UserId
Text = req.History Text = req.History
|> List.filter (fun it -> Option.isSome it.Text) |> Array.filter (fun it -> Option.isSome it.Text)
|> List.sortByDescending (fun it -> it.AsOf) |> Array.sortByDescending (fun it -> it.AsOf)
|> List.tryHead |> Array.tryHead
|> Option.map (fun h -> Option.get h.Text) |> Option.map (fun h -> Option.get h.Text)
|> Option.defaultValue "" |> Option.defaultValue ""
AsOf = match hist with Some h -> h.AsOf | None -> Instant.MinValue AsOf = asOf
LastStatus = match hist with Some h -> h.Status | None -> Created LastStatus = match lastHistory with Some h -> h.Status | None -> Created
SnoozedUntil = req.SnoozedUntil SnoozedUntil = req.SnoozedUntil
ShowAfter = req.ShowAfter ShowAfter = req.ShowAfter
Recurrence = req.Recurrence Recurrence = req.Recurrence
@ -252,6 +272,6 @@ module JournalRequest =
/// Same as `ofRequestLite`, but with notes and history /// Same as `ofRequestLite`, but with notes and history
let ofRequestFull req = let ofRequestFull req =
{ ofRequestLite req with { ofRequestLite req with
History = req.History History = List.ofArray req.History
Notes = req.Notes Notes = List.ofArray req.Notes
} }

291
src/MyPrayerJournal/Handlers.fs
View File

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

56
src/MyPrayerJournal/Program.fs
View File

@ -47,9 +47,7 @@ module Configure =
/// Configure logging /// Configure logging
let logging (bldr : WebApplicationBuilder) = let logging (bldr : WebApplicationBuilder) =
match bldr.Environment.IsDevelopment () with if bldr.Environment.IsDevelopment () then bldr.Logging.AddFilter (fun l -> l > LogLevel.Information) |> ignore
| true -> ()
| false -> bldr.Logging.AddFilter (fun l -> l > LogLevel.Information) |> ignore
bldr.Logging.AddConsole().AddDebug() |> ignore bldr.Logging.AddConsole().AddDebug() |> ignore
bldr bldr
@ -74,25 +72,23 @@ module Configure =
| SameSiteMode.None, false -> opts.SameSite <- SameSiteMode.Unspecified | SameSiteMode.None, false -> opts.SameSite <- SameSiteMode.Unspecified
| _, _ -> () | _, _ -> ()
bldr.Services let _ = bldr.Services.AddRouting ()
.AddRouting() let _ = bldr.Services.AddGiraffe ()
.AddGiraffe() let _ = bldr.Services.AddSingleton<IClock>(SystemClock.Instance)
.AddSingleton<IClock>(SystemClock.Instance)
.Configure<CookiePolicyOptions>( let _ =
fun (opts : CookiePolicyOptions) -> bldr.Services.Configure<CookiePolicyOptions>(fun (opts : CookiePolicyOptions) ->
opts.MinimumSameSitePolicy <- SameSiteMode.Unspecified opts.MinimumSameSitePolicy <- SameSiteMode.Unspecified
opts.OnAppendCookie <- fun ctx -> sameSite ctx.CookieOptions opts.OnAppendCookie <- fun ctx -> sameSite ctx.CookieOptions
opts.OnDeleteCookie <- fun ctx -> sameSite ctx.CookieOptions) opts.OnDeleteCookie <- fun ctx -> sameSite ctx.CookieOptions)
.AddAuthentication( let _ =
// Use HTTP "Bearer" authentication with JWTs bldr.Services.AddAuthentication(fun opts ->
fun opts ->
opts.DefaultAuthenticateScheme <- CookieAuthenticationDefaults.AuthenticationScheme opts.DefaultAuthenticateScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultSignInScheme <- CookieAuthenticationDefaults.AuthenticationScheme opts.DefaultSignInScheme <- CookieAuthenticationDefaults.AuthenticationScheme
opts.DefaultChallengeScheme <- CookieAuthenticationDefaults.AuthenticationScheme) opts.DefaultChallengeScheme <- CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie() .AddCookie()
.AddOpenIdConnect("Auth0", .AddOpenIdConnect("Auth0", fun opts ->
// Configure OIDC with Auth0 options from configuration // Configure OIDC with Auth0 options from configuration
fun opts ->
let cfg = bldr.Configuration.GetSection "Auth0" let cfg = bldr.Configuration.GetSection "Auth0"
opts.Authority <- $"""https://{cfg["Domain"]}/""" opts.Authority <- $"""https://{cfg["Domain"]}/"""
opts.ClientId <- cfg["Id"] opts.ClientId <- cfg["Id"]
@ -123,24 +119,22 @@ module Configure =
Uri.EscapeDataString $"&returnTo={finalRedirUri}" Uri.EscapeDataString $"&returnTo={finalRedirUri}"
ctx.Response.Redirect $"""https://{cfg["Domain"]}/v2/logout?client_id={cfg["Id"]}{returnTo}""" ctx.Response.Redirect $"""https://{cfg["Domain"]}/v2/logout?client_id={cfg["Id"]}{returnTo}"""
ctx.HandleResponse () ctx.HandleResponse ()
Task.CompletedTask Task.CompletedTask
opts.Events.OnRedirectToIdentityProvider <- fun ctx -> opts.Events.OnRedirectToIdentityProvider <- fun ctx ->
let bldr = UriBuilder ctx.ProtocolMessage.RedirectUri let bldr = UriBuilder ctx.ProtocolMessage.RedirectUri
bldr.Scheme <- cfg["Scheme"] bldr.Scheme <- cfg["Scheme"]
bldr.Port <- int cfg["Port"] bldr.Port <- int cfg["Port"]
ctx.ProtocolMessage.RedirectUri <- string bldr ctx.ProtocolMessage.RedirectUri <- string bldr
Task.CompletedTask Task.CompletedTask)
)
|> ignore
let jsonOptions = JsonSerializerOptions () let jsonOptions = JsonSerializerOptions ()
jsonOptions.Converters.Add (JsonFSharpConverter ()) jsonOptions.Converters.Add (JsonFSharpConverter ())
let db = new LiteDatabase (bldr.Configuration.GetConnectionString "db") let db = new LiteDatabase (bldr.Configuration.GetConnectionString "db")
Data.Startup.ensureDb db Data.Startup.ensureDb db
bldr.Services.AddSingleton(jsonOptions) let _ = bldr.Services.AddSingleton jsonOptions
.AddSingleton<Json.ISerializer, SystemTextJson.Serializer>() let _ = bldr.Services.AddSingleton<Json.ISerializer, SystemTextJson.Serializer> ()
.AddSingleton<LiteDatabase> db let _ = bldr.Services.AddSingleton<LiteDatabase> db
|> ignore
bldr.Build () bldr.Build ()
@ -148,18 +142,12 @@ module Configure =
/// Configure the web application /// Configure the web application
let application (app : WebApplication) = let application (app : WebApplication) =
// match app.Environment.IsDevelopment () with let _ = app.UseStaticFiles ()
// | true -> app.UseDeveloperExceptionPage () let _ = app.UseCookiePolicy ()
// | false -> app.UseGiraffeErrorHandler Handlers.Error.error let _ = app.UseRouting ()
// |> ignore let _ = app.UseAuthentication ()
app let _ = app.UseGiraffeErrorHandler Handlers.Error.error
.UseStaticFiles() let _ = app.UseEndpoints (fun e -> e.MapGiraffeEndpoints Handlers.routes)
.UseCookiePolicy()
.UseRouting()
.UseAuthentication()
.UseGiraffeErrorHandler(Handlers.Error.error)
.UseEndpoints (fun e -> e.MapGiraffeEndpoints Handlers.routes)
|> ignore
app app
/// Compose all the configurations into one /// Compose all the configurations into one

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

@ -1,27 +1,25 @@
/// Layout / home views /// Layout / home views
module MyPrayerJournal.Views.Layout module MyPrayerJournal.Views.Layout
// fsharplint:disable RecordFieldNames
open Giraffe.ViewEngine open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility open Giraffe.ViewEngine.Accessibility
/// The data needed to render a page-level view /// The data needed to render a page-level view
type PageRenderContext = type PageRenderContext =
{ /// Whether the user is authenticated { /// Whether the user is authenticated
isAuthenticated : bool IsAuthenticated : bool
/// Whether the user has snoozed requests /// Whether the user has snoozed requests
hasSnoozed : bool HasSnoozed : bool
/// The current URL /// The current URL
currentUrl : string CurrentUrl : string
/// The title for the page to be rendered /// The title for the page to be rendered
pageTitle : string PageTitle : string
/// The content of the page /// The content of the page
content : XmlNode Content : XmlNode
} }
/// The home page /// The home page
@ -51,12 +49,12 @@ let private navBar ctx =
] ]
seq { seq {
let navLink (matchUrl : string) = 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 |> pageLink matchUrl
if ctx.isAuthenticated then if ctx.IsAuthenticated then
li [ _class "nav-item" ] [ navLink "/journal" [ str "Journal" ] ] li [ _class "nav-item" ] [ navLink "/journal" [ str "Journal" ] ]
li [ _class "nav-item" ] [ navLink "/requests/active" [ str "Active" ] ] 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" ] [ navLink "/requests/answered" [ str "Answered" ] ]
li [ _class "nav-item" ] [ a [ _href "/user/log-off" ] [ str "Log Off" ] ] 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" ] ] 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 /// The title tag with the application name appended
let titleTag ctx = let titleTag ctx =
title [] [ str ctx.pageTitle; rawText " &#xab; myPrayerJournal" ] title [] [ str ctx.PageTitle; rawText " &#xab; myPrayerJournal" ]
/// The HTML `head` element /// The HTML `head` element
let htmlHead ctx = let htmlHead ctx =
@ -136,7 +134,7 @@ let view ctx =
html [ _lang "en" ] [ html [ _lang "en" ] [
htmlHead ctx htmlHead ctx
body [] [ 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 toaster
htmlFoot htmlFoot
] ]
@ -146,5 +144,5 @@ let view ctx =
let partial ctx = let partial ctx =
html [ _lang "en" ] [ html [ _lang "en" ] [
head [] [ titleTag ctx ] 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 /// Create a request within the list
let reqListItem now req = let reqListItem now req =
let isFuture instant = defaultArg (instant |> Option.map (fun it -> it > now)) false
let reqId = RequestId.toString req.RequestId let reqId = RequestId.toString req.RequestId
let isAnswered = req.LastStatus = Answered let isAnswered = req.LastStatus = Answered
let isSnoozed = req.SnoozedUntil > now let isSnoozed = isFuture req.SnoozedUntil
let isPending = (not isSnoozed) && req.ShowAfter > now let isPending = (not isSnoozed) && isFuture req.ShowAfter
let btnClass = _class "btn btn-light mx-2" let btnClass = _class "btn btn-light mx-2"
let restoreBtn (link : string) title = let restoreBtn (link : string) title =
button [ btnClass; _hxPatch $"/request/{reqId}/{link}"; _title title ] [ icon "restore" ] button [ btnClass; _hxPatch $"/request/{reqId}/{link}"; _title title ] [ icon "restore" ]
@ -27,8 +28,8 @@ let reqListItem now req =
if isSnoozed || isPending || isAnswered then if isSnoozed || isPending || isAnswered then
br [] br []
small [ _class "text-muted" ] [ small [ _class "text-muted" ] [
if isSnoozed then [ str "Snooze expires "; relativeDate req.SnoozedUntil now ] if isSnoozed then [ str "Snooze expires "; relativeDate req.SnoozedUntil.Value now ]
elif isPending then [ str "Request appears next "; relativeDate req.ShowAfter now ] elif isPending then [ str "Request appears next "; relativeDate req.ShowAfter.Value now ]
else (* isAnswered *) [ str "Answered "; relativeDate req.AsOf now ] else (* isAnswered *) [ str "Answered "; relativeDate req.AsOf now ]
|> em [] |> em []
] ]
@ -56,7 +57,7 @@ let answered now reqs =
article [ _class "container mt-3" ] [ article [ _class "container mt-3" ] [
h2 [ _class "pb-3" ] [ str "Answered Requests" ] h2 [ _class "pb-3" ] [ str "Answered Requests" ]
if List.isEmpty reqs then 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 " str "Your prayer journal has no answered requests; once you have marked one as "
rawText "&ldquo;Answered&rdquo;, it will appear here" rawText "&ldquo;Answered&rdquo;, it will appear here"
] ]
@ -75,29 +76,30 @@ let full (clock : IClock) (req : Request) =
let now = clock.GetCurrentInstant () let now = clock.GetCurrentInstant ()
let answered = let answered =
req.History req.History
|> List.filter History.isAnswered |> Array.filter History.isAnswered
|> List.tryHead |> Array.tryHead
|> Option.map (fun x -> x.AsOf) |> 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 daysOpen =
let asOf = defaultArg answered now 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 = let lastText =
req.History req.History
|> List.filter (fun h -> Option.isSome h.Text) |> Array.filter (fun h -> Option.isSome h.Text)
|> List.sortByDescending (fun h -> h.AsOf) |> Array.sortByDescending (fun h -> h.AsOf)
|> List.map (fun h -> Option.get h.Text) |> Array.map (fun h -> Option.get h.Text)
|> List.head |> Array.head
// The history log including notes (and excluding the final entry for answered requests) // The history log including notes (and excluding the final entry for answered requests)
let log = let log =
let toDisp (h : History) = {| asOf = h.AsOf; text = h.Text; status = RequestAction.toString h.Status |} let toDisp (h : History) = {| asOf = h.AsOf; text = h.Text; status = RequestAction.toString h.Status |}
let all = let all =
req.Notes req.Notes
|> List.map (fun n -> {| asOf = n.AsOf; text = Some n.Notes; status = "Notes" |}) |> Array.map (fun n -> {| asOf = n.AsOf; text = Some n.Notes; status = "Notes" |})
|> List.append (req.History |> List.map toDisp) |> Array.append (req.History |> Array.map toDisp)
|> List.sortByDescending (fun it -> it.asOf) |> Array.sortByDescending (fun it -> it.asOf)
|> List.ofArray
// Skip the first entry for answered requests; that info is already displayed // 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" ] [ article [ _class "container mt-3" ] [
div [_class "card" ] [ div [_class "card" ] [
h5 [ _class "card-header" ] [ str "Full Prayer Request" ] h5 [ _class "card-header" ] [ str "Full Prayer Request" ]
@ -111,7 +113,7 @@ let full (clock : IClock) (req : Request) =
relativeDate date now relativeDate date now
rawText ") &bull; " rawText ") &bull; "
| None -> () | 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 ] p [ _class "card-text" ] [ str lastText ]
] ]