Aspnetcore ext

.gitignore

@@ -272,3 +272,4 @@ coverage.*.xml
 .ionide
 .fsdocs
 /experiments/Orsak.Benchmarks/BenchmarkDotNet.Artifacts/results
+/samples/SampleWeb/test.db

samples/SampleWeb/BackgroundWorker.fs → Orsak.AspNetCore/BackgroundWorker.fs

@@ -1,4 +1,4 @@
-namespace SampleWeb.BackgroundWorker
+namespace Orsak.AspNetCore
 
 open System
 open System.Threading
@@ -11,22 +11,9 @@ open Orsak
 open Microsoft.Extensions.Logging
 open Microsoft.FSharp.Quotations
 
-module dummy =
-    let doWork () = eff {
-
-        return true
-    }
-
-    let dymmy () = eff {
-        use timer = new PeriodicTimer(TimeSpan.FromSeconds(10))
-
-        while timer.WaitForNextTickAsync() do
-            do! doWork () |> Effect.repeatWhileTrue
-    }
-
 [<AutoOpen>]
 module BackgroundWorker =
-    let private interpret work =
+    let private interpret<'r, 'e> work =
         match work with
         | Patterns.WithValue(:? Effect<'r, unit, 'e> as work, _, expr) ->
             let s =
@@ -36,9 +23,37 @@ module BackgroundWorker =
                 | _ -> "guess?"
 
             s, work
+        | Patterns.WithValue(work, _, expr) ->
+            let s =
+                match expr with
+                | Patterns.ValueWithName(a, _, name) -> name
+                | Patterns.Application(Patterns.ValueWithName(a, _, name), _) -> name
+                | _ -> "guess?"
+
+            failwith "what type-safety?"
         | _ -> failwith "what type-safety?"
 
-    let private executeFunc work (delay: TimeSpan) (logger: ILogger) ct provider =
+    let private interpret2<'r, 'e> work =
+        match work with
+        | Patterns.WithValue(:? (CancellationToken -> Effect<'r, unit, 'e>) as work, _, expr) ->
+            let s =
+                match expr with
+                | Patterns.ValueWithName(a, _, name) -> name
+                | Patterns.Application(Patterns.ValueWithName(a, _, name), _) -> name
+                | _ -> "guess?"
+
+            s, work
+        | Patterns.WithValue(work, _, expr) ->
+            let s =
+                match expr with
+                | Patterns.ValueWithName(a, _, name) -> name
+                | Patterns.Application(Patterns.ValueWithName(a, _, name), _) -> name
+                | _ -> "guess?"
+
+            failwith "what type-safety?"
+        | _ -> failwith "what type-safety?"
+
+    let private executeFunc<'r, 'e> (work: Effect<'r, unit, 'e>) (delay: TimeSpan) (logger: ILogger) ct provider =
         work
         |> Effect.onError (fun e -> eff {
             try
@@ -57,13 +72,13 @@ module BackgroundWorker =
             ([<ReflectedDefinition(includeValue = true)>] work: Expr<Effect<'r, unit, 'e>>)
             =
             this.AddHostedService(fun ctx ->
-                let effectName, work = interpret work
+                let effectName, work = interpret<'r, 'e> work
                 let logger = ctx.GetService<ILoggerFactory>().CreateLogger(effectName)
                 let provider = ctx.GetRequiredService<'r>()
 
                 { new BackgroundService() with
                     override _.ExecuteAsync ct =
-                        executeFunc work (TimeSpan.FromSeconds 30) logger ct provider
+                        executeFunc<'r, 'e> work (TimeSpan.FromSeconds 30) logger ct provider
                 })
 
         member this.AddEffectWorker<'r, 'e>
@@ -77,7 +92,7 @@ module BackgroundWorker =
 
                 { new BackgroundService() with
                     override _.ExecuteAsync ct =
-                        executeFunc work (TimeSpan.FromSeconds 30) logger ct provider
+                        executeFunc<'r, 'e> work (TimeSpan.FromSeconds 30) logger ct provider
                 })
 
         member this.AddEffectWorker<'r, 'e>
@@ -91,7 +106,7 @@ module BackgroundWorker =
 
                 { new BackgroundService() with
                     override _.ExecuteAsync ct =
-                        executeFunc work (TimeSpan.FromSeconds 30) logger ct (providerFactory ct)
+                        executeFunc<'r, 'e> work (TimeSpan.FromSeconds 30) logger ct (providerFactory ct)
                 })
 
 
