Handlers.fs

/// HTTP handlers for the myPrayerJournal API
[<RequireQualifiedAccess>]
module MyPrayerJournal.Handlers

// fsharplint:disable RecordFieldNames

open Giraffe
open Giraffe.Htmx
open Microsoft.AspNetCore.Authentication
open Microsoft.AspNetCore.Http
open System
open System.Security.Claims
open NodaTime

/// Helper function to be able to split out log on
[<AutoOpen>]
module private LogOnHelpers =

  /// Log on, optionally specifying a redirected URL once authentication is complete
  let logOn url : HttpHandler =
    fun next ctx -> backgroundTask {
      match url with
      | Some it ->
          do! ctx.ChallengeAsync ("Auth0", AuthenticationProperties (RedirectUri = it))
          return! next ctx
      | None -> return! challenge "Auth0" next ctx
      }

/// Handlers for error conditions
module Error =

  open Microsoft.Extensions.Logging
  open System.Threading.Tasks

  /// Handle errors
  let error (ex : Exception) (log : ILogger) =
    log.LogError (EventId(), ex, "An unhandled exception has occurred while executing the request.")
    clearResponse
    >=> setStatusCode 500
    >=> setHttpHeader "X-Toast" (sprintf "error|||%s: %s" (ex.GetType().Name) ex.Message)
    >=> text ex.Message

  /// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized reponse
  let notAuthorized : HttpHandler =
    fun next ctx ->
      (next, 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
  let notFound : HttpHandler =
    setStatusCode 404 >=> text "Not found"


/// Handler helpers
[<AutoOpen>]
module private Helpers =
  
  open LiteDB
  open Microsoft.Extensions.Logging
  open Microsoft.Net.Http.Headers

  let debug (ctx : HttpContext) message =
    let fac = ctx.GetService<ILoggerFactory>()
    let log = fac.CreateLogger "Debug"
    log.LogInformation message

  /// Get the LiteDB database
  let db (ctx : HttpContext) = ctx.GetService<LiteDatabase>()

  /// Get the user's "sub" claim
  let user (ctx : HttpContext) =
    ctx.User
    |> Option.ofObj
    |> Option.map (fun user -> user.Claims |> Seq.tryFind (fun u -> u.Type = ClaimTypes.NameIdentifier))
    |> Option.flatten
    |> Option.map (fun claim -> claim.Value)

  /// Get the current user's ID
  //  NOTE: this may raise if you don't run the request through the requiresAuthentication handler first
  let userId ctx =
    (user >> Option.get) ctx |> UserId

  /// Get the system clock
  let clock (ctx : HttpContext) =
    ctx.GetService<IClock> ()
  
  /// Get the current instant
  let now ctx =
    (clock ctx).GetCurrentInstant ()

  /// Return a 201 CREATED response
  let created =
    setStatusCode 201

  /// Return a 201 CREATED response with the location header set for the created resource
  let createdAt url : HttpHandler =
    fun next ctx ->
      (sprintf "%s://%s%s" ctx.Request.Scheme ctx.Request.Host.Value url |> setHttpHeader HeaderNames.Location
       >=> created) next ctx
  
  /// Return a 303 SEE OTHER response (forces a GET on the redirected URL)
  let seeOther (url : string) =
    noResponseCaching >=> setStatusCode 303 >=> setHttpHeader "Location" url

  /// Render a component result
  let renderComponent nodes : HttpHandler =
    noResponseCaching
    >=> fun next ctx -> backgroundTask {
      return! ctx.WriteHtmlStringAsync (ViewEngine.RenderView.AsString.htmlNodes nodes)
      }

  open Views.Layout

  /// Create a page rendering context
  let pageContext (ctx : HttpContext) pageTitle content = backgroundTask {
    let! hasSnoozed = backgroundTask {
      match user ctx with
      | Some _ -> return! Data.hasSnoozed (userId ctx) (now ctx) (db ctx)
      | None   -> return  false
      }
    return {
      isAuthenticated = (user >> Option.isSome) ctx
      hasSnoozed      = hasSnoozed
      currentUrl      = ctx.Request.Path.Value
      pageTitle       = pageTitle
      content         = content
      }
    }

  /// Composable handler to write a view to the output
  let writeView view : HttpHandler =
    fun next ctx -> backgroundTask {
      return! ctx.WriteHtmlViewAsync view
      }

  /// Hold messages across redirects
  module Messages =

    /// The messages being held
    let mutable private messages : Map<string, (string * string)> = Map.empty

    /// Locked update to prevent updates by multiple threads
    let private upd8 = obj ()

    /// Push a new message into the list
    let push ctx message url = lock upd8 (fun () ->
      messages <- messages.Add (ctx |> (user >> Option.get), (message, url)))

    /// Add a success message header to the response
    let pushSuccess ctx message url =
      push ctx (sprintf "success|||%s" message) url
    
    /// Pop the messages for the given user
    let pop userId = lock upd8 (fun () ->
      let msg = messages.TryFind userId
      msg |> Option.iter (fun _ -> messages <- messages.Remove userId)
      msg)

  /// Send a partial result if this is not a full page load (does not append no-cache headers)
  let partialStatic (pageTitle : string) content : HttpHandler =
    fun next ctx -> backgroundTask {
      let  isPartial = ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
      let! pageCtx   = pageContext ctx pageTitle content
      let  view      = (match isPartial with true -> partial | false -> view) pageCtx
      return! 
        (next, ctx)
        ||> match user ctx with
            | Some u ->
                match Messages.pop u with
                | Some (msg, url) -> setHttpHeader "X-Toast" msg >=> withHxPush url >=> writeView view
                | None -> writeView view
            | None -> writeView view
      }
   
  /// Send an explicitly non-cached result, rendering as a partial if this is not a full page load
  let partial pageTitle content =
    noResponseCaching >=> partialStatic pageTitle content

  /// Add a success message header to the response
  let withSuccessMessage : string -> HttpHandler =
    sprintf "success|||%s" >> setHttpHeader "X-Toast"
  
  /// Hide a modal window when the response is sent
  let hideModal (name : string) : HttpHandler =
    setHttpHeader "X-Hide-Modal" name


/// Strongly-typed models for post requests
module Models =
  
  /// An additional note
  [<CLIMutable; NoComparison; NoEquality>]
  type NoteEntry = {
    /// The notes being added
    notes : string
    }
  
  /// A prayer request
  [<CLIMutable; NoComparison; NoEquality>]
  type Request = {
    /// The ID of the request
    requestId     : string
    /// Where to redirect after saving
    returnTo      : string
    /// The text of the request
    requestText   : string
    /// The additional status to record
    status        : string option
    /// The recurrence type
    recurType     : string
    /// The recurrence count
    recurCount    : int16 option
    /// The recurrence interval
    recurInterval : string option
    }
  
  /// The date until which a request should not appear in the journal
  [<CLIMutable; NoComparison; NoEquality>]
  type SnoozeUntil = {
    /// The date (YYYY-MM-DD) at which the request should reappear
    until : string
    }


open MyPrayerJournal.Data.Extensions
open NodaTime.Text

/// Handlers for less-than-full-page HTML requests
module Components =

  // GET /components/journal-items
  let journalItems : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let  now   = now ctx
      let! jrnl  = Data.journalByUserId (userId ctx) (db ctx)
      let  shown = jrnl |> List.filter (fun it -> now > it.snoozedUntil && now > it.showAfter)
      return! renderComponent [ Views.Journal.journalItems now shown ] next ctx
      }
  
  // GET /components/request-item/[req-id]
  let requestItem reqId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      match! Data.tryJournalById (RequestId.ofString reqId) (userId ctx) (db ctx) with
      | Some req -> return! renderComponent [ Views.Request.reqListItem (now ctx) req ] next ctx
      | None     -> return! Error.notFound next ctx
      }

  // GET /components/request/[req-id]/add-notes
  let addNotes requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> renderComponent (Views.Journal.notesEdit (RequestId.ofString requestId))

  // GET /components/request/[req-id]/notes
  let notes requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let! notes = Data.notesById (RequestId.ofString requestId) (userId ctx) (db ctx)
      return! renderComponent (Views.Request.notes (now ctx) notes) next ctx
      }
  
  // GET /components/request/[req-id]/snooze
  let snooze requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> renderComponent [ RequestId.ofString requestId |> Views.Journal.snooze ]


