Experimental typed and computation expression-based Giraffe HTTP handlers

Handler.fs

module Handler

open System.Threading.Tasks
open Giraffe
open Giraffe.FormatExpressions
open Microsoft.AspNetCore.Http
open Microsoft.Extensions.Logging

(* Core definitions *)

type Handler<'a> = Handler of (HttpContext -> ('a -> HttpFuncResult) -> HttpFuncResult)

let ret a : Handler<'a> = Handler (fun _ k -> k a)

let map f (Handler h : Handler<'a>) : Handler<'b> = Handler (fun c k -> h c (fun a -> k (f a)))

let apply (Handler f) (Handler v) : Handler<'b> = Handler (fun c k -> f c (fun g -> v c (fun a -> k (g a))))

let bind f (Handler h : Handler<'a>) : Handler<'b> = Handler (fun c k' -> h c (fun a -> let (Handler h') = f a in h' c k'))

(* Basic API *)

/// Recover the regular Giraffe 'HttpHandler' from a 'Handler' closed with 'HttpContext'.
let httpHandler (Handler h) : HttpHandler = fun next ctx -> h ctx next

/// Adapt a regular Giraffe HTTP handler to a typed handler.
let ofHttpHandler (giraffeHandler : HttpHandler) : Handler<_> = Handler (fun ctx next -> giraffeHandler next ctx)

/// Access the 'HttpContext' inside of a 'Handler'.
let context = Handler (|>)

/// Abandon (the remainder of) processing in current pipeline.
let skip = Handler (fun _ _ -> Task.FromResult None)

/// Finish processing in the current pipeline omitting the remaining steps in the pipeline, if any. This is called
/// "early return" in Giraffe.
let finish = Handler (fun ctx _ -> Task.FromResult (Some ctx))

/// Computation expression support for typed HTTP handlers.
type HandlerBuilder () =
    
    member _.Return(a) = ret a

    member _.ReturnFrom(h : Handler<_>) = h

    member _.Bind(h, f) = bind f h

    member _.Combine(left : Handler<_>, right : Handler<'a>) : Handler<'a> = left |> bind (fun _ -> right)

    member _.Delay(fh) = Handler (fun ctx next -> let (Handler h) = fh () in h ctx next)

    member _.Run(f) = f

    member inline _.Source(same : Handler<_>) = same

    member _.Source(ta : Task<'a>) : Handler<'a> =
        Handler (fun _ next -> task { let! a = ta in return! next a }) // Note the similarity with `ret`!

    member _.Source(giraffeHandler : HttpHandler) : Handler<_> = ofHttpHandler giraffeHandler

/// Computation expression support for typed HTTP handlers.
let handler = HandlerBuilder ()

/// Operators for typed HTTP handlers.
type Handler<'a> with
    static member (<!>) (f, h) = map f h
    static member (<*>) (hf, ha) = apply hf ha
    static member (>>=) (h, fh) = bind fh h
    static member ( *> ) (hl, hr) = ret (fun _ b -> b) <*> hl <*> hr
    static member ( <* ) (hl, hr) = ret (fun a _ -> a) <*> hl <*> hr
    static member (>=>) (hf, hg) = fun a -> bind hg (hf a)
    static member (<=<) (hg, hf) = fun a -> bind hg (hf a)

(* A port of a tiny selection of functions from Giraffe *)

let private httpVerb validate = handler {
    let! ctx = context
    if validate ctx.Request.Method then return () else return! skip
}

let GET = httpVerb HttpMethods.IsGet
let POST = httpVerb HttpMethods.IsPost

let route (path : string) = handler {
    let! ctx = context
    if SubRouting.getNextPartOfPath ctx = path then return () else return! skip
}

let routef (path : PrintfFormat<_,_,_,_, 'T>) : Handler<'T> = handler {
    validateFormat path
    let! ctx = context
    match tryMatchInput path MatchOptions.Exact (SubRouting.getNextPartOfPath ctx) with
    | None -> return! skip
    | Some args -> return args
}

let text (str : string) = handler {
    let bytes = System.Text.Encoding.UTF8.GetBytes str
    let! ctx = context
    ctx.SetContentType "text/plain; charset=utf-8"
    let! _ = ctx.WriteBytesAsync bytes
    return ()
}

let setStatusCode (statusCode : int) = handler {
    let! ctx = context
    ctx.SetStatusCode statusCode
    return ()
}

(* Examples *)

/// A reusable handler which returns an often-used DTO after extracting it from the request body.
let personFromBody = handler {
    // Access the HTTP context
    let! ctx = context
    // Bind to a 'Task' result directly
    let! person = ctx.BindJsonAsync<{| Name : string |}> ()
    // Typed result
    return person
}

let exampleService : HttpHandler =
    choose [

        // Warming up: a very simple greeter
        httpHandler (GET *> route "/hello" *> text "Hello" *> finish)

        // Reusing a typed handler and more
        httpHandler (handler {
            do! POST *> route "/person"
            let! ctx = context
            let logger = ctx.GetLogger "handler"
            // Reuse a typed handler
            let! person = personFromBody
            if person.Name = "Batman" then
                // An in-line asynchronous step; simulate some long work
                do! task { do! Task.Delay 1_000 }
                logger.LogInformation "Batman detected"
                do! setStatusCode 202
                do! text "Hi Batman!"
                return! finish
            else
                logger.LogInformation "Not Batman, ignoring"
                do! setStatusCode 422 // This does not have effect due to `skip` below.
                return! skip
                return! handler { logger.LogError "This should not be logged (after skip)"; return! finish }
            // No manual application of 'next' anywhere, in particular when working with Task-s.
        })

        // Reusing Giraffe handlers
        httpHandler (handler {
            do! GET *> route "/reuse"
            // Using explicit 'ofHttpHandler' adapter
            return! ofHttpHandler (Giraffe.Core.setStatusCode 202)
            // Directly
            return! Giraffe.Core.text "This text is returned by reusing the regular Giraffe `text` handler"
        })

        // A showcase of `routef`
        httpHandler (handler {
            let! name = GET *> routef "/hello2/%s"
            let! ctx = context
            let! _ = ctx.WriteJsonAsync {| Greetings = name |}
            return! finish
        })
    ]