Delay

fsprojects · Sep 28, 2018 · 5e538b2 · 5e538b2
1 parent 55ce218
commit 5e538b2
Show file tree

Hide file tree

Showing 7 changed files with 184 additions and 155 deletions.
diff --git a/FsHttp.Tests/FsHttp.Tests.fsproj b/FsHttp.Tests/FsHttp.Tests.fsproj
@@ -0,0 +1,23 @@
+<Project Sdk="Microsoft.NET.Sdk">
+
+  <PropertyGroup>
+    <TargetFramework>netcoreapp2.1</TargetFramework>
+
+    <IsPackable>false</IsPackable>
+  </PropertyGroup>
+
+  <ItemGroup>
+    <Compile Include="Tests.fs" />
+  </ItemGroup>
+
+  <ItemGroup>
+    <PackageReference Include="Microsoft.NET.Test.Sdk" Version="15.8.0" />
+    <PackageReference Include="MSTest.TestAdapter" Version="1.3.2" />
+    <PackageReference Include="MSTest.TestFramework" Version="1.3.2" />
+  </ItemGroup>
+
+  <ItemGroup>
+    <ProjectReference Include="..\FsHttp\FsHttp.fsproj" />
+  </ItemGroup>
+
+</Project>
diff --git a/FsHttp.Tests/Tests.fs b/FsHttp.Tests/Tests.fs
@@ -0,0 +1,55 @@
+
+module ``Tests for FsHttp``
+
+open System
+open Microsoft.VisualStudio.TestTools.UnitTesting
+
+open FsHttp
+
+[<TestMethod>]
+let ``Synchronous GET call is invoked immediately`` =
+    http {  GET @"https://reqres.in/api/users?page=2&delay=3"
+    }
+    |> toJson
+    //>>> async {
+    //    return 4
+    //}
+    //>> send
+
+
+
+// http {  GET @"http://www.google.com"
+//         AcceptLanguage "de-DE"
+// }
+// |> send
+
+
+// http {  POST @"https://reqres.in/api/users"
+//         CacheControl "no-cache"
+
+//         body
+//         json """
+//         {
+//             "name": "morpheus",
+//             "job": "leader"
+//         }
+//         """
+// } 
+// |> send
+
+// http {  GET "https://reqres.in/api/users"
+// }
+// |> send
+// |> toJson
+// |> test
+// >>= byExample IgnoreIndexes Subset
+//     """
+//     {
+//         "page": 1,
+//         "data": [
+//             { "id": 1 }
+//         ]
+//     }
+//     """
+// >>= expect *> fun json -> json?Data.AsArray() |> should haveLength 2
+// |> eval
diff --git a/FsHttp.sln b/FsHttp.sln
@@ -3,7 +3,9 @@ Microsoft Visual Studio Solution File, Format Version 12.00
 # Visual Studio 15
 VisualStudioVersion = 15.0.27703.2026
 MinimumVisualStudioVersion = 10.0.40219.1
-Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FsHttp", "FsHttp\FsHttp.fsproj", "{3DE85489-E133-470D-B153-8A61AD1D9301}"
+Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FsHttp", "FsHttp\FsHttp.fsproj", "{3DE85489-E133-470D-B153-8A61AD1D9301}"
+EndProject
+Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FsHttp.Tests", "FsHttp.Tests\FsHttp.Tests.fsproj", "{CD6F0C00-72D5-467B-9C18-04EAE6C5D9FB}"
 EndProject
 Global
 	GlobalSection(SolutionConfigurationPlatforms) = preSolution
@@ -15,6 +17,10 @@ Global
 		{3DE85489-E133-470D-B153-8A61AD1D9301}.Debug|Any CPU.Build.0 = Debug|Any CPU
 		{3DE85489-E133-470D-B153-8A61AD1D9301}.Release|Any CPU.ActiveCfg = Release|Any CPU
 		{3DE85489-E133-470D-B153-8A61AD1D9301}.Release|Any CPU.Build.0 = Release|Any CPU
+		{CD6F0C00-72D5-467B-9C18-04EAE6C5D9FB}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
+		{CD6F0C00-72D5-467B-9C18-04EAE6C5D9FB}.Debug|Any CPU.Build.0 = Debug|Any CPU
+		{CD6F0C00-72D5-467B-9C18-04EAE6C5D9FB}.Release|Any CPU.ActiveCfg = Release|Any CPU
+		{CD6F0C00-72D5-467B-9C18-04EAE6C5D9FB}.Release|Any CPU.Build.0 = Release|Any CPU
 	EndGlobalSection
 	GlobalSection(SolutionProperties) = preSolution
 		HideSolutionNode = FALSE