/// / URL    
module Home =
  
  // GET /
  let home : HttpHandler =
    partialStatic "Welcome!" Views.Layout.home
  

/// /journal URL
module Journal =
  
  // GET /journal
  let journal : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let usr =
        ctx.User.Claims
        |> Seq.tryFind (fun c -> c.Type = ClaimTypes.GivenName)
        |> Option.map (fun c -> c.Value)
        |> Option.defaultValue "Your"
      let title = usr |> match usr with "Your" -> sprintf "%s" | _ -> sprintf "%s's"
      return! partial (sprintf "%s Prayer Journal" title) (Views.Journal.journal usr) next ctx
    }


/// /legal URLs
module Legal =
  
  // GET /legal/privacy-policy
  let privacyPolicy : HttpHandler =
    partialStatic "Privacy Policy" Views.Legal.privacyPolicy
  
  // GET /legal/terms-of-service
  let termsOfService : HttpHandler =
    partialStatic "Terms of Service" Views.Legal.termsOfService


/// /api/request and /request(s) URLs
module Request =

  // GET /request/[req-id]/edit  
  let edit requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let returnTo =
        match ctx.Request.Headers.Referer.[0] with
        | it when it.EndsWith "/active"  -> "active"
        | it when it.EndsWith "/snoozed" -> "snoozed"
        | _                              -> "journal"
      match requestId with
      | "new" ->
          return! partial "Add Prayer Request"
                    (Views.Request.edit (JournalRequest.ofRequestLite Request.empty) returnTo true) next ctx
      | _     ->
          match! Data.tryJournalById (RequestId.ofString requestId) (userId ctx) (db ctx) with
          | Some req ->
              debug ctx "Found - sending view"
              return! partial "Edit Prayer Request" (Views.Request.edit req returnTo false) next ctx
          | None     ->
              debug ctx "Not found - uh oh..."
              return! Error.notFound next ctx
      }

  // PATCH /request/[req-id]/prayed
  let prayed requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let db    = db     ctx
      let usrId = userId ctx
      let reqId = RequestId.ofString requestId
      match! Data.tryRequestById reqId usrId db with
      | Some req ->
          let now  = now ctx
          do! Data.addHistory reqId usrId { asOf = now; status = Prayed; text = None } db
          let nextShow =
            match Recurrence.duration req.recurType with
            | 0L       -> Instant.MinValue
            | duration -> now.Plus (Duration.FromSeconds (duration * int64 req.recurCount))
          do! Data.updateShowAfter reqId usrId nextShow db
          do! db.saveChanges ()
          return! (withSuccessMessage "Request marked as prayed" >=> Components.journalItems) next ctx
      | None -> return! Error.notFound next ctx
      }
  
  /// POST /request/[req-id]/note
  let addNote requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let db    = db     ctx
      let usrId = userId ctx
      let reqId = RequestId.ofString requestId
      match! Data.tryRequestById reqId usrId db with
      | Some _ ->
          let! notes = ctx.BindFormAsync<Models.NoteEntry> ()
          do! Data.addNote reqId usrId { asOf = now ctx; notes = notes.notes } db
          do! db.saveChanges ()
          return! (withSuccessMessage "Added Notes" >=> hideModal "notes" >=> created) next ctx
      | None -> return! Error.notFound next ctx
      }
          
  // GET /requests/active
  let active : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let! reqs = Data.journalByUserId (userId ctx) (db ctx)
      return! partial "Active Requests" (Views.Request.active (now ctx) reqs) next ctx
      }
  
  // GET /requests/snoozed
  let snoozed : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let! reqs    = Data.journalByUserId (userId ctx) (db ctx)
      let  now     = now ctx
      let  snoozed = reqs |> List.filter (fun it -> it.snoozedUntil > now)
      return! partial "Active Requests" (Views.Request.snoozed now snoozed) next ctx
      }

  // GET /requests/answered
  let answered : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let! reqs = Data.answeredRequests (userId ctx) (db ctx)
      return! partial "Answered Requests" (Views.Request.answered (now ctx) reqs) next ctx
      }
  
  // GET /api/request/[req-id]
  let get requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      match! Data.tryJournalById (RequestId.ofString requestId) (userId ctx) (db ctx) with
      | Some req -> return! json req next ctx
      | None -> return! Error.notFound next ctx
      }
  
  // GET /request/[req-id]/full
  let getFull requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      match! Data.tryFullRequestById (RequestId.ofString requestId) (userId ctx) (db ctx) with
      | Some req -> return! partial "Prayer Request" (Views.Request.full (clock ctx) req) next ctx
      | None     -> return! Error.notFound next ctx
      }
  
  // PATCH /request/[req-id]/show
  let show requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let db    = db     ctx
      let usrId = userId ctx
      let reqId = RequestId.ofString requestId
      match! Data.tryRequestById reqId usrId db with
      | Some _ ->
          do! Data.updateShowAfter reqId usrId Instant.MinValue db
          do! db.saveChanges ()
          return! (withSuccessMessage "Request now shown" >=> Components.requestItem requestId) next ctx
      | None -> return! Error.notFound next ctx
      }
  
  // PATCH /request/[req-id]/snooze
  let snooze requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let db    = db     ctx
      let usrId = userId ctx
      let reqId = RequestId.ofString requestId
      match! Data.tryRequestById reqId usrId db with
      | Some _ ->
          let! until = ctx.BindFormAsync<Models.SnoozeUntil> ()
          let date =
            LocalDatePattern.CreateWithInvariantCulture("yyyy-MM-dd").Parse(until.until).Value
              .AtStartOfDayInZone(DateTimeZone.Utc)
              .ToInstant ()
          do! Data.updateSnoozed reqId usrId date db
          do! db.saveChanges ()
          return!
            (withSuccessMessage $"Request snoozed until {until.until}"
             >=> hideModal "snooze"
             >=> Components.journalItems) next ctx
      | None -> return! Error.notFound next ctx
      }
  
  // PATCH /request/[req-id]/cancel-snooze
  let cancelSnooze requestId : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let db    = db     ctx
      let usrId = userId ctx
      let reqId = RequestId.ofString requestId
      match! Data.tryRequestById reqId usrId db with
      | Some _ ->
          do! Data.updateSnoozed reqId usrId Instant.MinValue db
          do! db.saveChanges ()
          return! (withSuccessMessage "Request unsnoozed" >=> Components.requestItem requestId) next ctx
      | None -> return! Error.notFound next ctx
      }

  /// Derive a recurrence and interval from its primitive representation in the form
  let private parseRecurrence (form : Models.Request) =
    (Recurrence.ofString (match form.recurInterval with Some x -> x | _ -> "Immediate"),
     defaultArg form.recurCount (int16 0))

  // POST /request
  let add : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let! form             = ctx.BindModelAsync<Models.Request> ()
      let  db               = db ctx
      let  usrId            = userId ctx
      let  now              = now ctx
      let (recur, interval) = parseRecurrence form
      let  req   =
        { Request.empty with
            userId     = usrId
            enteredOn  = now
            showAfter  = Instant.MinValue
            recurType  = recur
            recurCount = interval
            history    = [
              { asOf   = now
                status = Created
                text   = Some form.requestText
                }      
              ]
          }
      Data.addRequest req db
      do! db.saveChanges ()
      Messages.pushSuccess ctx "Added prayer request" "/journal"
      return! seeOther "/journal" next ctx
      }
  
  // PATCH /request
  let update : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> backgroundTask {
      let! form  = ctx.BindModelAsync<Models.Request> ()
      let  db    = db ctx
      let  usrId = userId ctx
      match! Data.tryJournalById (RequestId.ofString form.requestId) usrId db with
      | Some req ->
          // update recurrence if changed
          let (recur, interval) = parseRecurrence form
          match recur = req.recurType && interval = req.recurCount with
          | true  -> ()
          | false ->
              do! Data.updateRecurrence req.requestId usrId recur interval db
              match recur with
              | Immediate -> do! Data.updateShowAfter req.requestId usrId Instant.MinValue db
              | _         -> ()
          // append history
          let upd8Text = form.requestText.Trim ()
          let text     = match upd8Text = req.text with true -> None | false -> Some upd8Text
          do! Data.addHistory req.requestId usrId
                { asOf = now ctx; status = (Option.get >> RequestAction.ofString) form.status; text = text } db
          do! db.saveChanges ()
          let nextUrl =
            match form.returnTo with
            | "active"          -> "/requests/active"
            | "snoozed"         -> "/requests/snoozed"
            | _ (* "journal" *) -> "/journal"
          Messages.pushSuccess ctx "Prayer request updated successfully" nextUrl
          return! seeOther nextUrl next ctx
      | None -> return! Error.notFound next ctx
      }


