diff --git a/.gitignore b/.gitignore index 86eaa93..9bd8036 100644 --- a/.gitignore +++ b/.gitignore @@ -272,3 +272,4 @@ coverage.*.xml .ionide .fsdocs /experiments/Orsak.Benchmarks/BenchmarkDotNet.Artifacts/results +/samples/SampleWeb/test.db diff --git a/samples/SampleWeb/BackgroundWorker.fs b/Orsak.AspNetCore/BackgroundWorker.fs similarity index 59% rename from samples/SampleWeb/BackgroundWorker.fs rename to Orsak.AspNetCore/BackgroundWorker.fs index e8615f4..2891360 100644 --- a/samples/SampleWeb/BackgroundWorker.fs +++ b/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 - } - [] 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 = ([] work: Expr>) = this.AddHostedService(fun ctx -> - let effectName, work = interpret work + let effectName, work = interpret<'r, 'e> work let logger = ctx.GetService().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> + ([] work: Expr Effect<'r, unit, 'e>>) + = + this.AddHostedService(fun ctx -> + let effectName, work = interpret2 work + let logger = ctx.GetService().CreateLogger(effectName) + let provider = ctx.GetRequiredService<'r>() + + { new BackgroundService() with + override _.ExecuteAsync ct = + executeFunc<'r, 'e> (work ct) (TimeSpan.FromSeconds 30) logger ct provider }) diff --git a/Orsak.AspNetCore/EndpointRouting.fs b/Orsak.AspNetCore/EndpointRouting.fs new file mode 100644 index 0000000..0fe7f22 --- /dev/null +++ b/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([]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([] 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) + +[] +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." + + [] + 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)) + + [] + 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, "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>, Expression.New(ctorInfo, ctorArgs), args) + .Compile() + :?> Func + + let inline createEndpointDelegate (eff: 'T -> 'A) (names: string []) this = + //type tests for all primitives we support + if + typeof<'T> = typeof + || typeof<'T> = typeof + || typeof<'T> = typeof + || typeof<'T> = typeof + || typeof<'T> = typeof + || typeof<'T> = typeof + || typeof<'T> = typeof + 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 + ) + +[] +type EffectRunnerExtensions = + [] + 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 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)." + + [] + static member inline RouteGet(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Get, routeHandler) + + [] + static member inline RoutePost(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Post, routeHandler) + + [] + static member inline RoutePut(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Put, routeHandler) + + [] + static member inline RoutePatch(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Patch, routeHandler) + + [] + static member inline RouteDelete(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Delete, routeHandler) + + [] + static member inline RouteHead(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Head, routeHandler) + + [] + static member inline RouteTrace(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Trace, routeHandler) + + [] + static member inline RouteConnect(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Connect, routeHandler) + + [] + static member inline RouteOptions(this, path, [] routeHandler) = + EffectRunnerExtensions.CreateEndpoint(this, path, HttpMethods.Options, routeHandler) diff --git a/Orsak.AspNetCore/Orsak.AspNetCore.fsproj b/Orsak.AspNetCore/Orsak.AspNetCore.fsproj new file mode 100644 index 0000000..4b995ab --- /dev/null +++ b/Orsak.AspNetCore/Orsak.AspNetCore.fsproj @@ -0,0 +1,18 @@ + + + net6.0;net7.0;net8.0 + true + 3390;$(WarnOn) + Orsak.AspNetCore + + + + + + + + + + + + diff --git a/Orsak.sln b/Orsak.sln index 05d8648..b3b7c2e 100644 --- a/Orsak.sln +++ b/Orsak.sln @@ -14,10 +14,10 @@ EndProject Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "SolutionFiles", "SolutionFiles", "{55957464-5E47-42EB-9DF5-8E5A3BA56DFD}" ProjectSection(SolutionItems) = preProject .editorconfig = .editorconfig + CHANGELOG.md = CHANGELOG.md GitVersion.yml = GitVersion.yml global.json = global.json LICENSE.txt = LICENSE.txt - CHANGELOG.md = CHANGELOG.md EndProjectSection EndProject Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Orsak", "src\Orsak\Orsak.fsproj", "{63514ED7-7DEB-47A9-A771-23DAF203500B}" @@ -26,6 +26,8 @@ Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Orsak.Tests", "tests\Orsak. EndProject Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Orsak.Benchmarks", "experiments\Orsak.Benchmarks\Orsak.Benchmarks.fsproj", "{126F9D50-D5E9-4E86-BBC3-670D2A835876}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Orsak.AspNetCore", "Orsak.AspNetCore\Orsak.AspNetCore.fsproj", "{6FE77668-E21E-4D92-AF78-2520677C3241}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -84,6 +86,18 @@ Global {126F9D50-D5E9-4E86-BBC3-670D2A835876}.Release|x64.Build.0 = Release|Any CPU {126F9D50-D5E9-4E86-BBC3-670D2A835876}.Release|x86.ActiveCfg = Release|Any CPU {126F9D50-D5E9-4E86-BBC3-670D2A835876}.Release|x86.Build.0 = Release|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Debug|Any CPU.Build.0 = Debug|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Debug|x64.ActiveCfg = Debug|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Debug|x64.Build.0 = Debug|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Debug|x86.ActiveCfg = Debug|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Debug|x86.Build.0 = Debug|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Release|Any CPU.ActiveCfg = Release|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Release|Any CPU.Build.0 = Release|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Release|x64.ActiveCfg = Release|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Release|x64.Build.0 = Release|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Release|x86.ActiveCfg = Release|Any CPU + {6FE77668-E21E-4D92-AF78-2520677C3241}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE @@ -92,6 +106,7 @@ Global {95CBDA61-BA67-494A-8219-D41C0FE9BE3B} = {1507F71E-9C19-4C50-9E87-2ADE61196C25} {63514ED7-7DEB-47A9-A771-23DAF203500B} = {C397A34C-84F1-49E7-AEBC-2F9F2B196216} {2434C300-6997-4035-8ABA-B80491C283C7} = {ACBEE43C-7A88-4FB1-9B06-DB064D22B29F} + {6FE77668-E21E-4D92-AF78-2520677C3241} = {C397A34C-84F1-49E7-AEBC-2F9F2B196216} EndGlobalSection GlobalSection(ExtensibilityGlobals) = postSolution SolutionGuid = {DBE9E517-B720-4756-AA7D-FF3644E47C71} diff --git a/docs/1_Motivation.fsx b/docs/1_Motivation.fsx index a3ef8cf..d90e1bd 100644 --- a/docs/1_Motivation.fsx +++ b/docs/1_Motivation.fsx @@ -9,7 +9,7 @@ index: 1 (*** condition: prepare ***) #r "nuget: Microsoft.Extensions.Logging.Abstractions, 7.0.0" #I "../src/Orsak/bin/Release/net6.0" -#r "Orsak.dll" +#r "../src/Orsak/bin/Release/net6.0/Orsak.dll" open System.Threading.Tasks open Microsoft.Extensions.Logging diff --git a/docs/2_Motivation.fsx b/docs/2_Motivation.fsx index 848643c..770c5cc 100644 --- a/docs/2_Motivation.fsx +++ b/docs/2_Motivation.fsx @@ -16,19 +16,19 @@ open System.Threading.Tasks ###In the beginning, there was OOP -Let's say you have an application that is architected according to [Functional Core, imperative shell](https://www.destroyallsoftware.com/screencasts/catalog/functional-core-imperative-shell). And all the functional code is easy to test and easy to reuse. +Let's say you have an application that is architected according to [Functional Core, imperative shell](https://www.destroyallsoftware.com/screencasts/catalog/functional-core-imperative-shell). And all the functional code is easy to test and easy to reuse. But in the imperative shell, how do we compose the side-effectful code? -If you are coming from an object-oriented background, you might be thinking about SOLID. Certainly that was my background. So I made ``IRepositories`` and ``IClients`` and ``IMessageHandlers``, and injected them into ``IDomainService`` and ``IThisService`` and ``IThatService``, +If you are coming from an object-oriented background, you might be thinking about SOLID. Certainly that was my background. So I made ``IRepositories`` and ``IClients`` and ``IMessageHandlers``, and injected them into ``IDomainService`` and ``IThisService`` and ``IThatService``, and all that jazz. And inevitably I ended up with too many constructor-parameters, and interfaces with too many members, and weird code duplication. And at the end of the day I thought to my self "There must be a better way. If this is the Right Waytm, why is it so hard?" In the end, I believe that while this is the least bad way of doing oo-programming, it is not enough. ###Putting the 'fun' in programming -If the I in solid is taken to its natural conclusion, your interfaces end up with a single member. Now, this is not an [original](https://blog.ploeh.dk/2014/03/10/solid-the-next-step-is-functional/) observation, but one I believe merits repeating. +If the I in solid is taken to its natural conclusion, your interfaces end up with a single member. Now, this is not an [original](https://blog.ploeh.dk/2014/03/10/solid-the-next-step-is-functional/) observation, but one I believe merits repeating. But in OO the object is the natural method of composition, and even with dependency injection creating SRP-conforming objects quickly becomes tedious. But give that [objects are merely a poor man's -closures](http://people.csail.mit.edu/gregs/ll1-discuss-archive-html/msg03277.html), maybe we can unlock reuse and composability some other way? +closures](http://people.csail.mit.edu/gregs/ll1-discuss-archive-html/msg03277.html), maybe we can unlock reuse and composability some other way? *) type IMessageClient = diff --git a/experiments/Orsak.Benchmarks/Orsak.Benchmarks.fsproj b/experiments/Orsak.Benchmarks/Orsak.Benchmarks.fsproj index 7ac4b2f..0d6750a 100644 --- a/experiments/Orsak.Benchmarks/Orsak.Benchmarks.fsproj +++ b/experiments/Orsak.Benchmarks/Orsak.Benchmarks.fsproj @@ -11,7 +11,7 @@ - + diff --git a/experiments/Orsak.Benchmarks/Program.fs b/experiments/Orsak.Benchmarks/Program.fs index 235f6e0..21a0253 100644 --- a/experiments/Orsak.Benchmarks/Program.fs +++ b/experiments/Orsak.Benchmarks/Program.fs @@ -3,11 +3,12 @@ open BenchmarkDotNet.Running open Orsak open System.Threading.Tasks +open FSharp.Control #nowarn "3511" module Old = - open FSharp.Control + let inline par (eff: Effect<'r, 'a, 'e> seq) = mkEffect (fun rEnv -> vtask { let! results = @@ -28,6 +29,7 @@ module Old = | Error e -> Error e) results }) + [] type SyncBenchmarks() = static member CompletedEffectsSource() = @@ -36,37 +38,38 @@ type SyncBenchmarks() = [| for _ in 1..100 -> Effect.ret () |] [| for _ in 1..1000 -> Effect.ret () |] - ] :> seq<_> + ] + :> seq<_> [] - [< ParamsSource("CompletedEffectsSource" ) >] + [] val mutable CompletedEffects: Effect array - [] + [] member this.CompletedOld() = task { let! a = Old.par this.CompletedEffects |> Effect.run () return () } - [] + [] member this.CompletedNew() = task { let! a = Effect.whenAll this.CompletedEffects |> Effect.run () return () } module AsyncBenchmarks = - let yieldEffect : Effect = - eff { + let yieldEffect: Effect = + mkEffect (fun () -> vtask { do! Task.Yield() - return 1 - } + return Ok 1 + }) - let asyncEffect : Effect = - eff { + let asyncEffect: Effect = + mkEffect (fun () -> vtask { do! Task.Delay 100 - return 1 - } + return Ok 1 + }) @@ -78,26 +81,24 @@ type AsyncYieldBenchmarks() = [| for _ in 1..1000 -> AsyncBenchmarks.yieldEffect |] ] - [] - [] + [] + [] member this.CompletedOld(effects: Effect array) = task { let! a = Old.par effects |> Effect.run () + match a with - | Ok a -> - return () - | Error _ -> - return() + | Ok a -> return () + | Error _ -> return () } [] - [] + [] member this.CompletedNew(effects: Effect array) = task { let! a = Effect.whenAll effects |> Effect.run () + match a with - | Ok a -> - return () - | Error _ -> - return() + | Ok a -> return () + | Error _ -> return () } [] @@ -107,26 +108,24 @@ type AsyncBenchmarks() = [| for _ in 1..20 -> AsyncBenchmarks.asyncEffect |] ] - [] - [] + [] + [] member this.CompletedOld(effects: Effect array) = task { let! a = Old.par effects |> Effect.run () + match a with - | Ok a -> - return () - | Error _ -> - return() + | Ok a -> return () + | Error _ -> return () } [] - [] + [] member this.CompletedNew(effects: Effect array) = task { let! a = Effect.whenAll effects |> Effect.run () + match a with - | Ok a -> - return () - | Error _ -> - return() + | Ok a -> return () + | Error _ -> return () } [] @@ -147,18 +146,22 @@ module Helpers2 = return List.ofSeq res } + [] type AsyncSeqYieldBenchmarks() = - [] + [] member this.CompletedOld() = task { - let! _unused = evaluatesToSequence (effSeq { - yield 1 - do! Task.Yield() - yield 2 - do! Task.Yield() - yield 3 - }) + let! _unused = + evaluatesToSequence ( + effSeq { + yield 1 + do! Task.Yield() + yield 2 + do! Task.Yield() + yield 3 + } + ) return () } @@ -166,8 +169,7 @@ type AsyncSeqYieldBenchmarks() = [] let main argv = //asyncMain().GetAwaiter().GetResult() - BenchmarkSwitcher - .FromAssembly(typeof.Assembly).Run(argv) - |> ignore + BenchmarkSwitcher.FromAssembly(typeof.Assembly).Run(argv) + |> ignore 0 diff --git a/samples/SampleWeb/Application.fs b/samples/SampleWeb/Application.fs new file mode 100644 index 0000000..e18387e --- /dev/null +++ b/samples/SampleWeb/Application.fs @@ -0,0 +1,33 @@ +module SampleWeb.Application + +open Orsak +open Orsak.Extensions +open Fleece +open FSharpPlus +open Microsoft.AspNetCore.Http +open Microsoft.Extensions.Logging + +type Message = { + message: string +} with + + static member ToJson(x: Message) = jobj [ "message" .= x.message ] + +let ping () : Effect<_, _, _> = eff { + do! Log.getLogger() |>> _.LogInformation("") + let! batchId = GuidGenerator.newGuid () + let msg = { message = "hi"; batchId = batchId.ToString(); orderId = "2" } + //do! Message.send msg + return () +} + +let ping2 (x: int) : Effect<_, _, string> = eff { + do! Log.logInformation ("Hi") + let! batchId = GuidGenerator.newGuid () + let msg = { message = "hi"; orderId = batchId.ToString(); batchId = "2" } + //do! Message.send msg + do! ChatHub.sendMessage "test" "hello" + return Results.Ok({| test = x |}) +} + +let post (target, _unused: int) = eff { return { message = target } } diff --git a/samples/SampleWeb/Effects.fs b/samples/SampleWeb/Effects.fs index 5eb4c78..12c3bcc 100644 --- a/samples/SampleWeb/Effects.fs +++ b/samples/SampleWeb/Effects.fs @@ -4,22 +4,167 @@ open System open Orsak open Microsoft.Extensions.Logging open Microsoft.AspNetCore.Http +open System.Security.Cryptography +open System.Threading.Tasks +open System.Text.Json +open Orsak.Effects +open FSharp.Control +open Fleece +open Fleece.SystemTextJson +open FSharpPlus +open Dapper +open Orsak.Scoped +open Azure.Storage.Queues.Models +open System.Collections.Generic +open System.Threading +open System.Runtime.InteropServices +open System.Runtime.CompilerServices + +type GuidGenerator = + abstract member NewGuid: unit -> Guid + +type GuidProvider = + abstract member Gen: GuidGenerator + +module GuidGenerator = + let newGuid () = + Effect.Create(fun (p: #GuidProvider) -> p.Gen.NewGuid()) + + +type RNGProvider = + abstract member Gen: RandomNumberGenerator + +module RandomNumberGenerator = + let getBytes (x: byte array) = + Effect.Create(fun (provider: #RNGProvider) -> provider.Gen.GetBytes(x)) + type ILoggerProvider = - abstract member Logger: ILogger + abstract member Logger: string -> ILogger type Log = - static member getLogger() = - Effect.Create(fun (provider: #ILoggerProvider) -> provider.Logger) + static member getLogger([]caller: string) = + Effect.Create(fun (provider: #ILoggerProvider) -> provider.Logger(caller)) - static member logInformation(message, [] args) = - Effect.Create(fun (provider: #ILoggerProvider) -> provider.Logger.LogInformation(message, args)) + static member logInformation(message, []caller: string) = + Effect.Create(fun (provider: #ILoggerProvider) -> provider.Logger(caller).LogInformation(message)) type IContextProvider = abstract member Context: HttpContext module HttpContext = - open Giraffe - let current () = Effect.Create(fun (provider: #IContextProvider) -> provider.Context) + + +type IChatHub = + abstract member MessageSent: user: string * message: string -> Task + +type IChatHubProvider = + abstract member Hub: IChatHub + +module ChatHub = + let sendMessage user message = + Effect.Create(fun (provider: #IChatHubProvider) -> task { do! provider.Hub.MessageSent(user, message) }) + + +(* + Abstraction over storage queues +*) +type MessageModel = { + message: string + batchId: string + orderId: string +} with + + static member ToJson(x: MessageModel) = + jobj [ "message" .= x.message; "batchId" .= x.batchId; "orderId" .= x.orderId ] + + static member OfJson json = + match json with + | JObject o -> monad { + let! message = o .@ "message" + let! batchId = o .@ "batchId" + let! orderId = o .@ "orderId" + return { message = message; batchId = batchId; orderId = orderId } + } + | x -> Decode.Fail.objExpected x + +type MessageSink = + abstract member Send: byte array -> Task + abstract member Receive: CancellationToken -> IAsyncEnumerable + abstract member Delete: QueueMessage -> Task + +type MessageSinkProvider = + abstract member Sink: MessageSink + +module Message = + + let inline receive (token) = + EffSeq.Create(fun (provider: #MessageSinkProvider) -> provider.Sink.Receive(token)) + + let delete msg = + Effect.Create(fun (provider: #MessageSinkProvider) -> provider.Sink.Delete msg) + + ///This is mostly for max control, this can be done in much fewer lines of code if so desired. + let inline send (message) = + Effect.Create(fun (provider: #MessageSinkProvider) -> task { + use ms = new IO.MemoryStream() + use writer = new Utf8JsonWriter(ms) + let enc = Operators.toJsonValue message + enc.WriteTo writer + writer.Flush() + let result = ms.ToArray() + do! provider.Sink.Send(result) + }) + + let read<'a> (sql: string) (p: obj) = + mkEffect (fun (tran: DbTransactional) -> vtask { + let connection = tran.Connection + let b = connection.QueryFirstOrDefault<'a>(sql, p) + + match box b with + | null -> return Ok None + | _ -> return Ok(Some b) + }) + + let execute (sql: string) (p: obj) = + mkEffect (fun (tran: DbTransactional) -> vtask { + let connection = tran.Connection + let b = connection.Execute(sql, param = p) + return Ok() + }) + + + let handleMessage (message: MessageModel) = commitEff { + match! + read<{| handled: string; id: Int64; orderId: string |}> + ("SELECT handled, id, orderId FROM inbox where orderId = @orderId") + {| orderId = message.orderId |} + with + | Some a -> do! Log.logInformation $"got duplicate message with id %s{a.orderId}" + | None -> + //it is possible to do some upsert shenanigans also + do! execute "INSERT INTO inbox (orderId) VALUES (@orderId)" {| orderId = message.orderId |} + + () + + return () + } + + ///There is probably a nicer way of doing this, depending on prefered json library + let inline parseAs (bytes: ReadOnlyMemory) = + JsonDocument.Parse(bytes).RootElement + |> Operators.ofJsonValue + |> Result.mapError string + + let msgWork (ct: CancellationToken) = eff { + for msgModel in receive (ct) do + let! msg = parseAs (BinaryData.op_Implicit msgModel.Body) + + do! Log.logInformation ("Got message {message}", msg.message) + do! handleMessage msg + do! delete msgModel + + return () + } diff --git a/samples/SampleWeb/Environments.fs b/samples/SampleWeb/Environments.fs new file mode 100644 index 0000000..0fd2459 --- /dev/null +++ b/samples/SampleWeb/Environments.fs @@ -0,0 +1,131 @@ +namespace SampleWeb + +open Azure.Storage.Queues +open Dapper +open Microsoft.AspNetCore.Http +open Microsoft.AspNetCore.SignalR +open Microsoft.Data.Sqlite +open Microsoft.Extensions.Logging +open Microsoft.Extensions.DependencyInjection + +open Orsak +open Orsak.Effects +open Orsak.Extensions + +open System +open System.Data.Common +open System.Threading.Tasks + +open FSharpPlus +open FSharp.Control + +type ChatHub() = + inherit Hub() + + //invoked by InvokeAsync + member this.SendMessage(user, message) = + //triggers callers On... + this.Clients.Caller.MessageSent(user, message) + + override this.OnConnectedAsync() = + let caller = this.Clients.Caller + let user = this.Context.User + Task.CompletedTask + + +type MessageScope(queue: QueueClient) = + interface MessageSink with + member this.Send bytes = + queue.SendMessageAsync(BinaryData bytes) |>> ignore + + member this.Delete(msg) = + queue.DeleteMessageAsync(msg.MessageId, msg.PopReceipt) |>> ignore + + member this.Receive(token) = taskSeq { + let! _ = queue.CreateIfNotExistsAsync() + + while not (token.IsCancellationRequested) do + let! response = queue.ReceiveMessagesAsync(32, cancellationToken = token) + + if response.Value.Length = 0 then + //for extra credits, this could increase or shrink depending of prior history + do! Task.Delay(TimeSpan.FromMilliseconds 10) + else + yield! response.Value + } + +module Transaction = + let setup () = + let conn: DbConnection = new SqliteConnection("Data Source=test.db;Cache=Shared") + + conn.Execute( + """CREATE TABLE IF NOT EXISTS inbox( + id INTEGER PRIMARY KEY, + handled DATE DEFAULT CURRENT_TIMESTAMP, + orderId TEXT NOT NULL UNIQUE + );""" + ) + |> ignore + + let create () = vtask { + let conn: DbConnection = new SqliteConnection("Data Source=test.db;Cache=Shared") + do! conn.OpenAsync() + let! tran = conn.BeginTransactionAsync() + return DbTransactional(tran) + } + +type MainEnv = { + context: HttpContext + loggerFactory: ILoggerFactory + queueClient: MessageScope +} with + + interface IContextProvider with + member this.Context = this.context + + interface ILoggerProvider with + member this.Logger s = this.loggerFactory.CreateLogger(s) + + interface Scoped.CompletableScopeProvider with + member _.BeginScope() = Transaction.create () + + interface Scoped.ExceptionHandler with + member _.Handle(arg1: exn) : string = + raise (System.NotImplementedException()) + + interface MessageSinkProvider with + member this.Sink: MessageSink = this.queueClient + + interface GuidProvider with + member this.Gen = + { new GuidGenerator with + member _.NewGuid() = Guid.NewGuid() + } + + interface IChatHubProvider with + member this.Hub = + let cty = + this.context.RequestServices.GetRequiredService>() + + { new IChatHub with + member this.MessageSent(x, y) = cty.Clients.All.MessageSent(x, y) + } + + +type BackgroundEnv = { + loggerFactory: ILoggerFactory + queueClient: MessageScope +} with + + interface ILoggerProvider with + member this.Logger s = this.loggerFactory.CreateLogger(s) + + interface Scoped.CompletableScopeProvider with + member _.BeginScope() = Transaction.create () + + interface Scoped.ExceptionHandler with + member _.Handle(arg1: exn) : string = + raise (System.NotImplementedException()) + + interface MessageSinkProvider with + member this.Sink: MessageSink = this.queueClient diff --git a/samples/SampleWeb/Models.fs b/samples/SampleWeb/Models.fs deleted file mode 100644 index b324e8a..0000000 --- a/samples/SampleWeb/Models.fs +++ /dev/null @@ -1,12 +0,0 @@ -namespace Models - -open Fleece -open Fleece.SystemTextJson - -type Ping = { - message: string - a: int - b: float -} with - - static member ToJson(x: Ping) = jobj [ "message" .= x.message ] diff --git a/samples/SampleWeb/Program.fs b/samples/SampleWeb/Program.fs index 5560e1a..9497529 100644 --- a/samples/SampleWeb/Program.fs +++ b/samples/SampleWeb/Program.fs @@ -1,60 +1,53 @@ -open System -open System.Threading.Channels open Microsoft.AspNetCore.Builder -open Microsoft.AspNetCore.Http open Microsoft.Extensions.Hosting open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.Logging - -open Giraffe open Orsak -open FSharpPlus -open FSharpPlus.Control - -let getService<'t> (app: IApplicationBuilder) = - app.ApplicationServices.GetService<'t>() - -type MainEnv = { - context: HttpContext - loggerFactory: ILoggerFactory -} with - - interface Orsak.Extensions.IContextProvider with - member this.Context = this.context - - interface Orsak.Extensions.ILoggerProvider with - member this.Logger = this.loggerFactory.CreateLogger("EffectLogger") +open Orsak.AspNetCore - -let sanity1 () = eff { - return sprintf "%i" -} - -let sanity2 () = eff { - return 2 -} +open Azure.Storage.Queues +open SampleWeb +open Orsak.Extensions.Message +open FSharpPlus [] let main args = + let queueCLient = QueueClient("UseDevelopmentStorage=true", "my-ku") + Transaction.setup () let builder = WebApplication.CreateBuilder(args) + builder.Services + .AddHttpContextAccessor() + .AddSingleton(fun ctx -> { + loggerFactory = ctx.GetRequiredService<_>() + queueClient = MessageScope queueCLient + }) + .AddEffectWorker(msgWork) + .AddSignalR() + |> ignore + builder.Logging.AddSimpleConsole(fun opts -> opts.IncludeScopes <- true) |> ignore let app = builder.Build() - let loggerFactory = getService app - let r = Random(420) + let loggerFactory = app.Services.GetService() - let mainEnv ctx = { - context = ctx - loggerFactory = loggerFactory - } + let mkEnv ctx = { context = ctx; loggerFactory = loggerFactory; queueClient = MessageScope queueCLient } - let (x: Effect) = - sanity1 () <*> sanity2() + app + .UseRouting() + .UseEndpoints(fun builder -> + builder.MapEffectEndpoints( + let (r: EffectRunner<_>) = RunWith mkEnv in + [ + r.RouteGet("/ping", Application.ping) + r.RouteGet("/ping/%i", Application.ping2).WithName("ping") + r.RouteGet("/pong/%s/%i", Application.post) + ] + )) - app.UseGiraffe(Routes.R.webApp mainEnv) + |> ignore app.Run() diff --git a/samples/SampleWeb/Routes.fs b/samples/SampleWeb/Routes.fs deleted file mode 100644 index efa6761..0000000 --- a/samples/SampleWeb/Routes.fs +++ /dev/null @@ -1,77 +0,0 @@ -namespace Routes - -open Giraffe -open Orsak -open Orsak.Extensions -open Fleece -open Fleece.SystemTextJson -open Microsoft.AspNetCore.Http - -module EffectPipeline = - let wrap (e: Effect<_, _, _>) = - eff { - //other things before the effect is run - let! result = e - //stuff after the effect is run - return result - } - -type Response<'a> = - | StatusOk of 'a - | Created of string - -[] -type EffectRunner<'a> = - | RunWith of (HttpContext -> 'a) - - static member inline ( *>> )(effect: Effect<_, unit, string>, RunWith runEnv) : HttpHandler = - fun next ctx -> - task { - match! Effect.run (runEnv ctx) (EffectPipeline.wrap effect) with - | Ok() -> return! setStatusCode 204 <|| (next, ctx) - | Error _e -> return! setStatusCode 400 next ctx - } - - static member inline ( *>> )(effect: Effect<_, Response<'b>, string>, RunWith runEnv) : HttpHandler = - fun next ctx -> - task { - match! Effect.run (runEnv ctx) (EffectPipeline.wrap effect) with - | Ok(StatusOk b) -> - let payload = toJsonText b - - return! - setStatusCode 200 - >=> setHttpHeader "Content-Type" "application/json" - >=> setBodyFromString payload - <|| (next, ctx) - | Ok(Created href) -> - return! - setStatusCode 201 - >=> setHttpHeader "Content-Type" "application/json" - >=> setHttpHeader "Location" href - <|| (next, ctx) - | Error _e -> return! setStatusCode 400 next ctx - } - - - -module R = - let ping () : Effect<_, _, _> = eff { return () } - - let post () = eff { return () } - - - let webApp runEnv : HttpHandler = - let inline (==>) httpHandler effect = - httpHandler >=> effect *>> RunWith runEnv - - choose [ - GET - >=> choose [ - route "/ping" ==> ping () - route "/ping2" ==> ping () - route "/ping3" ==> ping () - ] - POST >=> route "/pong" >=> post () *>> RunWith runEnv - setStatusCode 404 >=> text "Not Found" - ] diff --git a/samples/SampleWeb/RoutesEffectRunner.fs b/samples/SampleWeb/RoutesEffectRunner.fs new file mode 100644 index 0000000..fd759df --- /dev/null +++ b/samples/SampleWeb/RoutesEffectRunner.fs @@ -0,0 +1,45 @@ +namespace SampleWeb + +open Application +open Microsoft.AspNetCore.Http + +open Orsak +open Fleece +open Fleece.SystemTextJson +open System.Text.Json + +module EndpointRouting = + let wrap (e: Effect<_, _, _>) = eff { + //other things before the effect is run + let! result = e + //stuff after the effect is run + return result + } + + let inline writeTo (writer: System.Buffers.IBufferWriter) b = + use writer = new Utf8JsonWriter(writer) + Operators.toJsonValue(b).WriteTo writer + do writer.Flush() + writer.BytesCommitted + + +type EffectRunner<'a> = + | RunWith of (HttpContext -> 'a) + + static member inline ( *>> )(effect: Effect<'a, IResult, string>, RunWith runEnv) : RequestDelegate = + RequestDelegate(fun ctx -> task { + match! Effect.run (runEnv ctx) (EndpointRouting.wrap effect) with + | Ok result -> return! result.ExecuteAsync ctx + | Error e -> return () + }) + + static member inline ( *>> )(effect: Effect<'a, 'b, string>, RunWith runEnv) : RequestDelegate = + RequestDelegate(fun ctx -> task { + match! Effect.run (runEnv ctx) (EndpointRouting.wrap effect) with + | Ok b -> + let written = b |> EndpointRouting.writeTo ctx.Response.BodyWriter + ctx.Response.Headers.ContentLength <- written + ctx.Response.Headers.ContentType <- "application/json; charset=UTF-8" + do! ctx.Response.CompleteAsync() + | Error e -> return () + }) diff --git a/samples/SampleWeb/SampleWeb - Backup.fsproj b/samples/SampleWeb/SampleWeb - Backup.fsproj new file mode 100644 index 0000000..acaa433 --- /dev/null +++ b/samples/SampleWeb/SampleWeb - Backup.fsproj @@ -0,0 +1,31 @@ + + + net6.0 + 0.1.0.0 + 0.1.0.0 + 0.1.0-beta.28+Branch.main.Sha.de0812bbd4257b3581e40b032397d238a9bfe3a9 + 0.1.0-beta0028 + 57 + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/samples/SampleWeb/SampleWeb.fsproj b/samples/SampleWeb/SampleWeb.fsproj index d52d8bd..c7eff29 100644 --- a/samples/SampleWeb/SampleWeb.fsproj +++ b/samples/SampleWeb/SampleWeb.fsproj @@ -5,21 +5,27 @@ 0.1.0.0 0.1.0-beta.28+Branch.main.Sha.de0812bbd4257b3581e40b032397d238a9bfe3a9 0.1.0-beta0028 + 57 - - - + + + + + - - + + + + + \ No newline at end of file diff --git a/src/Orsak/Effect.fs b/src/Orsak/Effect.fs index 7a52569..88471a7 100644 --- a/src/Orsak/Effect.fs +++ b/src/Orsak/Effect.fs @@ -4,6 +4,7 @@ open System.Threading open FSharp.Control open System.Threading.Tasks open System +open System.Collections.Generic [] module Effect = @@ -201,8 +202,7 @@ module Effect = /// Executes effects in parallel if possible. /// /// The effects to run in parallel - let inline whenAll (s: Effect<'r, 'a, 'e> seq) : Effect<'r, 'a array, 'e> = - eff.Run(eff.WhenAll(s)) + let inline whenAll (s: Effect<'r, 'a, 'e> seq) : Effect<'r, 'a array, 'e> = eff.Run(eff.WhenAll(s)) /// /// Executes effects in parallel if possible. @@ -212,6 +212,7 @@ module Effect = let! _ = whenAll s return () } + let inline par (s: Effect<'r, 'a, 'e> seq) = eff { let! array = whenAll s return List.ofArray array @@ -219,9 +220,10 @@ module Effect = ///Traverses an array of effects, turning it in to an effect of an array. ///For a more generic implementation, consider FSharpPlus - let inline traverse f (effects: Effect<'r, 'a, 'e> array): Effect<'r, 'b array, 'e> = eff { + let inline traverse f (effects: Effect<'r, 'a, 'e> array) : Effect<'r, 'b array, 'e> = eff { let store = Array.zeroCreate effects.Length let mutable i = 0 + while i < effects.Length do let! result = effects[i] store[i] <- f result @@ -299,6 +301,10 @@ type Effect = static member Create(f: 'a -> Async>) = mkEffect (fun a -> ValueTask<_>(task = Async.StartAsTask(f a))) +type EffSeq = + static member Create(f: 'r -> IAsyncEnumerable>) = + EffSeq.Effect(EffectSeqDelegate(fun r -> f r)) + [] module WrapTwice = //extensions for Effect for things weed need to wrap twice. lowest prio @@ -311,6 +317,13 @@ module WrapTwice = static member Create<'a, 'b, 'e>(f: 'a -> 'b) : Effect<'a, 'b, 'e> = mkEffect (f >> Ok >> ValueTask.FromResult) + + type EffSeq with + static member Create<'r, 'a, 'e>(f: 'r -> IAsyncEnumerable<'a>) : EffSeq<'r, 'a, 'e> = effSeq { + let! seq = mkEffect(f >> Ok >> ValueTask.FromResult) + for e in seq do yield e + } + [] module WrapOnce = //extensions for Effect for things weed need to wrap once, or which wraps once diff --git a/src/Orsak/EffectBuilder.fs b/src/Orsak/EffectBuilder.fs index 50286d3..141b99a 100644 --- a/src/Orsak/EffectBuilder.fs +++ b/src/Orsak/EffectBuilder.fs @@ -3243,6 +3243,53 @@ module Medium = type EffBuilderBase with (* DO WANT *) + + member inline this.Using<'TaskLike, 'Awaiter, 'Resource, 'TOverall, 'T, 'Env, 'Err + when 'TaskLike: (member GetAwaiter: unit -> 'Awaiter) + and 'Awaiter :> ICriticalNotifyCompletion + and 'Awaiter: (member get_IsCompleted: unit -> bool) + and 'Awaiter: (member GetResult: unit -> unit) + and 'Resource: (member DisposeAsync: unit -> 'TaskLike) + and 'Resource: struct> + ( + resource: 'Resource, + body: 'Resource -> EffectCode<'Env, 'TOverall, 'T, 'Err> + ) : EffectCode<'Env, 'TOverall, 'T, 'Err> = + ResumableCode.TryFinallyAsync( + (ResumableCode(fun sm -> (body resource).Invoke(&sm))), + (ResumableCode(fun sm -> + let taskLike = resource.DisposeAsync() + + if __useResumableCode then + let mutable __stack_condition_fin = true + + let mutable awaiter = taskLike.GetAwaiter() + + if not (awaiter.get_IsCompleted ()) then + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_condition_fin <- __stack_yield_fin + + if not __stack_condition_fin then + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + + __stack_condition_fin + else + + let mutable awaiter = taskLike.GetAwaiter() + // shortcut to continue immediately + if awaiter.get_IsCompleted () then + true + else + let cont = + EffectResumptionFunc<'Env, 'TOverall, 'Err>(fun sm -> + awaiter.GetResult() + true) + + sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) + sm.ResumptionDynamicInfo.ResumptionFunc <- cont + false)) + ) + static member inline BindDynamic ( sm: byref<_>, @@ -3424,6 +3471,35 @@ module Medium = ) )) + member inline this.For(s: ConfiguredCancelableAsyncEnumerable<'a>, [] f) = + this.Delay(fun () -> + this.Using( + s.GetAsyncEnumerator(), + fun (enumerator) -> + let mutable continue' = false + + this.Bind( + enumerator.MoveNextAsync(), + fun b -> + continue' <- b + + this.While( + (fun () -> continue'), + this.Delay(fun () -> + this.Combine( + (f enumerator.Current), + this.Bind( + enumerator.MoveNextAsync(), + fun b -> + let y = b + continue' <- y + this.Zero() + ) + )) + ) + ) + )) + member inline this.While ( [] condition: unit -> Effect<'Env, bool, 'Err>, @@ -3565,6 +3641,6 @@ type Effect<'R, 'T, 'E> with static member inline (<*>)(f: Effect<'r, 'b -> 'a, 'e>, e: Effect<'r, 'b, 'e>) = eff { let! fn = f - let! a = e - return fn a + and! b = e + return fn b } diff --git a/src/Orsak/Effects/Database.fs b/src/Orsak/Effects/Database.fs new file mode 100644 index 0000000..a9bda0c --- /dev/null +++ b/src/Orsak/Effects/Database.fs @@ -0,0 +1,173 @@ +namespace Orsak.Effects + +#nowarn "57" +//#nowarn "3559" + +open System.Data.Common +open System.Threading.Tasks +open Orsak +open Orsak.Scoped +open FSharp.Control + +[] +type DbTransactional(tran: DbTransaction) = + member val Connection = tran.Connection + + interface CompletableScope with + member this.Complete() = vtask { do tran.Commit() } + + member this.DisposeAsync() : ValueTask = vtask { + do! tran.DisposeAsync() + do! this.Connection.DisposeAsync() + } + +/// +/// Pure transaction effect. +/// +type Transaction<'a, 'err> = Effect + +/// +/// Effects created by trxAware have this type. +/// +type EnlistedTransaction<'r, 'a, 'err> = Effect<'r * DbTransactional, 'a, 'err> + +namespace Orsak.Scoped + +open Orsak +open Orsak.Effects +open System.Threading +open System.Threading.Tasks + +[] +module Builder = + let commitEff = Orsak.Scoped.CompletableScopeCreatingEffectBuilder() + + let trxAware = Orsak.ScopeAware.ScopeAwareEffectBuilder() + +(* + Using scoped effects: +*) + +//define some kind of Effect that should be scoped +[] +type IProgressScope = + abstract member Progress: System.IProgress + inherit Scoped + +//type alias for convini +type IProgressScopeProvider = ScopeProvider + +//builder for your scope +module Builder2 = + //using this to create an effect, will create an IProgressScope at the start of the effect, and it will be available + //throught the effect, and disposed at the end of the effect + //the result will be just a normal effect, that requires a IProgressScopeProvider + let pEff = Orsak.Scoped.ScopeCreatingEffectBuilder() + + //using this allows access to the IProgressScope created by a another effect + //expects to be bound in pEff + //if bound in a normal eff, the resulting Effect will be specialized as an enlisted progress effect + let enlistP = Orsak.ScopeAware.ScopeAwareEffectBuilder() + +open Builder2 + +module Progress = + //Pure progress effect, no other effects allowed. + type Progress<'err> = Effect + + //Function for calling our scoped effect + let report (t: float) : Progress<_> = + //by not making x generic, we restrict how report is called. (No #) + //it can now only really be called through pEff or enlistP + Effect.Create(fun (x: IProgressScope) -> x.Progress.Report(t)) + + let reportWhenDone total (e: Effect<'r,_,_>) = enlistP { + let! result = e + do! report total + return result + } + + let reportWhenDone2 total (e: Effect<'r,_,_>) = eff { + let! a = reportWhenDone total e + return a + } + + let whenAll (effects: Effect<'r,_,_> array) = pEff { + let total = float effects.Length + let! result = + effects + |> Array.map(reportWhenDone total) + |> Effect.whenAll + + return result + } + + let whenAllBatch size (effects: Effect<'r,_,_> array) = pEff { + let total = float effects.Length + use ss = new SemaphoreSlim(size) + let! _x = + effects + |> Array.map(fun e -> eff { + do! ss.WaitAsync() + try + return! reportWhenDone total e + finally + ss.Release() |> ignore + }) + |> Effect.whenAll + + return () + } + +//Implementation of the Scoped Effect +type ProgressScope() = + let mutable Calls = 0. + //unique progress per scope. + let p = new System.Progress(fun _x -> ()) + do + p.ProgressChanged.Add(fun total -> + Calls <- Calls + 1. + let pcnt = Calls / total + System.Console.WriteLine(pcnt) + ) + interface IProgressScope with + member this.Progress = p + member this.DisposeAsync() = ValueTask() + +(* Mixing in other effects *) +type GuidGenerator = + abstract member NewGuid: unit -> System.Guid + +type GuidProvider = + abstract member Gen: GuidGenerator + +module GuidGenerator = + let newGuid () = + Effect.Create(fun (p: #GuidProvider) -> p.Gen.NewGuid()) + + + +type Runner() = + interface IProgressScopeProvider with + member this.BeginScope() = ValueTask(ProgressScope()) + + interface GuidProvider with + member this.Gen = raise (System.NotImplementedException()) + +module Test = + let test2() = eff { + return! + [| GuidGenerator.newGuid () |] + |> Progress.whenAllBatch 10 + } + + let test() = task { + match! + test2() + |> id + |> Effect.run (Runner()) + with + | Ok () -> () + | Error (_ :string) -> () + } + diff --git a/src/Orsak/Orsak.fsproj b/src/Orsak/Orsak.fsproj index 305e4af..1d533d6 100644 --- a/src/Orsak/Orsak.fsproj +++ b/src/Orsak/Orsak.fsproj @@ -34,6 +34,7 @@ + diff --git a/src/Orsak/ScopedEffect.fs b/src/Orsak/ScopedEffect.fs index 74da2af..f3c12f8 100644 --- a/src/Orsak/ScopedEffect.fs +++ b/src/Orsak/ScopedEffect.fs @@ -1,5 +1,4 @@ -[] -module Orsak.Scoped +namespace Orsak.Scoped open Orsak open FSharp.Control @@ -8,7 +7,6 @@ open System open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Core.CompilerServices.StateMachineHelpers - type ScopedEffectCode<'Scope, 'Env, 'TOverall, 'T, 'Err> = EffectCode<'Env * 'Scope, 'TOverall, 'T, 'Err> #nowarn "57" @@ -22,8 +20,7 @@ type ScopedEffectBuilder() = [] module Extension = type ScopedEffectBuilder with - - member inline this.ReturnFrom<'Scope, 'Env, 'T, 'TOverall, 'Err> + member inline this.ReturnFrom<'Scope, 'Env, 'TOverall, 'Err> (eff: Effect<'Env, 'TOverall, 'Err>) : ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TOverall, 'Err> = ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TOverall, 'Err>(fun sm -> @@ -50,11 +47,10 @@ module Extension = EffBuilder.BindDynamic(&sm, task, this.Return)) [] - member inline _.Bind<'Scope, 'Env, 'T, 'TOverall, 'TResult1, 'TResult2, 'Err> + member inline _.Bind<'Scope, 'Env, 'TOverall, 'TResult1, 'TResult2, 'Err> ( eff: Effect<'Env, 'TResult1, 'Err>, continuation: 'TResult1 -> ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> - ) : ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> = ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err>(fun sm -> let env, _ = sm.Data.Environment @@ -81,19 +77,59 @@ module Extension = sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) false else - EffBuilder.BindDynamic(&sm, task, continuation)) + EffBuilder.BindDynamic(&sm, task, continuation)) + +type Scoped = IAsyncDisposable -type ScopeProvider<'Scope when 'Scope :> IAsyncDisposable> = - abstract member Scope: unit -> ValueTask<'Scope> +type ScopeProvider<'Scope when 'Scope :> Scoped> = + abstract member BeginScope: unit -> ValueTask<'Scope> -type ScopedEffectBuilder<'Scope when 'Scope :> IAsyncDisposable>() = +///A computation expression that knows how to start a scope local to the effect, and bind effects in that scope +[] +type ScopeCreatingEffectBuilder<'Scope when 'Scope :> Scoped>() = inherit ScopedEffectBuilder() + member inline this.Bind(ex: Effect<'Env * 'Scope, 'a, 'err>, cont) = eff.Bind(ex, cont) + + [] + member inline _.Bind<'Env, 'TOverall, 'TResult1, 'TResult2, 'Err> + ( + eff: Effect<'Scope, 'TResult1, 'Err>, + continuation: 'TResult1 -> ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> + + ) : ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> = + ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err>(fun sm -> + let _, scope = sm.Data.Environment + let task = eff.Run scope + + if __useResumableCode then + let mutable awaiter = task.GetAwaiter() + + let mutable __stack_fin = true + + if not awaiter.IsCompleted then + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_fin <- __stack_yield_fin + + if __stack_fin then + let result = awaiter.GetResult() + + match result with + | Ok result -> (continuation result).Invoke(&sm) + | Error error -> + sm.Data.Result <- Error error + true + else + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + false + else + EffBuilder.BindDynamic(&sm, task, continuation)) + member _.Run<'r, 'a, 'err when 'r :> ScopeProvider<'Scope>> (effect: ScopedEffectCode<'Scope, 'r, 'a, 'a, 'err>) : Effect<'r, 'a, 'err> = mkEffect (fun env -> vtask { - use! scope = (env :> ScopeProvider<'Scope>).Scope() + use! scope = (env :> ScopeProvider<'Scope>).BeginScope() match! eff.Run(effect).Run((env, scope)) with | Ok a -> return Ok a @@ -103,15 +139,19 @@ type ScopedEffectBuilder<'Scope when 'Scope :> IAsyncDisposable>() = type ExceptionHandler<'err> = abstract member Handle: exn -> 'err -type TransactionScope = - abstract member CommitAsync: unit -> Task - inherit IAsyncDisposable +type CompletableScope = + abstract member Complete: unit -> ValueTask + inherit Scoped -type TransactionScopeProvider<'Scope when 'Scope :> TransactionScope> = ScopeProvider<'Scope> +type CompletableScopeProvider<'Scope when 'Scope :> CompletableScope> = ScopeProvider<'Scope> -type TransactionalEffectBuilder<'Scope when 'Scope :> TransactionScope>() = +///A computation expression that knows how to start a completable scope local to the effect, and bind effects in that scope +[] +type CompletableScopeCreatingEffectBuilder<'Scope when 'Scope :> CompletableScope>() = inherit ScopedEffectBuilder() + member inline this.Bind(ex: Effect<'Env * 'Scope, 'a, 'err>, cont) = eff.Bind(ex, cont) + member inline this.ReturnFrom<'Scope, 'Env, 'TOverall, 'Err> (eff: Effect<'Scope, 'TOverall, 'Err>) : ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TOverall, 'Err> = @@ -140,15 +180,15 @@ type TransactionalEffectBuilder<'Scope when 'Scope :> TransactionScope>() = EffBuilder.BindDynamic(&sm, task, this.Return)) [] - member inline _.Bind<'Env, 'T, 'TOverall, 'TResult1, 'TResult2, 'Err> + member inline _.Bind<'Env, 'TOverall, 'TResult1, 'TResult2, 'Err> ( - eff: Effect<'Scope, 'TResult1, 'Err>, + scopedEff: Effect<'Scope, 'TResult1, 'Err>, continuation: 'TResult1 -> ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> ) : ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> = ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err>(fun sm -> let _, scope = sm.Data.Environment - let task = eff.Run scope + let task = scopedEff.Run scope if __useResumableCode then let mutable awaiter = task.GetAwaiter() @@ -173,19 +213,104 @@ type TransactionalEffectBuilder<'Scope when 'Scope :> TransactionScope>() = else EffBuilder.BindDynamic(&sm, task, continuation)) - member _.Run<'r, 'a, 'err when 'r :> ExceptionHandler<'err> and 'r :> TransactionScopeProvider<'Scope>> + member _.Run<'r, 'a, 'err when 'r :> ExceptionHandler<'err> and 'r :> CompletableScopeProvider<'Scope>> (effect: ScopedEffectCode<'Scope, 'r, 'a, 'a, 'err>) : Effect<'r, 'a, 'err> = mkEffect (fun env -> vtask { try - use! scope = (env :> TransactionScopeProvider<'Scope>).Scope() + use! scope = (env :> CompletableScopeProvider<'Scope>).BeginScope() match! eff.Run(effect).Run((env, scope)) with | Ok a -> - do! scope.CommitAsync() + do! scope.Complete() return Ok a | Error e -> return Error e with e -> let (err: 'err) = (env :> ExceptionHandler<'err>).Handle e return Error err }) + +namespace Orsak.ScopeAware + +open Orsak +open Orsak.Scoped +open Microsoft.FSharp.Core.CompilerServices +open Microsoft.FSharp.Core.CompilerServices.StateMachineHelpers + + +/// +/// Allows for binding effects in a scope, but does not allow for starting a new scope. +/// Typically would be run by binding them in a scoped effect. Not expected to be run by themselves, since the +/// Effect.run must run it with an already started scope, and the scopes would generally be started implicitly. +/// +[] +type ScopeAwareEffectBuilder<'Scope>() = + inherit ScopedEffectBuilder() + + member inline this.ReturnFrom<'Scope, 'Env, 'TOverall, 'Err> + (eff: Effect<'Scope, 'TOverall, 'Err>) + : ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TOverall, 'Err> = + ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TOverall, 'Err>(fun sm -> + let _, scope = sm.Data.Environment + let task = eff.Run scope + + if __useResumableCode then + let mutable awaiter = task.GetAwaiter() + + let mutable __stack_fin = true + + if not awaiter.IsCompleted then + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_fin <- __stack_yield_fin + + if __stack_fin then + let result = awaiter.GetResult() + sm.Data.Result <- result + true + + else + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + false + else + EffBuilder.BindDynamic(&sm, task, this.Return)) + + /// + /// Binds the effects from the scope + /// + /// + /// + [] + member inline _.Bind<'Env, 'TOverall, 'TResult1, 'TResult2, 'Err> + ( + eff: Effect<'Scope, 'TResult1, 'Err>, + continuation: 'TResult1 -> ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> + + ) : ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err> = + ScopedEffectCode<'Scope, 'Env, 'TOverall, 'TResult2, 'Err>(fun sm -> + let _, scope = sm.Data.Environment + let task = eff.Run scope + + if __useResumableCode then + let mutable awaiter = task.GetAwaiter() + + let mutable __stack_fin = true + + if not awaiter.IsCompleted then + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_fin <- __stack_yield_fin + + if __stack_fin then + let result = awaiter.GetResult() + + match result with + | Ok result -> (continuation result).Invoke(&sm) + | Error error -> + sm.Data.Result <- Error error + true + else + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + false + else + EffBuilder.BindDynamic(&sm, task, continuation)) + + member _.Run(effect: ScopedEffectCode<'Scope, 'r, 'a, 'a, 'err>) : Effect<'r * 'Scope, 'a, 'err> = eff.Run(effect) diff --git a/tests/Orsak.Tests/EffSeqTests.fs b/tests/Orsak.Tests/EffSeqTests.fs index a53651e..4eea6d2 100644 --- a/tests/Orsak.Tests/EffSeqTests.fs +++ b/tests/Orsak.Tests/EffSeqTests.fs @@ -116,10 +116,12 @@ module Helpers2 = interface IAsyncDisposable with member this.DisposeAsync() = - ValueTask(task = task { - this.WasDisposed <- true - do! Task.Yield() - }) + ValueTask( + task = task { + this.WasDisposed <- true + do! Task.Yield() + } + ) type IRand = abstract member Next: unit -> int @@ -456,6 +458,7 @@ module ``Effect Sequences With Elements`` = 2 3 } + for i = 0 to 1000 do do! evaluatesToSequence [ 1; 2; 3 ] s } @@ -626,7 +629,8 @@ module ``Effect Sequences With Elements`` = for _ in 1..3 do yield! next () - }).Invoke(provider) + }) + .Invoke(provider) |> TaskSeq.toListAsync let rand = Random(seed) @@ -655,7 +659,7 @@ module ``Effect Sequences With Elements`` = } |> evaluatesToSequence [ 1; 2 ] - + [] let ``should bind tasks yielding after bind`` () = effSeq { @@ -665,7 +669,7 @@ module ``Effect Sequences With Elements`` = } |> evaluatesToSequence [ 1; 2 ] - + [] let ``should bind tasks interleaved`` () = effSeq { @@ -677,7 +681,12 @@ module ``Effect Sequences With Elements`` = do! Task.Yield() 4 } - |> evaluatesToSequence [ 1; 2; 3; 4 ] + |> evaluatesToSequence [ + 1 + 2 + 3 + 4 + ] [] @@ -691,20 +700,23 @@ module ``Effect Sequences With Elements`` = [] let ``should support parallel calls to GetEnumerator`` () = task { - let enumerable = - effSeq { - 1 - do! vtask { do! Task.Yield() } - 2 - } + let enumerable = effSeq { + 1 + do! vtask { do! Task.Yield() } + 2 + } + do! Parallel.ForEachAsync( - [ 1.. 10 ], + [ 1..10 ], ParallelOptions(MaxDegreeOfParallelism = 10), - (fun _ _ -> ValueTask(task = task { - do! evaluatesToSequence [ 1; 2; ] enumerable - return () - })) + (fun _ _ -> + ValueTask( + task = task { + do! evaluatesToSequence [ 1; 2 ] enumerable + return () + } + )) ) return () @@ -718,7 +730,7 @@ module ``Effect Sequences With Elements`` = do! Async.AwaitTask(task { do! Task.Delay(10) }) 2 } - |> evaluatesToSequence [ 1; 2; ] + |> evaluatesToSequence [ 1; 2 ] [] let ``should bind results`` () = diff --git a/tests/Orsak.Tests/NameParserTests.fs b/tests/Orsak.Tests/NameParserTests.fs new file mode 100644 index 0000000..f71832e --- /dev/null +++ b/tests/Orsak.Tests/NameParserTests.fs @@ -0,0 +1,123 @@ +module Orsak.Tests.NameParserTests + +open Xunit +open Microsoft.FSharp.Quotations.Patterns +open Microsoft.FSharp.Quotations + +type Helper = + static member Convert([] a: Expr<_>) = + match a with + | WithValue(_, _, expr) -> Orsak.AspNetCore.Helpers.getNames expr + | _ -> failwith "" + + static member ConvertMethodInfo([] a: Expr<_>) = + match a with + | WithValue(_, _, expr) -> Orsak.AspNetCore.Helpers.getMethodInfo expr + | _ -> failwith "" + +let singleArgFunction (i: int) = ignore i +let twoArgFunction (i: int) (j: int) = ignore (i, j) + +let twoTupleFunction (i: int, j: int) = ignore (i, j) + +let mixedFunction (i: int, j: int) (k: int) = ignore (i, j, k) +let threeTupleFunction (i: int, j: int, k: int) = ignore (i, j, k) + +let mixedThreeTupleFunction (i: int, j: int, k: int) (l: int) = ignore (i, j, k, l) + +let fourTupleFunction (i: int, j: int, k: int, l: int) = ignore (i, j, k, l) +let mixedFourTupleFunction (i: int, j: int, k: int, l: int) (m: int) = ignore (i, j, k, l, m) + +[] +let ``Can parse single argument`` () = + let s = Helper.Convert(singleArgFunction) + Assert.Equal<_ array>([| "i" |], s) + +[] +let ``Can parse single argument annonymous function`` () = + let s = Helper.Convert(fun (i: int) -> ignore i) + Assert.Equal<_ array>([| "i" |], s) + +[] +let ``Can parse single argument lambda`` () = + let s = Helper.Convert(fun (i: int) -> ignore i) + Assert.Equal<_ array>([| "i" |], s) + +[] +let ``Can parse two argument`` () = + let s = Helper.Convert(twoArgFunction) + Assert.Equal<_ array>([| "i"; "j" |], s) + +[] +let ``Can parse two argument lambda`` () = + let s = Helper.Convert(fun (i: int) (j: int) -> ignore (i, j)) + Assert.Equal<_ array>([| "i"; "j" |], s) + +[] +let ``Can parse two tuple argument`` () = + let s = Helper.Convert(twoTupleFunction) + Assert.Equal<_ array>([| "i"; "j" |], s) + +[] +let ``Can parse two tuple lambda`` () = + let s = Helper.Convert(fun (i: int, j: int) -> ignore (i, j)) + Assert.Equal<_ array>([| "i"; "j" |], s) + +[] +let ``Can parse two arguments one which is tuple`` () = + let s = Helper.Convert(mixedFunction) + Assert.Equal<_ array>([| "i"; "j"; "k" |], s) + +[] +let ``Can parse three tuple argument`` () = + let s = Helper.Convert(threeTupleFunction) + Assert.Equal<_ array>([| "i"; "j"; "k" |], s) + +[] +let ``Can parse three tuple mixed arguments`` () = + let s = Helper.Convert(mixedThreeTupleFunction) + + Assert.Equal<_ array>( + [| + "i" + "j" + "k" + "l" + |], + s + ) + +[] +let ``Can parse four tuple argument`` () = + let s = Helper.Convert(fourTupleFunction) + + Assert.Equal<_ array>( + [| + "i" + "j" + "k" + "l" + |], + s + ) + +[] +let ``Can parse four tuple mixed arguments`` () = + let s = Helper.Convert(mixedFourTupleFunction) + + Assert.Equal<_ array>( + [| + "i" + "j" + "k" + "l" + "m" + |], + s + ) + +[] +let ``Can get method info`` () = + let s = Helper.ConvertMethodInfo(mixedFourTupleFunction) + + Assert.Equal(nameof mixedFourTupleFunction, s.Name) diff --git a/tests/Orsak.Tests/Orsak.Tests.fsproj b/tests/Orsak.Tests/Orsak.Tests.fsproj index 8dad9a7..20feebd 100644 --- a/tests/Orsak.Tests/Orsak.Tests.fsproj +++ b/tests/Orsak.Tests/Orsak.Tests.fsproj @@ -1,39 +1,41 @@  - - net8.0 - false - false - true - 0.1.0.0 - 0.1.0.0 - 0.1.0-beta.28+Branch.main.Sha.de0812bbd4257b3581e40b032397d238a9bfe3a9 - 0.1.0-beta0028 - - - - - - - - - - - - - - - - - - runtime; build; native; contentfiles; analyzers; buildtransitive - all - - - runtime; build; native; contentfiles; analyzers; buildtransitive - all - - - - - + + net7.0;net8.0 + false + false + true + 0.1.0.0 + 0.1.0.0 + 0.1.0-beta.28+Branch.main.Sha.de0812bbd4257b3581e40b032397d238a9bfe3a9 + 0.1.0-beta0028 + + + + + + + + + + + + + + + + + + + runtime; build; native; contentfiles; analyzers; buildtransitive + all + + + runtime; build; native; contentfiles; analyzers; buildtransitive + all + + + + + + \ No newline at end of file diff --git a/tests/Orsak.Tests/RecoveryTests.fs b/tests/Orsak.Tests/RecoveryTests.fs index 95abf40..95f911d 100644 --- a/tests/Orsak.Tests/RecoveryTests.fs +++ b/tests/Orsak.Tests/RecoveryTests.fs @@ -28,13 +28,12 @@ let ``the effect is executed again on retry`` () = task { Ok() =! result } -let my_yield () = eff { - do! Task.Yield() -} +let my_yield () = eff { do! Task.Yield() } [] let ``effects can safely be run multiple times`` () = task { let mutable x = 0 + let theEffect = eff { x <- x + 1 do! my_yield () @@ -92,7 +91,7 @@ let ``the effect is not executed again on if cond is not matched on retryIf`` () [] let ``recover is never run on success`` () = task { let! result = - (eff { do! Task.Yield() }) + eff { do! Task.Yield() } |> Effect.recover (fun _ -> failwith "Never run") |> Effect.run () @@ -104,7 +103,7 @@ let ``recover is run once on error`` () = task { let mutable counter = 0 let! result = - (eff { return! Error "I am Error" }) + eff { return! Error "I am Error" } |> Effect.recover (fun _ -> counter <- counter + 1) |> Effect.run () @@ -115,7 +114,7 @@ let ``recover is run once on error`` () = task { [] let ``tryRecovery is never run on success`` () = task { let! result = - (eff { do! Task.Yield() }) + eff { do! Task.Yield() } |> Effect.tryRecover (fun _ -> failwith "Never run") |> Effect.run () @@ -127,7 +126,7 @@ let ``tryRecover is run once on error`` () = task { let mutable counter = 0 let! result = - (eff { return! Error "I am Error" }) + eff { return! Error "I am Error" } |> Effect.tryRecover (fun _ -> counter <- counter + 1 Ok()) @@ -141,7 +140,7 @@ let ``tryRecover is run once on error`` () = task { [] let ``onError is never run on success`` () = task { let! result = - (eff { do! Task.Yield() }) + eff { do! Task.Yield() } |> Effect.onError (fun _ -> failwith "Never run") |> Effect.run () @@ -153,11 +152,11 @@ let ``onError is run once on error`` () = task { let mutable counter = 0 let! result = - (eff { + eff { do! Task.Yield() return! Error "I am Error" - }) + } |> Effect.onError (fun _ -> eff { counter <- counter + 1 return () diff --git a/tests/Orsak.Tests/ScopedTests.fs b/tests/Orsak.Tests/ScopedTests.fs index ac86de0..db39d22 100644 --- a/tests/Orsak.Tests/ScopedTests.fs +++ b/tests/Orsak.Tests/ScopedTests.fs @@ -1,59 +1,67 @@ namespace Orsak.Tests open System +open System.Security.Cryptography +open Microsoft.FSharp.NativeInterop +open System.Runtime.InteropServices +//#nowarn "9" #nowarn "57" open System.Data.Common -open System.Threading.Tasks open FSharp.Control open Microsoft.Data.Sqlite open Orsak +open Orsak.Effects +open Orsak.ScopeAware open Orsak.Scoped open Xunit +open Swensen.Unquote + +type RNGProvider = + abstract member Gen: RandomNumberGenerator + +module RandomNumberGenerator = + let getBytes (x: byte array) = + + Effect.Create(fun (provider: #RNGProvider) -> provider.Gen.GetBytes(x)) type IClock = - abstract member UtcNow: unit -> System.DateTimeOffset + abstract member UtcNow: unit -> DateTimeOffset type IClockProvider = abstract member Clock: IClock -type Clock = - static member utcNow() = +module Clock = + let utcNow () = Effect.Create(fun (provider: #IClockProvider) -> provider.Clock.UtcNow()) - - -type DbTransactional(tran: DbTransaction) = - member val Connection = tran.Connection - - interface TransactionScope with - member this.CommitAsync() : Task = tran.CommitAsync() - - member this.DisposeAsync() : ValueTask = vtask { - do! tran.DisposeAsync() - do! this.Connection.DisposeAsync() - } - type TestProvider() = + let rng = RandomNumberGenerator.Create() + interface ExceptionHandler with member this.Handle e = e.ToString() interface IClockProvider with member this.Clock = { new IClock with - member this.UtcNow() = System.DateTimeOffset.UtcNow + member this.UtcNow() = DateTimeOffset.UtcNow } - interface TransactionScopeProvider with - member this.Scope() : ValueTask = vtask { + interface RNGProvider with + member this.Gen: RandomNumberGenerator = rng + + interface CompletableScopeProvider with + member this.BeginScope() = vtask { let conn: DbConnection = new SqliteConnection("Data Source=test.db;Cache=Shared") do! conn.OpenAsync() let! tran = conn.BeginTransactionAsync() return DbTransactional(tran) } + + type Scoped() = do use conn = new SqliteConnection("Data Source=test.db;Cache=Shared") @@ -62,29 +70,22 @@ type Scoped() = let command = conn.CreateCommand() command.CommandText <- - """ - CREATE TABLE TestData ( - pkey INTEGER PRIMARY KEY AUTOINCREMENT, - data TEXT NOT NULL - );""" + """CREATE TABLE IF NOT EXISTS TestData ( + pkey INTEGER PRIMARY KEY AUTOINCREMENT, + data TEXT NOT NULL + );""" command.ExecuteNonQuery() |> ignore tran.Commit() () - - let commitEff = TransactionalEffectBuilder() - //Mostly explores what is possible with this api //all the async usage is wasted with SQLite, but can be valuable with other providers. - let read () = + let read () : Transaction<_, _> = mkEffect (fun (trans: DbTransactional) -> vtask { let command = trans.Connection.CreateCommand() - command.CommandText <- - """ - SELECT pkey, data FROM TestData - """ + command.CommandText <- "SELECT pkey, data FROM TestData" let list = ResizeArray() @@ -101,15 +102,36 @@ type Scoped() = return Error(e.ToString()) }) - let insert () = - mkEffect (fun (trans: DbTransactional) -> vtask { - let command = trans.Connection.CreateCommand() - command.CommandText <- - """ - INSERT INTO TestData (data) VALUES (@data) - """ + let readSingle () : EnlistedTransaction<_, _, _> = trxAware { + let! _now = Clock.utcNow () + + let! list = read () + let value = Assert.Single(list) + Assert.Equal((1, "test"), value) + return () + } + + let readEmpty () = commitEff { + let! list = read () + Assert.Empty list + return () + } + + let readAndCommit () = commitEff { return! read () } + + let readThenFail () = trxAware { + let! _now = Clock.utcNow () + let! list = read () + let value = Assert.Single(list) + Assert.Equal((1, "test"), value) + return! Error "Something went wrong" + } + let insert () : Transaction = + mkEffect (fun (trans: DbTransactional) -> vtask { + let command = trans.Connection.CreateCommand() + command.CommandText <- """INSERT INTO TestData (data) VALUES (@data)""" let par = command.CreateParameter() par.ParameterName <- "@data" par.Value <- "test" @@ -118,6 +140,19 @@ type Scoped() = return Ok() }) + let scopedInsert () = trxAware { + do! insert () + return () + } + + let insertWithError () = commitEff { + do! insert () + let! list = read () + let value = Assert.Single(list) + Assert.Equal((1, "test"), value) + return! Error "expected" + } + let run e = Effect.runOrFail (TestProvider()) e @@ -131,17 +166,29 @@ type Scoped() = failwith $"Got error %O{es} when expecting error %O{error}") [] - let ``Connection tests`` () = + let ``We can bind a scoped effect and then a regular effect with proper overload resolution`` () = commitEff { let! list = read () - Assert.Empty list + let! _now = Clock.utcNow () - return 1 + + Assert.Empty(list) + return () } |> run [] - let ``Connection tests 2`` () = + let ``We can bind a regular effect and then a scoped effect with proper overload resolution`` () = + commitEff { + let! _now = Clock.utcNow () + let! list = read () + Assert.Empty(list) + return () + } + |> run + + [] + let ``We can interleave effects in a commitEff with proper overload resolution`` () = commitEff { do! insert () let! _now = Clock.utcNow () @@ -154,43 +201,92 @@ type Scoped() = [] - let ``Connection tests 3`` () = - let insertWithError () = commitEff { + let ``A failed commitEff does not execute its commit`` () = + eff { + do! insertWithError () |> expectError "expected" + + let! list = readAndCommit () + + Assert.Empty list + return () + } + |> run + + + [] + let ``We can see the scoped results in commitEff`` () = + commitEff { do! insert () + let! list = read () let value = Assert.Single(list) Assert.Equal((1, "test"), value) - return! Error "expected" + return! Clock.utcNow () } + |> run - let read () = commitEff { return! read () } + [] + let ``A failed commitEff rolls back its scope`` () = - eff { - do! insertWithError () |> expectError "expected" + commitEff { + do! scopedInsert () let! list = read () - Assert.Empty list - return () + let value = Assert.Single(list) + Assert.Equal((1, "test"), value) + return! Error "Error" } + |> expectError "Error" + |> Effect.bind (readEmpty) |> run [] - let ``Connection tests 4`` () = + let ``Scope aware effects read with the surrounding scope`` () = commitEff { do! insert () + do! readSingle () + let! _now = Clock.utcNow () + return 1 + } + |> run + + [] + let ``Scope aware effects can fail the surrounding scope`` () = + commitEff { + do! insert () + do! readThenFail () + let! _now = Clock.utcNow () + return () + } + |> Effect.tryRecover (fun es -> + if es = "Something went wrong" then + Ok() + else + Error $"Got error %O{es} when expecting error Something went wrong") + |> Effect.bind readEmpty + |> run + [] + let ``Scope aware effects effect with the surrounding scope`` () = + commitEff { + let! list = read () + Assert.Empty(list) + do! scopedInsert () let! list = read () let value = Assert.Single(list) Assert.Equal((1, "test"), value) - return! Clock.utcNow () + return () } |> run + [] - let ``Connection tests 5`` () = + let ``Each commitEff should have their own transaction`` () = let insertAndRead () = commitEff { + let! list = read () + Assert.True(3 > list.Count) do! insert () let! list = read () return list.Count diff --git a/tests/Orsak.Tests/Tests.fs b/tests/Orsak.Tests/Tests.fs index 5bffd2a..bd69549 100644 --- a/tests/Orsak.Tests/Tests.fs +++ b/tests/Orsak.Tests/Tests.fs @@ -8,6 +8,10 @@ open System.Threading open System.Threading.Tasks open System.Threading.Channels open System +open FSharp.Control + +#nowarn "1204" +#nowarn "57" [] module Helpers = @@ -172,6 +176,49 @@ module BuilderTests = return i =! 15 } + [] + let ``Builder should support for with CancelableAsyncEnumerable`` () = + run + <| eff { + let chan = Channel.CreateBounded(5) + + for i in 1..5 do + chan.Writer.TryWrite i |> ignore + + chan.Writer.Complete() + + let mutable i = 0 + + for j in chan.Reader.ReadAllAsync().WithCancellation(CancellationToken.None) do + i <- i + j + + return i =! 15 + } + + [] + let ``Builder should support while with CancelableAsyncEnumerable`` () = + run + <| eff { + let chan = Channel.CreateBounded(5) + + for i in 1..5 do + chan.Writer.TryWrite i |> ignore + + chan.Writer.Complete() + + let mutable i = 0 + let enumerable = chan.Reader.ReadAllAsync().WithCancellation(CancellationToken.None) + use enumerable = enumerable.GetAsyncEnumerator() + let move () = vtask { return! enumerable.MoveNextAsync() } + + while (move ()) do + let j = enumerable.Current + i <- i + j + + return i =! 15 + } + + [] let ``Builder should support while with ValueTask`` () = eff { @@ -194,7 +241,6 @@ module BuilderTests = } |> run - [] let ``Builder should support and! in an asynchronous fashion`` () = eff { @@ -594,8 +640,10 @@ module BuilderTests = else return! Error "Expected error" } + task { let mutable counter = 0 + do! eff { @@ -608,6 +656,7 @@ module BuilderTests = } |> expectError "Expected error" |> run + Assert.Equal(2, counter) } @@ -621,11 +670,13 @@ module BuilderTests = return! Ok() } + task { let mutable counter = 0 + do! eff { - for j in [ 1..5] do + for j in [ 1..5 ] do do! inlineEffect j counter <- counter + 1 @@ -634,6 +685,7 @@ module BuilderTests = } |> expectError "Expected error" |> run + Assert.Equal(2, counter) }