diff --git a/FsHttp/FsHttp.fs b/FsHttp/FsHttp.fs
@@ -36,76 +36,75 @@ module Helper =
             |> Seq.reduce (+)
         segments
 
+[<AutoOpen>]
+module Domain =
+
+    type Header = {
+        url: string;
+        method: HttpMethod;
+        headers: (string*string) list;
+    }
+
+    type Content = {
+        content: string;
+        contentType: string;
+        headers: (string*string) list;
+    } 
+
+    type StartingContext = StartingContext
+
+    type FinalContext = {
+        request: Header;
+        content: Content option;
+    } with
+        member this.invoke () =
+            let request = this.request
+            let requestMessage = new HttpRequestMessage(request.method, request.url)
+
+            requestMessage.Content <-
+                match this.content with
+                | Some c -> 
+                    let stringContent = new StringContent(c.content, System.Text.Encoding.UTF8, c.contentType)
+                    for name,value in c.headers do
+                        stringContent.Headers.TryAddWithoutValidation(name, value) |> ignore
+                    stringContent
+                | _ -> null
+
+            for name,value in request.headers do
+                requestMessage.Headers.TryAddWithoutValidation(name, value) |> ignore
+
+            // TODO: dispose        
+            let client = new HttpClient()
+            client.SendAsync(requestMessage)
+
+    type HeaderContext = { request: Header } with
+        static member header (this: HeaderContext, name: string, value: string) =
+            { this with request = { this.request with headers = this.request.headers @ [name,value] } }
+        static member finalize (this: HeaderContext) =
+            let finalContext = { request=this.request; content=None }
+            finalContext
+
+    type BodyContext = {
+        request: Header;
+        content: Content;
+    } with
+        static member header (this: BodyContext, name: string, value: string) =
+            { this with request = { this.request with headers = this.request.headers @ [name,value] } }
+        static member finalize (this: BodyContext) =
+            let finalContext:FinalContext = { request=this.request; content=Some this.content }
+            finalContext
+
+let inline private finalizeContext (context: ^t) =
+    (^t: (static member finalize: ^t -> FinalContext) (context))
+
+type HttpBuilder() =
+    member this.Bind(m, f) = f m
+    member this.Return(x) = x
+    member this.Yield(x) = StartingContext
+    member this.For(m, f) = this.Bind m f
 
-type Header = {
-    url: string;
-    method: HttpMethod;
-    headers: (string*string) list;
-}
-
-type Content = {
-    content: string;
-    contentType: string;
-    headers: (string*string) list;
-} 
-
-
-type StartingContext = StartingContext
-
-type FinalContext = {
-    request: Header;
-    content: Content option;
-}
-with
-    member this.invoke () =
-        let request = this.request
-        let requestMessage = new HttpRequestMessage(request.method, request.url)
-
-        requestMessage.Content <-
-            match this.content with
-            | Some c -> 
-                let stringContent = new StringContent(c.content, System.Text.Encoding.UTF8, c.contentType)
-                for name,value in c.headers do
-                    stringContent.Headers.TryAddWithoutValidation(name, value) |> ignore
-                stringContent
-            | _ -> null
-
-        for name,value in request.headers do
-            requestMessage.Headers.TryAddWithoutValidation(name, value) |> ignore
-
-        // TODO: dispose        
-        let client = new HttpClient()
-        client.SendAsync(requestMessage)
-
-type HeaderContext = { request: Header }
-with
-    static member header (this: HeaderContext, name: string, value: string) =
-        { this with request = { this.request with headers = this.request.headers @ [name,value] } }
-    static member finalize (this: HeaderContext) =
-        let finalContext = { request=this.request; content=None }
-        finalContext
-
-type BodyContext = {
-    request: Header;
-    content: Content;
-}
-with
-    static member header (this: BodyContext, name: string, value: string) =
-        { this with request = { this.request with headers = this.request.headers @ [name,value] } }
-    static member finalize (this: BodyContext) =
-        let finalContext:FinalContext = { request=this.request; content=Some this.content }
-        finalContext
-
-
-module Builder =
-
-    type HttpBuilder() =
-        member this.Bind(m, f) = f m
-        member this.Return(x) = x
-        member this.Yield(x) = StartingContext
-        member this.For(m, f) = this.Bind m f
-
-    // Request methods
+[<AutoOpen>]
+module RequestMethods =
     type HttpBuilder with
 
         [<CustomOperation("Request")>]
@@ -145,14 +144,16 @@ module Builder =
         // RFC 4918 (WebDAV) adds 7 methods
         // TODO
 
-    // Header + Body
+[<AutoOpen>]
+module HeaderAndBody =
     type HttpBuilder with
 
         [<CustomOperation("header")>]
         member inline this.Header(context: ^t, name, value) =
             (^t: (static member header: ^t * string * string -> ^t) (context,name,value))
 
