From 41e96d2ee6a598b87a09628ff4283322d3672e30 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A1s=20Jank=C3=B3?= Date: Sun, 22 Aug 2021 19:01:45 +0200 Subject: [PATCH] #4 add Context record, small cleanups --- Sitelets/Application.fs | 14 +++--- Sitelets/Application.fsi | 10 ++--- Sitelets/Middleware.fs | 28 ++---------- Sitelets/Sitelet.fs | 59 ++++++++++++++------------ Sitelets/Sitelet.fsi | 31 ++++++++------ Sitelets/SiteletHelper.fs | 89 +++++++++++++++++++++++++-------------- Sitelets/UrlHelpers.fs | 3 +- 7 files changed, 125 insertions(+), 109 deletions(-) diff --git a/Sitelets/Application.fs b/Sitelets/Application.fs index f724320..6815825 100644 --- a/Sitelets/Application.fs +++ b/Sitelets/Application.fs @@ -34,21 +34,19 @@ type Application = static member BaseMultiPage f = Sitelet.Infer f - static member BaseSinglePage (f: HttpContext -> obj) = + static member BaseSinglePage (f: Context -> obj) = { Router = Router.Single SPA.EndPoint.Home "/" Controller = fun ctx _ -> f ctx } - static member SinglePage (f: Func) : Sitelet = + static member SinglePage (f: Func, obj>) : Sitelet = Application.BaseSinglePage (fun ctx -> f.Invoke ctx) - static member MultiPage (f: Func) : Sitelet<'EndPoint> = + static member MultiPage (f: Func, 'EndPoint, obj>) : Sitelet<'EndPoint> = Application.BaseMultiPage (fun ctx ep -> f.Invoke(ctx, ep)) - static member Text (f: Func) : Sitelet = + static member Text (f: Func, string>) : Sitelet = Application.BaseSinglePage (fun ctx -> - do - ctx.Response.WriteAsync(f.Invoke ctx) - |> Async.AwaitTask |> Async.RunSynchronously - ( f.Invoke ctx):> obj) \ No newline at end of file + f.Invoke ctx |> box + ) diff --git a/Sitelets/Application.fsi b/Sitelets/Application.fsi index 8468e27..f801622 100644 --- a/Sitelets/Application.fsi +++ b/Sitelets/Application.fsi @@ -31,19 +31,19 @@ open Microsoft.AspNetCore.Http [] type Application = /// Create a multi-page application. - static member BaseMultiPage : (HttpContext -> 'EndPoint -> obj) -> Sitelet<'EndPoint> + static member BaseMultiPage : (Context<'EndPoint> -> 'EndPoint -> obj) -> Sitelet<'EndPoint> /// Create a single-page HTML application. - static member BaseSinglePage : (HttpContext -> obj) -> Sitelet + static member BaseSinglePage : (Context -> obj) -> Sitelet /// Create a single-page application that returns text. // static member Text : (Context -> string) -> Sitelet /// Create a multi-page application. - static member MultiPage : Func -> Sitelet<'EndPoint> + static member MultiPage : Func, 'EndPoint, obj> -> Sitelet<'EndPoint> /// Create a single-page HTML application. - static member SinglePage : Func -> Sitelet + static member SinglePage : Func, obj> -> Sitelet /// Create a single-page application that returns text. - static member Text : Func -> Sitelet \ No newline at end of file + static member Text : Func, string> -> Sitelet \ No newline at end of file diff --git a/Sitelets/Middleware.fs b/Sitelets/Middleware.fs index 74ccf27..66a6723 100644 --- a/Sitelets/Middleware.fs +++ b/Sitelets/Middleware.fs @@ -43,33 +43,11 @@ module Middleware = | Some sitelet -> Func<_,_,_>(fun (httpCtx: HttpContext) (next: Func) -> let req = httpCtx.Request - let rec contentHelper (content: obj) = - async { - match content with - | :? string as stringContent -> - httpCtx.Response.StatusCode <- StatusCodes.Status200OK - do! httpCtx.Response.WriteAsync(stringContent) |> Async.AwaitTask - | :? IActionResult as actionResult -> - let actionCtx = ActionContext(httpCtx, RouteData(), ActionDescriptor()) - do! actionResult.ExecuteResultAsync(actionCtx) |> Async.AwaitTask - | _ -> - let contentType = content.GetType() - if contentType.IsGenericType && contentType.GetGenericTypeDefinition() = typedefof> then - let contentTask = content :?> Task - do! contentTask |> Async.AwaitTask - let contentResult = - let resultGetter = contentType.GetProperty("Result") - resultGetter.GetMethod.Invoke(contentTask, [||]) - return! contentHelper contentResult - else - httpCtx.Response.StatusCode <- StatusCodes.Status200OK - //let jsonOptions = httpCtx.RequestServices.GetService(typeof(JsonSerializerOptions)) - do! System.Text.Json.JsonSerializer.SerializeAsync(httpCtx.Response.Body, content) |> Async.AwaitTask - } match sitelet.Router.Route req with | Some endpoint -> - let content = sitelet.Controller httpCtx endpoint - contentHelper content + let ctx = SiteletHelper.createContext sitelet httpCtx + let content = sitelet.Controller ctx endpoint + SiteletHelper.contentHelper httpCtx content |> Async.StartAsTask :> Task | None -> next.Invoke() ) diff --git a/Sitelets/Sitelet.fs b/Sitelets/Sitelet.fs index 500be15..8256cd1 100644 --- a/Sitelets/Sitelet.fs +++ b/Sitelets/Sitelet.fs @@ -29,10 +29,23 @@ open System.Threading.Tasks open System.Runtime.CompilerServices open Microsoft.AspNetCore.Http +type Context<'T> = + { + Link : 'T -> string + HttpContext : HttpContext + } + +module Context = + let Map (f: 'T2 -> 'T1) (ctx: Context<'T1>) : Context<'T2> = + { + Link = (ctx.Link << f) + HttpContext = ctx.HttpContext + } + type Sitelet<'T when 'T : equality> = { Router : IRouter<'T> - Controller : HttpContext -> 'T -> obj + Controller : Context<'T> -> 'T -> obj } static member (+) (s1: Sitelet<'T>, s2: Sitelet<'T>) = @@ -60,7 +73,7 @@ module Sitelet = } /// Creates a WebSharper.Sitelet using the given router and handler function. - let New (router: IRouter<'T>) (handle: HttpContext -> 'T -> obj) = + let New (router: IRouter<'T>) (handle: Context<'T> -> 'T -> obj) = { Router = router Controller = handle @@ -81,11 +94,9 @@ module Sitelet = Controller = fun ctx endpoint -> let prot = filter let failure () = - let redirEndpoint = prot.LoginRedirect endpoint - let link = ctx.Items.["Sitelets.Link"] |> unbox<'T -> string> - (RedirectResult (link redirEndpoint)) :> obj + RedirectResult (ctx.Link endpoint) |> box let loggedIn = - let nameClaim = ctx.User.FindFirst(Security.Claims.ClaimTypes.NameIdentifier) + let nameClaim = ctx.HttpContext.User.FindFirst(Security.Claims.ClaimTypes.NameIdentifier) if isNull nameClaim then None else Some nameClaim.Value match loggedIn with | Some user -> @@ -99,7 +110,7 @@ module Sitelet = /// Constructs a singleton sitelet that contains exactly one endpoint /// and serves a single content value at a given location. - let Content (location: string) (endpoint: 'T) (cnt: HttpContext -> obj) = + let Content (location: string) (endpoint: 'T) (cnt: Context<'T> -> obj) = { Router = Router.Single endpoint location Controller = fun ctx _ -> cnt ctx @@ -110,7 +121,7 @@ module Sitelet = { Router = IRouter.Map f g s.Router Controller = fun ctx endpoint -> - s.Controller ctx (g endpoint) + s.Controller (Context.Map f ctx) (g endpoint) } /// Maps over the served sitelet content. @@ -128,7 +139,7 @@ module Sitelet = Router = IRouter.TryMap f g s.Router Controller = fun ctx a -> match g a with - | Some ea -> s.Controller ctx ea + | Some ea -> s.Controller (Context.Map (f >> Option.get) ctx) ea | None -> failwith "Invalid endpoint in Sitelet.Embed" } @@ -138,7 +149,7 @@ module Sitelet = Router = IRouter.Embed embed unembed sitelet.Router Controller = fun ctx a -> match unembed a with - | Some ea -> sitelet.Controller ctx ea + | Some ea -> sitelet.Controller (Context.Map embed ctx) ea | None -> failwith "Invalid endpoint in Sitelet.Embed" } @@ -195,7 +206,7 @@ module Sitelet = { Router = IRouter.Box sitelet.Router Controller = fun ctx a -> - sitelet.Controller ctx (unbox a) + sitelet.Controller (Context.Map box ctx) (unbox a) } let Upcast sitelet = Box sitelet @@ -205,31 +216,27 @@ module Sitelet = { Router = IRouter.Unbox sitelet.Router Controller = fun ctx a -> - sitelet.Controller ctx (box a) + sitelet.Controller (Context.Map unbox ctx) (box a) } let UnsafeDowncast sitelet = Unbox sitelet /// Constructs a sitelet with an inferred router and a given controller /// function. - let Infer<'T when 'T : equality> (handle : HttpContext -> 'T -> obj) = + let Infer<'T when 'T : equality> (handle : Context<'T> -> 'T -> obj) = { Router = Router.IInfer<'T>() Controller = handle } - let InferWithCustomErrors<'T when 'T : equality> (handle : HttpContext -> ParseRequestResult<'T> -> obj) = + let InferWithCustomErrors<'T when 'T : equality> (handle : Context<'T> -> ParseRequestResult<'T> -> obj) = { Router = Router.IInferWithCustomErrors<'T>() - Controller = handle // TODO - //C.CustomContentAsync <| fun ctx -> async { - // let ctx = (Context.Map ParseRequestResult.Success ctx) - // let! content = handle ctx x - // return! C.ToResponse content ctx - //} + Controller = fun ctx x -> + handle (Context.Map ParseRequestResult.Success ctx) x } - let InferPartial (embed: 'T1 -> 'T2) (unembed: 'T2 -> 'T1 option) (mkContent: HttpContext -> 'T1 -> obj) : Sitelet<'T2> = + let InferPartial (embed: 'T1 -> 'T2) (unembed: 'T2 -> 'T1 option) (mkContent: Context<'T2> -> 'T1 -> obj) : Sitelet<'T2> = { Router = Router.IInfer<'T1>() |> IRouter.Embed embed unembed Controller = fun ctx p -> @@ -245,7 +252,7 @@ module Sitelet = | Some (embed, unembed) -> InferPartial embed unembed mkContent | None -> failwith "Invalid union case in Sitelet.InferPartialInUnion" - let MapContext (f: HttpContext -> HttpContext) (sitelet: Sitelet<'T>) : Sitelet<'T> = + let MapContext (f: Context<'T> -> Context<'T>) (sitelet: Sitelet<'T>) : Sitelet<'T> = { sitelet with Controller = fun ctx action -> sitelet.Controller (f ctx) action @@ -254,7 +261,7 @@ module Sitelet = // let WithSettings (settings: seq) (sitelet: Sitelet<'T>) : Sitelet<'T> = // MapContext (Context.WithSettings settings) sitelet // TODO -type RouteHandler<'T> = delegate of HttpContext * 'T -> obj +type RouteHandler<'T> = delegate of Context * 'T -> obj [] type CSharpSitelet = @@ -266,7 +273,7 @@ type CSharpSitelet = handle.Invoke(ctx, unbox<'T> ep) ) - static member Content (location: string, endpoint: 'T, cnt: Func) = + static member Content (location: string, endpoint: 'T, cnt: Func, obj>) = Sitelet.Content location endpoint cnt.Invoke static member Sum ([] sitelets: Sitelet<'T>[]) = @@ -311,7 +318,7 @@ type SiteletBuilder() = let sitelets = ResizeArray() - member this.With<'T when 'T : equality>(content: Func) = + member this.With<'T when 'T : equality>(content: Func, 'T, obj>) = sitelets.Add <| Sitelet.InferPartial box @@ -322,7 +329,7 @@ type SiteletBuilder() = ) this - member this.With(path: string, content: Func) = + member this.With(path: string, content: Func, obj>) = let content ctx = content.Invoke(ctx) sitelets.Add <| Sitelet.Content path (box path) content diff --git a/Sitelets/Sitelet.fsi b/Sitelets/Sitelet.fsi index 897ecb9..e87e8bb 100644 --- a/Sitelets/Sitelet.fsi +++ b/Sitelets/Sitelet.fsi @@ -25,6 +25,13 @@ open System.Threading.Tasks open System.Runtime.CompilerServices open Microsoft.AspNetCore.Http +/// Provides services available to handlers at run-time. +type Context<'T> = + { + Link : 'T -> string + HttpContext : HttpContext + } + /// Represents a self-contained website parameterized by the type of actions. /// A sitelet combines a router, which is used to match incoming requests to /// actions and actions to URLs, and a controller, which is used to handle @@ -32,7 +39,7 @@ open Microsoft.AspNetCore.Http type Sitelet<'T when 'T : equality> = { Router : IRouter<'T> - Controller : HttpContext -> 'T -> obj + Controller : Context<'T> -> 'T -> obj } /// Combines two sitelets, with the leftmost taking precedence. @@ -63,7 +70,7 @@ module Sitelet = val Empty<'T when 'T : equality> : Sitelet<'T> /// Creates a WebSharper.Sitelet using the given router and handler function. - val New<'T when 'T : equality> : router: IRouter<'T> -> handle: (HttpContext -> 'T -> obj) -> Sitelet<'T> + val New<'T when 'T : equality> : router: IRouter<'T> -> handle: (Context<'T> -> 'T -> obj) -> Sitelet<'T> /// Represents filters for protecting sitelets. type Filter<'T> = @@ -83,7 +90,7 @@ module Sitelet = val Content<'T when 'T : equality> : location: string -> endpoint: 'T -> - cnt: (HttpContext -> obj) -> + cnt: (Context<'T> -> obj) -> Sitelet<'T> /// Maps over the sitelet endpoint type. Requires a bijection. @@ -140,26 +147,26 @@ module Sitelet = sitelet: Sitelet -> Sitelet<'T> /// Constructs a sitelet with an inferred router and a given controller function. - val Infer<'T when 'T : equality> : (HttpContext -> 'T -> obj) -> Sitelet<'T> + val Infer<'T when 'T : equality> : (Context<'T> -> 'T -> obj) -> Sitelet<'T> /// Constructs a sitelet with an inferred router and a given controller function. val InferWithCustomErrors<'T when 'T : equality> - : (HttpContext -> ParseRequestResult<'T> -> obj) + : (Context<'T> -> ParseRequestResult<'T> -> obj) -> Sitelet> /// Constructs a partial sitelet with an inferred router and a given controller function. val InferPartial<'T1, 'T2 when 'T1 : equality and 'T2 : equality> : - ('T1 -> 'T2) -> ('T2 -> 'T1 option) -> (HttpContext -> 'T1 -> obj) -> Sitelet<'T2> + ('T1 -> 'T2) -> ('T2 -> 'T1 option) -> (Context<'T2> -> 'T1 -> obj) -> Sitelet<'T2> /// Constructs a partial sitelet with an inferred router and a given controller function. /// The actions covered by this sitelet correspond to the given union case. val InferPartialInUnion<'T1, 'T2 when 'T1 : equality and 'T2 : equality> : - Expr<'T1 -> 'T2> -> (HttpContext -> 'T1 -> obj) -> Sitelet<'T2> + Expr<'T1 -> 'T2> -> (Context<'T2> -> 'T1 -> obj) -> Sitelet<'T2> /// Applies a mapping function on the Context object whenever a sitelet controller is used. - val MapContext : (HttpContext -> HttpContext) -> Sitelet<'T> -> Sitelet<'T> + val MapContext : (Context<'T> -> Context<'T>) -> Sitelet<'T> -> Sitelet<'T> -type RouteHandler<'T> = delegate of HttpContext * 'T -> obj +type RouteHandler<'T> = delegate of Context * 'T -> obj [] type CSharpSitelet = @@ -172,7 +179,7 @@ type CSharpSitelet = /// Constructs a singleton sitelet that contains exactly one endpoint /// and serves a single content value at a given location. - static member Content<'T when 'T: equality> : location: string * endpoint: 'T * cnt: Func -> Sitelet<'T> + static member Content<'T when 'T: equality> : location: string * endpoint: 'T * cnt: Func, obj> -> Sitelet<'T> /// Combines several sitelets, leftmost taking precedence. /// Is equivalent to folding with the choice operator. @@ -202,11 +209,11 @@ type SiteletBuilder = new : unit -> SiteletBuilder /// Add a handler for an inferred endpoint. - member With<'T> : Func -> SiteletBuilder + member With<'T> : Func, 'T, obj> -> SiteletBuilder when 'T : equality /// Add a handler for a specific path. - member With : string * Func -> SiteletBuilder + member With : string * Func, obj> -> SiteletBuilder /// Get the resulting Sitelet. member Install : unit -> Sitelet diff --git a/Sitelets/SiteletHelper.fs b/Sitelets/SiteletHelper.fs index abd1b02..5237a50 100644 --- a/Sitelets/SiteletHelper.fs +++ b/Sitelets/SiteletHelper.fs @@ -35,41 +35,68 @@ module SiteletHelper = type SiteletHttpFunc = HttpContext -> SiteletHttpFuncResult type SiteletHttpHandler = SiteletHttpFunc -> SiteletHttpFunc + let rec internal contentHelper (httpCtx: HttpContext) (content: obj) = + async { + match content with + | :? string as stringContent -> + httpCtx.Response.StatusCode <- StatusCodes.Status200OK + do! httpCtx.Response.WriteAsync(stringContent) |> Async.AwaitTask + return None + | :? IActionResult as actionResult -> + let actionCtx = ActionContext(httpCtx, RouteData(), ActionDescriptor()) + do! actionResult.ExecuteResultAsync(actionCtx) |> Async.AwaitTask + return None + | _ -> + let contentType = content.GetType() + if contentType.IsGenericType && contentType.GetGenericTypeDefinition() = typedefof> then + let contentTask = content :?> Task + do! contentTask |> Async.AwaitTask + let contentResult = + let resultGetter = contentType.GetProperty("Result") + resultGetter.GetMethod.Invoke(contentTask, [||]) + return! contentHelper httpCtx contentResult + else + httpCtx.Response.StatusCode <- StatusCodes.Status200OK + do! System.Text.Json.JsonSerializer.SerializeAsync(httpCtx.Response.Body, content) |> Async.AwaitTask + return None + } + + let private (++) (a: string) (b: string) = + let startsWithSlash (s: string) = + s.Length > 0 + && s.[0] = '/' + let endsWithSlash (s: string) = + s.Length > 0 + && s.[s.Length - 1] = '/' + match endsWithSlash a, startsWithSlash b with + | true, true -> a + b.Substring(1) + | false, false -> a + "/" + b + | _ -> a + b + + let internal createContext (sl: Sitelet<'T>) (httpCtx: HttpContext) = + let appPath = httpCtx.Request.PathBase.ToUriComponent() + let link (x: 'T) = + match sl.Router.Link x with + | None -> failwithf "Failed to link to %O" (box x) + | Some loc when loc.IsAbsoluteUri -> string loc + | Some loc -> appPath ++ string loc + + { + Link = link + HttpContext = httpCtx + } + let sitelet (sl : Sitelet<'T>) : SiteletHttpHandler = - fun (httpFunc: SiteletHttpFunc) -> + fun (next: SiteletHttpFunc) -> let handleSitelet (httpCtx: HttpContext) = - let rec contentHelper (content: obj) = - async { - - match content with - | :? string as stringContent -> - httpCtx.Response.StatusCode <- StatusCodes.Status200OK - do! httpCtx.Response.WriteAsync(stringContent) |> Async.AwaitTask - return None - | :? IActionResult as actionResult -> - let actionCtx = ActionContext(httpCtx, RouteData(), ActionDescriptor()) - do! actionResult.ExecuteResultAsync(actionCtx) |> Async.AwaitTask - return None - | _ -> - let contentType = content.GetType() - if contentType.IsGenericType && contentType.GetGenericTypeDefinition() = typedefof> then - let contentTask = content :?> Task - do! contentTask |> Async.AwaitTask - let contentResult = - let resultGetter = contentType.GetProperty("Result") - resultGetter.GetMethod.Invoke(contentTask, [||]) - return! contentHelper contentResult - else - httpCtx.Response.StatusCode <- StatusCodes.Status200OK - do! System.Text.Json.JsonSerializer.SerializeAsync(httpCtx.Response.Body, content) |> Async.AwaitTask - return None - } let req = httpCtx.Request match sl.Router.Route req with | Some endpoint -> - let content = sl.Controller httpCtx endpoint - contentHelper content - |> Async.StartAsTask - | None -> Task.FromResult (Some httpCtx) + let ctx = createContext sl httpCtx + let content = sl.Controller ctx endpoint + let t = contentHelper httpCtx content + t |> Async.StartAsTask + | None -> + next httpCtx handleSitelet \ No newline at end of file diff --git a/Sitelets/UrlHelpers.fs b/Sitelets/UrlHelpers.fs index b4b6620..ade7fff 100644 --- a/Sitelets/UrlHelpers.fs +++ b/Sitelets/UrlHelpers.fs @@ -179,7 +179,6 @@ module UrlHelpers = // HttpTODO | "TRACE" -> TRACE (allParams (), req.PathBase.ToUriComponent() |> Uri) // TODO: Revise. Unfortunately, F# active patterns only allow up to 7 cases. - | "HEAD" - | "CONNECT" -> + | _ -> SPECIAL (req.Method, allParams, req.PathBase.ToUriComponent() |> Uri)