@@ -107,7 +122,7 @@ module BackgroundWorker =
 
                 { new BackgroundService() with
                     override _.ExecuteAsync ct =
-                        executeFunc work delay logger ct provider
+                        executeFunc<'r, 'e> work delay logger ct provider
                 })
 
         member this.AddEffectWorker<'r, 'e>
@@ -122,5 +137,18 @@ module BackgroundWorker =
 
                 { new BackgroundService() with
                     override _.ExecuteAsync ct =
-                        executeFunc work delay logger ct (providerFactory ct)
+                        executeFunc<'r, 'e> work delay logger ct (providerFactory ct)
+                })
+
+        member this.AddEffectWorker<'r, 'e>
+            ([<ReflectedDefinition(includeValue = true)>] work: Expr<CancellationToken -> Effect<'r, unit, 'e>>)
+            =
+            this.AddHostedService(fun ctx ->
+                let effectName, work = interpret2 work
+                let logger = ctx.GetService<ILoggerFactory>().CreateLogger(effectName)
+                let provider = ctx.GetRequiredService<'r>()
+
+                { new BackgroundService() with
+                    override _.ExecuteAsync ct =
+                        executeFunc<'r, 'e> (work ct) (TimeSpan.FromSeconds 30) logger ct provider
                 })

Orsak.AspNetCore/EndpointRouting.fs

