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