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

311
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>] open LiteDB
module private Helpers = open Microsoft.AspNetCore.Http
open NodaTime
open LiteDB /// Extensions on the HTTP context
open Microsoft.Extensions.Logging type HttpContext with
open Microsoft.Net.Http.Headers
let debug (ctx : HttpContext) message = /// The LiteDB database
let fac = ctx.GetService<ILoggerFactory>() member this.Db = this.GetService<LiteDatabase> ()
let log = fac.CreateLogger "Debug"
log.LogInformation message
/// Get the LiteDB database /// The "sub" for the current user (None if no user is authenticated)
let db (ctx : HttpContext) = ctx.GetService<LiteDatabase>() member this.CurrentUser =
this.User
/// Get the user's "sub" claim
let user (ctx : HttpContext) =
ctx.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,21 +112,21 @@ 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 }
}
} }
/// Composable handler to write a view to the output /// Composable handler to write a view to the output
@ -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

276
src/MyPrayerJournal/Program.fs
View File

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

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

40
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,9 +28,9 @@ 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 ]
] ]