/// Handlers for /user URLs
module User =

  open Microsoft.AspNetCore.Authentication.Cookies

  // GET /user/log-on
  let logOn : HttpHandler =
    logOn (Some "/journal")
  
  // GET /user/log-off
  let logOff : HttpHandler =
    requiresAuthentication Error.notAuthorized
    >=> fun next ctx -> task {
      do! ctx.SignOutAsync ("Auth0", AuthenticationProperties (RedirectUri = "/"))
      do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
      return! next ctx
    }


open Giraffe.EndpointRouting

/// The routes for myPrayerJournal
let routes =
  [ GET_HEAD [ route "/" Home.home ]
    subRoute "/components/" [
      GET_HEAD [
        route  "journal-items"        Components.journalItems
        routef "request/%s/add-notes" Components.addNotes
        routef "request/%s/item"      Components.requestItem
        routef "request/%s/notes"     Components.notes
        routef "request/%s/snooze"    Components.snooze
        ]
      ]
    GET_HEAD [ route "/journal" Journal.journal ]
    subRoute "/legal/" [
      GET_HEAD [
        route "privacy-policy"   Legal.privacyPolicy
        route "terms-of-service" Legal.termsOfService
        ]
      ]
    subRoute "/request" [
      GET_HEAD [
        routef "/%s/edit"   Request.edit
        routef "/%s/full"   Request.getFull
        route  "s/active"   Request.active
        route  "s/answered" Request.answered
        route  "s/snoozed"  Request.snoozed
        ]
      PATCH [
        route  ""                  Request.update
        routef "/%s/cancel-snooze" Request.cancelSnooze
        routef "/%s/prayed"        Request.prayed
        routef "/%s/show"          Request.show
        routef "/%s/snooze"        Request.snooze
        ]
      POST [
        route  ""         Request.add
        routef "/%s/note" Request.addNote
        ]
      ]
    subRoute "/user/" [
      GET_HEAD [
        route "log-off" User.logOff
        route "log-on"  User.logOn
        ]
      ]
    ]