@@ -0,0 +1,260 @@
+namespace Orsak.AspNetCore
+
+
+open FSharp.Quotations
+open FSharp.Quotations.Patterns
+open Microsoft.AspNetCore.Http
+open Microsoft.AspNetCore.Builder
+open Microsoft.AspNetCore.Routing
+open System
+open System.Linq.Expressions
+open System.Runtime.CompilerServices
+open System.ComponentModel
+open System.Reflection
+open System.Text
+
+type HandlingMethod = HandlingMethod of MethodInfo
+
+type Endpoint =   
+    | Endpoint of
+        {|
+            verb: string
+            path: string
+            requestDelegate: RequestDelegate
+            conventions: IEndpointConventionBuilder -> IEndpointConventionBuilder
+        |}
+
+    member inline this.AddConvention([<InlineIfLambda>]f: IEndpointConventionBuilder -> IEndpointConventionBuilder) =
+        let (Endpoint this) = this in Endpoint {| this with conventions = fun b -> f (this.conventions b) |}
+
+    member this.RequiresAuthorization() =
+        this.AddConvention(_.RequireAuthorization())
+
+    member this.AllowAnonymous() =
+        this.AddConvention(_.AllowAnonymous())
+
+    member this.RequireCors(name: string) =
+        this.AddConvention(_.RequireCors(name))
+
+    member this.RequireCors(builder: Action<_>) =
+        this.AddConvention(_.RequireCors(builder))
+
+    member this.WithName(name) =
+        this.AddConvention(_.WithName(name))
+
+    member this.WithMetadata([<ParamArray>] items) =
+        this.AddConvention(_.WithMetadata(items))
+
+    member this.WithDisplayName(name: string) =
+        this.AddConvention(_.WithDisplayName(name))
+
+    member this.WithDisplayName(f: Func<_,_>) =
+        this.AddConvention(_.WithDisplayName(f))
+
+    member this.WithGroupName(name) =
+        this.AddConvention(_.WithGroupName(name))
+
+    member this.Add(f) =
+        this.AddConvention(fun b -> b.Add(f); b)
+
+[<AutoOpen>]
+module Helpers =
+    let getConstraint name (ep: RouteEndpoint) =
+        let mutable policies = Unchecked.defaultof<_>
+        if ep.RoutePattern.ParameterPolicies.TryGetValue(name, &policies) then
+            policies[0].Content
+        else
+            ""
+
+    let parseRouteValue (name: string, ctx: HttpContext) =
+        let unEscape (s: string) = s.Replace("%2F", "/").Replace("%2f", "/")
+
+        match ctx.GetEndpoint() :?> RouteEndpoint |> getConstraint name with
+        | ""            -> (ctx.GetRouteValue(name) :?> string |> unEscape |> box)
+        | "int"         -> (ctx.GetRouteValue(name) :?> string |> int |> box)
+        | "bool"        -> (ctx.GetRouteValue(name) :?> string |> bool.Parse |> box)
+        | "length(1)"   -> (ctx.GetRouteValue(name) :?> string |> char |> box)
+        | "long"        -> (ctx.GetRouteValue(name) :?> string |> int64 |> box)
+        | "double"      -> (ctx.GetRouteValue(name) :?> string |> float |> box)
+        | "guid"        -> (ctx.GetRouteValue(name) :?> string |> Guid |> box)
+        | _ -> ctx.GetRouteValue(name)
+
+
+    type StringBuilder with
+        member sb.AppendParameter(c, name) =
+            match c with
+            | 'b' -> sb.Append($"{{%s{name}:bool}}")
+            | 'c' -> sb.Append($"{{%s{name}:length(1)}}")
+            | 's' -> sb.Append($"{{%s{name}}}")
+            | 'i' -> sb.Append($"{{%s{name}:int}}")
+            | 'd' -> sb.Append($"{{%s{name}:long}}")
+            | 'f' -> sb.Append($"{{%s{name}:double}}")
+            | 'O' -> sb.Append($"{{%s{name}:guid}}")
+            | _ -> failwith $"%c{c} is not a supported route format character."
+
+        [<TailCall>]
+        member sb.AppendPath(chars: char ReadOnlySpan, names: string ReadOnlySpan) =
+            let paramIndex = chars.IndexOf('%')
+            if paramIndex = -1 then
+                sb.Append(chars).ToString()
+            elif chars[paramIndex + 1] = '%' then
+                sb
+                  .Append(chars.Slice(0, paramIndex))
+                  .Append('%')
+                  .AppendPath(chars.Slice(paramIndex + 2), names)
+            else
+                sb
+                  .Append(chars.Slice(0, paramIndex))
+                  .AppendParameter(chars[paramIndex + 1], names[0])
+                  .AppendPath(chars.Slice(paramIndex + 2), names.Slice(1))
+
+    [<return: Struct>]
+    let (|TupledArg|_|) (var: Var) =
+        if var.Name = "tupledArg" then ValueSome() else ValueNone
+
+    let getNames (q: Expr) =
+        match q with
+        | Lambda(TupledArg, Let(var, _, Let(var2, _, Let(var3, _, Let(var4, _, Let(var5, _, _)))))) 
+        | Lambda(TupledArg, Let(var, _, Let(var2, _, Let(var3, _, Let(var4, _, Lambda(var5, _)))))) ->
+            [| var.Name; var2.Name; var3.Name; var4.Name; var5.Name; |]
+        | Lambda(TupledArg, Let(var, _, Let(var2, _, Let(var3, _, Let(var4, _, _))))) 
+        | Lambda(TupledArg, Let(var, _, Let(var2, _, Let(var3, _, Lambda(var4, _))))) ->
+            [| var.Name; var2.Name; var3.Name; var4.Name |]
+        | Lambda(TupledArg, Let(var, _, Let(var2, _, Let(var3, _, _))))
+        | Lambda(TupledArg, Let(var, _, Let(var2, _, Lambda(var3, _)))) ->
+            [| var.Name; var2.Name; var3.Name |]
+        | Lambda(TupledArg, Let(var, _, Let(var2, _, _)))
+        | Lambda(var, Lambda(var2, _)) ->
+            [| var.Name; var2.Name |]
+        | Lambda(var, _) -> [| var.Name |]
+        | _ -> [||]
+
+    let getMethodInfo (q: Expr) =
+        match q with
+        | Lambda(TupledArg, Let(_, _, Let(_, _, Let(_, _, Let(_, _, Let(_, _, Call(_, mi, _)))))))
+        | Lambda(TupledArg, Let(_, _, Let(_, _, Let(_, _, Let(_, _, Lambda(_, Call(_, mi, _)))))))
+        | Lambda(TupledArg, Let(_, _, Let(_, _, Let(_, _, Let(_, _, Call(_, mi, _))))))
+        | Lambda(TupledArg, Let(_, _, Let(_, _, Let(_, _, Lambda(_, Call(_, mi, _))))))
+        | Lambda(TupledArg, Let(_, _, Let(_, _, Let(_, _, Call(_, mi, _)))))
+        | Lambda(TupledArg, Let(_, _, Let(_, _, Lambda(_, Call(_, mi, _)))))
+        | Lambda(TupledArg, Let(_, _, Let(_, _, Call(_, mi, _))))
+        | Lambda(_, Lambda(_, Call(_, mi, _)))
+        | Lambda(_, Call(_, mi, _)) -> mi
+        | _ -> Unchecked.defaultof<_>
+
+    let createCtorFunc<'T> () =
+        let ctorInfo = typeof<'T>.GetConstructors()[0]
+        let args = Expression.Parameter(typeof<obj array>, "args")
+
+        let (ctorArgs: Expression array) =
+            ctorInfo.GetParameters()
+            |> Array.mapi (fun i pinfo ->
+                Expression.Convert(Expression.ArrayIndex(args, Expression.Constant(i)), pinfo.ParameterType))
+
+        Expression
+            .Lambda(typeof<Func<obj array, 'T>>, Expression.New(ctorInfo, ctorArgs), args)
+            .Compile()
+        :?> Func<obj array, 'T>
+
+    let inline createEndpointDelegate (eff: 'T -> 'A) (names: string []) this =
+        //type tests for all primitives we support
+        if
+            typeof<'T> = typeof<int>
+            || typeof<'T> = typeof<bool>
+            || typeof<'T> = typeof<char>
+            || typeof<'T> = typeof<string>
+            || typeof<'T> = typeof<int64>
+            || typeof<'T> = typeof<float>
+            || typeof<'T> = typeof<Guid>
+        then
+            RequestDelegate(fun ctx ->
+                let arg = parseRouteValue (names[0], ctx) :?> 'T
+                let (a: RequestDelegate) = eff arg *>> this in a.Invoke(ctx))
+        //if not a single value, it is a tuple
+        else
+            //tupled types
+            let activator = createCtorFunc<'T> ()
+            //we avoid paying the cost by creating this outside the request delegate
+            RequestDelegate(fun ctx ->
+                let argArray = Array.zeroCreate names.Length
+                for i = 0 to names.Length - 1 do
+                    argArray[i] <- parseRouteValue (names[i], ctx)
+
+                eff (activator.Invoke argArray) *>> this |> _.Invoke(ctx))
+
+    type IEndpointRouteBuilder with
+        member builder.MapEffectEndpoints(endpoints: Endpoint list) =
+            endpoints
+            |> List.iter (fun (Endpoint e) ->
+                let convBuilder = builder.MapMethods(e.path, [| e.verb |], e.requestDelegate)
+                e.conventions convBuilder |> ignore
+            )
+
+[<Extension>]
+type EffectRunnerExtensions =
+    [<EditorBrowsable(EditorBrowsableState.Never)>]
+    static member inline CreateEndpoint
+        (
+            this,
+            path: PrintfFormat<_, _, _, _, 'T>,
+            verb: string,
+            handler: (Expr<'T -> 'A>)
+        ) =
+        match handler with
+        | WithValue(value, ``type``, expr) ->
+            let eff = value :?> 'T -> 'A
+
+            if typeof<'T> = typeof<unit> then
+                Endpoint {|
+                    verb = verb
+                    path = path.ToString().Replace("%%", "%")
+                    requestDelegate = eff (Unchecked.defaultof<'T>) *>> this
+                    conventions = id
+                |}   
+            else
+                let names = getNames expr
+                Endpoint {|
+                    verb = verb
+                    path = StringBuilder().AppendPath(path.Value, names)
+                    requestDelegate = createEndpointDelegate eff names this    
+                    conventions = id
+                |}
+            |> _.WithMetadata(HandlingMethod (getMethodInfo expr))
+
+        | _ -> failwith "This expression is expected to be constructed with ReflectedDefinition(includeValue = true)."
+
+    [<Extension>]
+    static member inline RouteGet(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Get, routeHandler)
+
+    [<Extension>]
+    static member inline RoutePost(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Post, routeHandler)
+
+    [<Extension>]
+    static member inline RoutePut(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Put, routeHandler)
+
+    [<Extension>]
+    static member inline RoutePatch(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Patch, routeHandler)
+
+    [<Extension>]
+    static member inline RouteDelete(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Delete, routeHandler)
+
+    [<Extension>]
+    static member inline RouteHead(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Head, routeHandler)
+
+    [<Extension>]
+    static member inline RouteTrace(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Trace, routeHandler)
+
+    [<Extension>]
+    static member inline RouteConnect(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Connect, routeHandler)
+
+    [<Extension>]
+    static member inline RouteOptions(this, path, [<ReflectedDefinition(includeValue = true)>] routeHandler) =
+        EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Options, routeHandler)