Idiomatic F# routing with ASP.NET Core

_README.md

These are the bits and pieces you need to setup Suave-like URL routing on top of ASP.NET Core (currently v1.x). That enables you to use middleware (e.g JWT validation) for ASP.NET Core while still having F#-friendly routing for APIs.

Compared to Suave, this is not a purely-functional / immutable implementation, because ASP.NET's native HttpContext expects to be mutated rather than copied. But user routing code remains pretty functional.

Combinators.fs

module Combinators

// These are basic combinators that work with ASP.NET HttpContext.
// Feel free to add your own.
//
// most of this adapted from Giraffe v0.1.0-alpha025
// https://github.com/dustinmoris/Giraffe/blob/v0.1.0-alpha025/src/Giraffe/HttpHandlers.fs
// Some combinators adapted from Suave
// https://github.com/SuaveIO/suave
// Both projects are Apache 2.0 Licensed


open System
open System.Text
open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Hosting
open Microsoft.Extensions.Primitives
open Microsoft.Extensions.Logging
open Microsoft.Extensions.DependencyInjection

type HttpHandler = HttpContext -> Async<HttpContext option>

let inline isNotNull x = isNull x |> not

let inline strOption (str : string) =
    if String.IsNullOrEmpty str then None else Some str

let inline warbler f a = f a a

let inline succeed x = async.Return(Some x)

let fail<'a> = async.Return(Option<'a>.None)

let iff b x = async.Return(if b then Some x else None)

let inline always x _ = x

let never _ = async.Return(None)


let bind (f : HttpHandler) (r : Async<HttpContext option>) =
    async {
        let! ctxOpt = r
        match ctxOpt with
        | None ->
            return None

        | Some ctx ->
            return! f ctx
    }

let compose (f : HttpHandler) (g : HttpHandler) (ctx : HttpContext) =
    bind g (f ctx)


let tryThen (f : HttpHandler) (g : HttpHandler) (ctx : HttpContext)=
    async {
        let! rOpt = f ctx
        match rOpt with
        | None ->
            return! g ctx
        | _ ->
            return rOpt

    }   

let (>>=) = bind

let (>=>) = compose

let (<|>) = tryThen

let rec choose (handlers : HttpHandler list) (ctx : HttpContext) =
    async {
        match handlers with
        | []              -> return None
        | handler :: tail ->
            let! result = handler ctx
            match result with
            | Some c -> return Some c
            | None   -> return! choose tail ctx
    }

let httpVerb (verb : string) (ctx : HttpContext) =
    if ctx.Request.Method.Equals verb
    then Some ctx
    else None
    |> async.Return

let GET    : HttpHandler = httpVerb "GET"
let POST   : HttpHandler = httpVerb "POST"
let PUT    : HttpHandler = httpVerb "PUT"
let PATCH  : HttpHandler = httpVerb "PATCH"
let DELETE : HttpHandler = httpVerb "DELETE"

let mustAccept (mimeTypes : string list) (ctx : HttpContext) =
    let headers = ctx.Request.GetTypedHeaders()
    headers.Accept
    |> Seq.map    (fun h -> h.ToString())
    |> Seq.exists (fun h -> mimeTypes |> Seq.contains h)
    |> function
        | true  -> Some ctx
        | false -> None
        |> async.Return

let authenticated (ctx : HttpContext) =
    if not ( isNull ctx.User )
       && not ( isNull ctx.User.Identity )
       && ctx.User.Identities |> Seq.exists (fun x -> x.IsAuthenticated) then
        succeed ctx
    else
        fail

let path s (ctx : HttpContext) =
    iff (ctx.Request.Path.Equals(PathString(s))) ctx

let pathStarts s (ctx : HttpContext) =
    iff (ctx.Request.Path.StartsWithSegments(PathString(s))) ctx

let setStatusCode (statusCode : int) (ctx : HttpContext) =
    async {
        ctx.Response.StatusCode <- statusCode
        return Some ctx
    }

let setHttpHeader (key : string) (value : obj) (ctx : HttpContext) =
    async {
        ctx.Response.Headers.[key] <- StringValues(value.ToString())
        return Some ctx
    }

let setBody (bytes : byte array) (ctx : HttpContext) =
    async {
        ctx.Response.Headers.["Content-Length"] <- StringValues(bytes.Length.ToString())
        do! ctx.Response.Body.WriteAsync(bytes, 0, bytes.Length) |> Async.AwaitTask
        return Some ctx
    }

let setBodyAsString (str : string) =
    Encoding.UTF8.GetBytes str
    |> setBody

let text (str : string) =
    setHttpHeader "Content-Type" "text/plain"
    >=> setBodyAsString str


let json (str : string) =
    setHttpHeader "ContentType" "application/json"
    >=> setBodyAsString str

Middleware.fs

module Middleware

open System
open System.Threading.Tasks
open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.Http

let exceptionHandler (exHandler : HttpContext -> Exception -> unit) =
    Func<RequestDelegate, RequestDelegate> (
        fun (next : RequestDelegate) ->
            RequestDelegate (
                fun (ctx : HttpContext) ->
                    try
                        next
                            .Invoke(ctx)
                            .ContinueWith(
                                fun t ->
                                    if t.Status = TaskStatus.Faulted then
                                        // crashed while running on thread pool
                                        exHandler ctx t.Exception
                            )
                    with ex ->
                        // crashed during invocation, before going on thread pool
                        exHandler ctx ex
                        Task.FromResult(false) :> Task
            )
    )


let requestHandler (handler : HttpContext -> Async<Option<HttpContext>>) =
    Func<RequestDelegate, RequestDelegate> (
        fun (next : RequestDelegate) ->
            RequestDelegate (
                fun (ctx : HttpContext) ->
                    (
                        async {
                            let! result = handler ctx
                            match result with
                            | None -> // go to next middleware
                                return! next.Invoke(ctx) |> Async.AwaitTask

                            | Some _ -> // we handled this, ignore next middleware
                                return ()
                        } |> Async.StartAsTask
                    ) :> Task                
            )
    )

Program.fs

(* This has just the pieces needed to setup idiomatic F# request routing.
   Fill in with other bits like logging and auth middleware.
*)
    
open Combinators
    
let handleRequest : HttpHandler =
    choose [
        authenticated >=>
            choose [
                path "/" >=> text "Hello world!"
                setStatusCode 404
            ]
        setStatusCode 401
    ]

let handleException (ctx : HttpContext) (ex : Exception) =
    let loggerFactory = ctx.RequestServices.GetService<ILoggerFactory>()
    let logger = loggerFactory.CreateLogger("MyApp")
    logger.LogError(EventId(0), ex, "Unhandled exception on {method} {path}", ctx.Request.Method, ctx.Request.Path)
    ctx.Response.StatusCode <- 500

let configureApp (app : IApplicationBuilder) =
    app
        //...
        .Use(Middleware.exceptionHandler handleException)
        .Use(Middleware.requestHandler handleRequest)
        |> ignore

// ...

[<EntryPoint>]
let main argv =
    WebHostBuilder()
        .UseKestrel(fun options -> options.AddServerHeader <- false)
        // ...
        .Configure(Action<IApplicationBuilder> configureApp)
        .Build()
        .Run()
    0