myWebLog/src/MyWebLog/Handlers/Helpers.fs

[<AutoOpen>]
module private MyWebLog.Handlers.Helpers

open System.Text.Json
open Microsoft.AspNetCore.Http
open MyWebLog.Views

/// Session extensions to get and set objects
type ISession with
    
    /// Set an item in the session
    member this.Set<'T>(key, item: 'T) =
        this.SetString(key, JsonSerializer.Serialize item)
    
    /// Get an item from the session
    member this.TryGet<'T> key =
        match this.GetString key with
        | null -> None
        | item -> Some (JsonSerializer.Deserialize<'T> item)


/// Messages to be displayed to the user
[<Literal>]
let MESSAGES = "messages"

/// The HTTP item key for loading the session
let private sessionLoadedKey = "session-loaded"

/// Load the session if it has not been loaded already; ensures async access but not excessive loading
let private loadSession (ctx: HttpContext) = task {
    if not (ctx.Items.ContainsKey sessionLoadedKey) then
        do! ctx.Session.LoadAsync()
        ctx.Items.Add(sessionLoadedKey, "yes")
}

/// Ensure that the session is committed
let private commitSession (ctx: HttpContext) = task {
    if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync()
}

open MyWebLog.ViewModels

/// Add a message to the user's session
let addMessage (ctx: HttpContext) message = task {
    do! loadSession ctx
    let msg = match ctx.Session.TryGet<UserMessage list> MESSAGES with Some it -> it | None -> []
    ctx.Session.Set(MESSAGES, message :: msg)
}

/// Get any messages from the user's session, removing them in the process
let messages (ctx: HttpContext) = task {
    do! loadSession ctx
    match ctx.Session.TryGet<UserMessage list> MESSAGES with
    | Some msg ->
        ctx.Session.Remove MESSAGES
        return msg |> (List.rev >> Array.ofList)
    | None -> return [||]
}

open MyWebLog

/// Create a view context with the page title filled
let viewCtxForPage title =
    { AppViewContext.Empty with PageTitle = title }

open System.Security.Claims
open Giraffe
open Giraffe.Htmx
open Giraffe.ViewEngine

/// htmx script tag
let private htmxScript (webLog: WebLog) =
    $"""<script src="{webLog.RelativeUrl(Permalink "htmx.min.js")}"></script>"""

/// Get the current user messages, and commit the session so that they are preserved
let private getCurrentMessages ctx = task {
    let! messages = messages ctx
    do! commitSession ctx
    return messages
}

/// Generate the view context for a response
let private generateViewContext messages viewCtx (ctx: HttpContext) =
    { viewCtx with
        WebLog          = ctx.WebLog
        UserId          = ctx.User.Claims
                          |> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
                          |> Option.map (fun claim -> WebLogUserId claim.Value)
        Csrf            = Some ctx.CsrfTokenSet
        PageList        = PageListCache.get ctx
        Categories      = CategoryCache.get ctx
        CurrentPage     = ctx.Request.Path.Value[1..]
        Messages        = messages
        Generator       = ctx.Generator
        HtmxScript      = htmxScript ctx.WebLog
        IsAuthor        = ctx.HasAccessLevel Author
        IsEditor        = ctx.HasAccessLevel Editor
        IsWebLogAdmin   = ctx.HasAccessLevel WebLogAdmin
        IsAdministrator = ctx.HasAccessLevel Administrator }

/// Update the view context with standard information (if it has not been done yet) or updated messages
let updateViewContext ctx viewCtx = task {
    let! messages = getCurrentMessages ctx
    if viewCtx.Generator = "" then
        return generateViewContext messages viewCtx ctx
    else
        return { viewCtx with Messages = Array.concat [ viewCtx.Messages; messages ] }
}

/// Is the request from htmx?
let isHtmx (ctx: HttpContext) =
    ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh

/// Convert messages to headers (used for htmx responses)
let messagesToHeaders (messages: UserMessage array) : HttpHandler =
    seq {
        yield!
            messages
            |> Array.map (fun m ->
                match m.Detail with
                | Some detail -> $"{m.Level}|||{m.Message}|||{detail}"
                | None -> $"{m.Level}|||{m.Message}"
                |> setHttpHeader "X-Message")
        withHxNoPushUrl
    }
    |> Seq.reduce (>=>)

/// Redirect after doing some action; commits session and issues a temporary redirect
let redirectToGet url : HttpHandler = fun _ ctx -> task {
    do! commitSession ctx
    return! redirectTo false (ctx.WebLog.RelativeUrl(Permalink url)) earlyReturn ctx
}

/// The MIME type for podcast episode JSON chapters
[<Literal>]
let JSON_CHAPTERS = "application/json+chapters"


/// Handlers for error conditions
module Error =

    open System.Net

    /// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response
    let notAuthorized : HttpHandler = fun next ctx ->
        if ctx.Request.Method = "GET" then
            let redirectUrl = $"user/log-on?returnUrl={WebUtility.UrlEncode ctx.Request.Path}"
            (next, ctx)
            ||> if isHtmx ctx then withHxRedirect redirectUrl >=> withHxRetarget "body" >=> redirectToGet redirectUrl
                else redirectToGet redirectUrl
        else
            if isHtmx ctx then
                let messages = [|
                    { UserMessage.Error with
                        Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" }
                |]
                (messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx
            else setStatusCode 401 earlyReturn ctx

    /// Handle 404s
    let notFound : HttpHandler =
        handleContext (fun ctx ->
            if isHtmx ctx then
                let messages = [|
                    { UserMessage.Error with Message = $"The URL {ctx.Request.Path.Value} was not found" }
                |]
                RequestErrors.notFound (messagesToHeaders messages) earlyReturn ctx
            else RequestErrors.NOT_FOUND "Not found" earlyReturn ctx)
    
    let server message : HttpHandler =
        handleContext (fun ctx ->
            if isHtmx ctx then
                let messages = [| { UserMessage.Error with Message = message } |]
                ServerErrors.internalError (messagesToHeaders messages) earlyReturn ctx
            else ServerErrors.INTERNAL_ERROR message earlyReturn ctx)


/// Render a view for the specified theme, using the specified template, layout, and context
let viewForTheme themeId template next ctx (viewCtx: AppViewContext) = task {
    let! updated = updateViewContext ctx viewCtx
    
    // NOTE: Although Fluid's view engine support implements layouts and sections, it also relies on the filesystem.
    //       As we are loading templates from memory or a database, we do a 2-pass render; the first for the content,
    //       the second for the overall page.
    
    // Render view content...
    match! Template.Cache.get themeId template ctx.Data with
    | Ok contentTemplate ->
        let forLayout = { updated with Content = Template.render contentTemplate updated ctx.Data }
        // ...then render that content with its layout
        match! Template.Cache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with
        | Ok layoutTemplate -> return! htmlString (Template.render layoutTemplate forLayout ctx.Data) next ctx
        | Error message -> return! Error.server message next ctx
    | Error message -> return! Error.server message next ctx
}

/// Render a bare view for the specified theme, using the specified template and context
let bareForTheme themeId template next ctx viewCtx = task {
    let! updated     = updateViewContext ctx viewCtx
    let  withContent = task {
        if updated.Content = "" then 
            match! Template.Cache.get themeId template ctx.Data with
            | Ok contentTemplate -> return Ok { updated with Content = Template.render contentTemplate updated ctx.Data }
            | Error message -> return Error message
        else
            return Ok viewCtx 
    }
    match! withContent with
    | Ok completeCtx ->
        // Bare templates are rendered with layout-bare
        match! Template.Cache.get themeId "layout-bare" ctx.Data with
        | Ok layoutTemplate ->
            return!
                (messagesToHeaders completeCtx.Messages >=> htmlString (Template.render layoutTemplate completeCtx ctx.Data))
                    next ctx
        | Error message -> return! Error.server message next ctx
    | Error message -> return! Error.server message next ctx
}

/// Return a view for the web log's default theme
let themedView template next (ctx: HttpContext) viewCtx = task {
    return! viewForTheme ctx.WebLog.ThemeId template next ctx viewCtx
}

/// Display a page for an admin endpoint
let adminPage pageTitle next ctx (content: AppViewContext -> XmlNode list) = task {
    let! messages = getCurrentMessages ctx
    let  appCtx   = generateViewContext messages (viewCtxForPage pageTitle) ctx
    let  layout   = if isHtmx ctx then Layout.partial else Layout.full
    return! htmlString (layout content appCtx |> RenderView.AsString.htmlDocument) next ctx
}

/// Display a bare page for an admin endpoint
let adminBarePage pageTitle next ctx (content: AppViewContext -> XmlNode list) = task {
    let! messages = getCurrentMessages ctx
    let  appCtx   = generateViewContext messages (viewCtxForPage pageTitle) ctx
    return!
        (    messagesToHeaders appCtx.Messages
         >=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx
}

/// Validate the anti cross-site request forgery token in the current request
let validateCsrf : HttpHandler = fun next ctx -> task {
    match! ctx.AntiForgery.IsRequestValidAsync ctx with
    | true -> return! next ctx
    | false -> return! RequestErrors.BAD_REQUEST "CSRF token invalid" earlyReturn ctx
}

/// Require a user to be logged on
let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized

/// Require a specific level of access for a route
let requireAccess level : HttpHandler = fun next ctx -> task {
    match ctx.UserAccessLevel with
    | Some userLevel when userLevel.HasAccess level -> return! next ctx
    | Some userLevel ->
        do! addMessage ctx
                { UserMessage.Warning with
                    Message = $"The page you tried to access requires {level} privileges"
                    Detail = Some $"Your account only has {userLevel} privileges" }
        return! Error.notAuthorized next ctx
    | None ->
        do! addMessage ctx
                { UserMessage.Warning with Message = "The page you tried to access required you to be logged on" }
        return! Error.notAuthorized next ctx
}

/// Determine if a user is authorized to edit a page or post, given the author        
let canEdit authorId (ctx: HttpContext) =
    ctx.UserId = authorId || ctx.HasAccessLevel Editor

open System.Threading.Tasks

/// Create a Task with a Some result for the given object
let someTask<'T> (it: 'T) = Task.FromResult(Some it)

/// Create an absolute URL from a string that may already be an absolute URL
let absoluteUrl (url: string) (ctx: HttpContext) =
    if url.StartsWith "http" then url else ctx.WebLog.AbsoluteUrl(Permalink url)


open MyWebLog.Data

/// Get the templates available for the current web log's theme (in a meta item list)
let templatesForTheme (ctx: HttpContext) (typ: string) = backgroundTask {
    match! ctx.Data.Theme.FindByIdWithoutText ctx.WebLog.ThemeId with
    | Some theme ->
        return seq {
            { Name = ""; Value = $"- Default (single-{typ}) -" }
            yield!
                theme.Templates
                |> Seq.ofList
                |> Seq.filter (fun it -> it.Name.EndsWith $"-{typ}" && it.Name <> $"single-{typ}")
                |> Seq.map (fun it -> { Name = it.Name; Value = it.Name })
        }
    | None -> return seq { { Name = ""; Value = $"- Default (single-{typ}) -" } }
}

/// Get all authors for a list of posts as metadata items
let getAuthors (webLog: WebLog) (posts: Post list) (data: IData) =
    posts
    |> List.map _.AuthorId
    |> List.distinct
    |> data.WebLogUser.FindNames webLog.Id

/// Get all tag mappings for a list of posts as metadata items
let getTagMappings (webLog: WebLog) (posts: Post list) (data: IData) =
    posts
    |> List.map _.Tags
    |> List.concat
    |> List.distinct
    |> fun tags -> data.TagMap.FindMappingForTags tags webLog.Id

/// Get all category IDs for the given slug (includes owned subcategories)   
let getCategoryIds slug ctx =
    let allCats = CategoryCache.get ctx
    let cat     = allCats |> Array.find (fun cat -> cat.Slug = slug)
    // Category pages include posts in subcategories
    allCats
    |> Seq.ofArray
    |> Seq.filter (fun c -> c.Id = cat.Id || Array.contains cat.Name c.ParentNames)
    |> Seq.map (fun c -> CategoryId c.Id)
    |> List.ofSeq

open NodaTime

/// Parse a date/time to UTC 
let parseToUtc (date: string) : Instant =
    let result = roundTrip.Parse date
    if result.Success then result.Value else raise result.Exception

open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Logging

/// Log level for debugging
let mutable private debugEnabled : bool option = None

/// Is debug enabled for handlers?
let private isDebugEnabled (ctx: HttpContext) =
    match debugEnabled with
    | Some flag -> flag
    | None ->
        let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
        let log = fac.CreateLogger "MyWebLog.Handlers"
        debugEnabled <- Some(log.IsEnabled LogLevel.Debug)
        debugEnabled.Value

/// Log a debug message
let debug (name: string) ctx msg =
    if isDebugEnabled ctx then
        let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
        let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
        log.LogDebug(msg ())

/// Log a warning message
let warn (name: string) (ctx: HttpContext) msg =
    let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
    let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
    log.LogWarning msg