-    // HTTP request headers
+[<AutoOpen>]
+module RequestHeaders =
     type HttpBuilder with
 
         /// Content-Types that are acceptable for the response
@@ -392,7 +393,8 @@ module Builder =
         member this.XHTTPMethodOverride (context: HeaderContext, httpMethod: string) =
             this.Header(context, "X-HTTP-Method-Override", httpMethod)
 
-    // Body
+[<AutoOpen>]
+module Body =
     type HttpBuilder with
 
         [<CustomOperation("body")>]
@@ -416,10 +418,6 @@ module Builder =
                 content = { content with content=json; contentType="application/json";  }
             }
 
-let http = Builder.HttpBuilder()
-
-
-
 [<AutoOpen>]
 module Transformation =
 
@@ -440,9 +438,7 @@ module Transformation =
         printHint: PrintHint
     }
 
-
-    let inline sendAsync (context: ^t) =
-        let finalContext = (^t: (static member finalize: ^t -> FinalContext) (context))
+    let sendAsync (finalContext: FinalContext) =
         async {
             let! response = finalContext.invoke() |> Async.AwaitTask
             return
@@ -456,7 +452,7 @@ module Transformation =
                     printHint = Header
                 }
         }
-    let inline send (context: ^t) = (sendAsync context) |> Async.RunSynchronously
+    let send (finalContext: FinalContext) = finalContext |> sendAsync |> Async.RunSynchronously
 
     let headerToString (r: Response) =
         let sb = StringBuilder()
@@ -498,6 +494,18 @@ module Transformation =
     let preview maxLength r = { r with printHint = Preview maxLength }
     let expand r = { r with printHint = Expand }
 
+type HttpBuilderSync() =
+    inherit HttpBuilder()
+    member inline this.Delay(f: unit -> 'a) =
+        f() |> finalizeContext |> send
+
+type HttpBuilderAsync() =
+    inherit HttpBuilder()
+    member inline this.Delay(f: unit -> 'a) =
+        f() |> finalizeContext |> sendAsync
+
+let http = HttpBuilderSync()
+let httpAsync = HttpBuilderAsync()
 
 // TODO:
 // Multipart

diff --git a/FsHttp/FsHttp.fsproj b/FsHttp/FsHttp.fsproj
@@ -29,7 +29,6 @@
       <PackagePath>lib/$(TargetFramework)</PackagePath>
     </None>
     <Compile Include="Testing.fs" />
-    <None Include="test.fsx" />
   </ItemGroup>
   <ItemGroup>
     <PackageReference Include="FSharp.Data" Version="2.4.6" />

diff --git a/FsHttp/Testing.fs b/FsHttp/Testing.fs
@@ -14,9 +14,18 @@ type TestResult<'a> =
     | Ok of 'a
     | Failed of 'a * message: string
 
+let bind m f =
+    match m with
+    | Ok x -> f x
+    | Failed (x,y) -> Failed (x,y)
+let (>>=) = bind
+
 let test x = Ok x
 
-let eval t =
+//let (>>>) (y: 'b) (x: Async<'a>) =
+//    y
+
+let run t =
     match t with
     | Ok x -> "Ok"
     | Failed (x,y) -> sprintf "Failed: %s" y
@@ -28,29 +37,10 @@ let expect f x =
     with
     | ex -> Failed (x,ex.Message)
 
-// let private assertExpectation (f: FsHttp.Response -> _) (r: FsHttp.Response) =
-//     try
-//         f r |> ignore
-//         Ok r
-//     with
-//     | ex -> Failed (r,ex.Message)
-// let testString (f: string -> 'a) =
-//     assertExpectation (FsHttp.contentAsString >> f)
-// let testJson (f: JsonValue -> 'a) =
-//     assertExpectation (toJson >> f)
-// let testJsonArray (f: JsonValue[] -> 'a) =
-//     assertExpectation (toJson >> (fun json -> json.AsArray()) >> f)
-
 type ArrayComparison = | UseIndex | IgnoreIndexes
 type StructuralComparison = | Subset | Exact
 
-let bind m f =
-    match m with
-    | Ok x -> f x
-    | Failed (x,y) -> Failed (x,y)
-let (>>=) = bind
-
-let compareJson (arrayComparison: ArrayComparison) (expectedJson: JsonValue) (resultJson: JsonValue) =
+let private compareJson (arrayComparison: ArrayComparison) (expectedJson: JsonValue) (resultJson: JsonValue) =
 
     let rec toPaths (currentPath: string) (jsonValue: JsonValue) : ((string*obj) list) =
         match jsonValue with