Add Suave server integration package

FSharp.Data.GraphQL.Integration.slnx

@@ -13,6 +13,7 @@
     <Project Path="src/FSharp.Data.GraphQL.Server.AspNetCore/FSharp.Data.GraphQL.Server.AspNetCore.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Server.Giraffe/FSharp.Data.GraphQL.Server.Giraffe.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Server.Oxpecker/FSharp.Data.GraphQL.Server.Oxpecker.fsproj" />
+    <Project Path="src/FSharp.Data.GraphQL.Server.Suave/FSharp.Data.GraphQL.Server.Suave.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Server/FSharp.Data.GraphQL.Server.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Shared/FSharp.Data.GraphQL.Shared.fsproj" />
   </Folder>

FSharp.Data.GraphQL.slnx

@@ -122,6 +122,7 @@
     <Project Path="src/FSharp.Data.GraphQL.Server.Middleware/FSharp.Data.GraphQL.Server.Middleware.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Server.Oxpecker/FSharp.Data.GraphQL.Server.Oxpecker.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Server.Relay/FSharp.Data.GraphQL.Server.Relay.fsproj" />
+    <Project Path="src/FSharp.Data.GraphQL.Server.Suave/FSharp.Data.GraphQL.Server.Suave.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Server/FSharp.Data.GraphQL.Server.fsproj" />
     <Project Path="src/FSharp.Data.GraphQL.Shared/FSharp.Data.GraphQL.Shared.fsproj" />
   </Folder>

Packages.props

@@ -26,6 +26,7 @@
     <PackageReference Update="Microsoft.NETCore.Platforms" Version="$(SystemVersion)" />
     <PackageReference Update="NuGet.CommandLine" Version="1.*" />
     <PackageReference Update="Oxpecker" Version="2.*" />
+    <PackageReference Update="Suave" Version="3.3.0" NoWarn="NU1608" />
     <PackageReference Update="System.CodeDom" Version="$(SystemVersion)" />
     <PackageReference Update="System.Collections.Immutable" Version="$(SystemVersion)" />
     <PackageReference Update="System.Diagnostics.DiagnosticSource" Version="$(SystemVersion)" />

build/Program.fs

@@ -362,6 +362,9 @@ Target.create "PackServerGiraffe" <| fun _ -> pack "Server.Giraffe"
 let [<Literal>] PackServerOxpecker = "PackServerOxpecker"
 Target.create "PackServerOxpecker" <| fun _ -> pack "Server.Oxpecker"
 
+let [<Literal>] PackServerSuave = "PackServerSuave"
+Target.create "PackServerSuave" <| fun _ -> pack "Server.Suave"
+
 let [<Literal>] PackClientTarget = "PackClient"
 Target.create PackClientTarget <| fun _ -> pack "Client"
 
@@ -386,6 +389,9 @@ Target.create "PushServerGiraffe" <| fun _ -> push "Server.Giraffe"
 let [<Literal>] PushServerOxpecker = "PushServerOxpecker"
 Target.create "PushServerOxpecker" <| fun _ -> push "Server.Oxpecker"
 
+let [<Literal>] PushServerSuave = "PushServerSuave"
+Target.create "PushServerSuave" <| fun _ -> push "Server.Suave"
+
 let [<Literal>] PushClientTarget = "PushClient"
 Target.create PushClientTarget <| fun _ -> push "Client"
 
@@ -430,6 +436,8 @@ PackSharedTarget
 ==> PushServerGiraffe
 ==> PackServerOxpecker
 ==> PushServerOxpecker
+==> PackServerSuave
+==> PushServerSuave
 ==> PackMiddlewareTarget
 ==> PushMiddlewareTarget
 ==> PackRelayTarget

src/FSharp.Data.GraphQL.Server.Suave/FSharp.Data.GraphQL.Server.Suave.fsproj

@@ -0,0 +1,25 @@
+<Project Sdk="Microsoft.NET.Sdk">
+
+  <PropertyGroup>
+    <TargetFrameworks>$(DotNetVersion)</TargetFrameworks>
+    <GenerateDocumentationFile>true</GenerateDocumentationFile>
+    <Deterministic>true</Deterministic>
+    <Description>FSharp implementation of Facebook GraphQL query language (Suave integration)</Description>
+  </PropertyGroup>
+
+  <ItemGroup>
+    <Compile Include="HttpHandlers.fs" />
+  </ItemGroup>
+
+  <ItemGroup>
+    <ProjectReference Condition="$(IsNuGet) == ''" Include="..\FSharp.Data.GraphQL.Shared\FSharp.Data.GraphQL.Shared.fsproj" />
+    <ProjectReference Condition="$(IsNuGet) == ''" Include="..\FSharp.Data.GraphQL.Server\FSharp.Data.GraphQL.Server.fsproj" />
+    <PackageReference Condition="$(IsNuGet) != ''" Include="FSharp.Data.GraphQL.Shared" VersionOverride="$(Version)" />
+    <PackageReference Condition="$(IsNuGet) != ''" Include="FSharp.Data.GraphQL.Server" VersionOverride="$(Version)" />
+  </ItemGroup>
+
+  <ItemGroup>
+    <PackageReference Include="Suave" NoWarn="NU1608" />
+  </ItemGroup>
+
+</Project>

src/FSharp.Data.GraphQL.Server.Suave/HttpHandlers.fs

@@ -0,0 +1,218 @@
+namespace FSharp.Data.GraphQL.Server.Suave
+
+open System
+open System.IO
+open System.Net.Mime
+open System.Text
+open System.Text.Json
+open System.Text.Json.Serialization
+
+open Suave
+open Suave.Filters
+open Suave.Http
+open Suave.Operators
+open Suave.RequestErrors
+open Suave.Successful
+open Suave.Writers
+
+open FSharp.Data.GraphQL
+open FSharp.Data.GraphQL.Server
+open FSharp.Data.GraphQL.Shared
+
+type private SuaveRequestExecutionContext (httpContext : HttpContext) =
+
+    interface IInputExecutionContext with
+
+        member _.GetFile key =
+            match httpContext.request.files |> Seq.tryFind (fun file -> file.fieldName = key) with
+            | Some file ->
+                use source = File.OpenRead file.tempFilePath
+                let stream = new MemoryStream ()
+                source.CopyTo stream
+                stream.Seek (0L, SeekOrigin.Begin) |> ignore
+
+                Ok {
+                    FileName = file.fileName
+                    Stream = stream
+                    ContentType = file.mimeType
+                }
+            | None -> Result.Error $"File with key '{key}' not found"
+
+module HttpHandlers =
+
+    let private jsonMimeType = "application/json; charset=utf-8"
+    let private problemJsonMimeType = "application/problem+json; charset=utf-8"
+    let private serializerOptions = Shared.Json.getSerializerOptions Seq.empty
+
+    let private toResponse { DocumentId = documentId; Content = content } =
+        match content with
+        | Direct (data, errs) -> GQLResponse.Direct (documentId, data, errs)
+        | Deferred (data, errs, _) -> GQLResponse.Direct (documentId, data, errs)
+        | Stream _ -> GQLResponse.Stream documentId
+        | RequestError errs -> GQLResponse.RequestError (documentId, errs)
+
+    let private okJson (payload : string) =
+        setMimeType jsonMimeType
+        >=> ok (Encoding.UTF8.GetBytes payload)
+
+    let private badRequestJson (payload : string) =
+        setMimeType problemJsonMimeType
+        >=> bad_request (Encoding.UTF8.GetBytes payload)
+
+    let private problemDetails title detail instance =
+        JsonSerializer.Serialize (
+            {| title = title
+               detail = detail
+               status = 400
+               instance = instance |},
+            serializerOptions
+        )
+
+    let private isMultipartRequest (request : HttpRequest) =
+        request.headers
+        |> Seq.exists (fun (key, value) ->
+            String.Equals (key, "Content-Type", StringComparison.OrdinalIgnoreCase)
+            && value.Contains (MediaTypeNames.Multipart.FormData, StringComparison.OrdinalIgnoreCase)
+        )
+
+    let private tryGetMultipartField name (request : HttpRequest) =
+        request.multiPartFields
+        |> Seq.tryPick (fun (fieldName, value) ->
+            if String.Equals (fieldName, name, StringComparison.Ordinal) then
+                Some value
+            else
+                None
+        )
+
+    let private requestBody (request : HttpRequest) =
+        if isMultipartRequest request then
+            tryGetMultipartField "operations" request
+            |> Option.defaultValue ""
+        else
+            request.rawForm
+            |> Encoding.UTF8.GetString
+
+    let private operationNameAsValueOption (operationName : string Skippable) =
+        match operationName with
+        | Include value when not (isNull value) -> ValueSome value
+        | _ -> ValueNone
+
+    let private operationNameAsOption (operationName : string Skippable) =
+        match operationName with
+        | Include value when not (isNull value) -> Some value
+        | _ -> None
+
+    let private variablesAsOption (variables : _ Skippable) =
+        match variables with
+        | Include value when not (isNull value) -> Some value
+        | _ -> None
+
+    let private executeIntrospectionQuery (executor : Executor<'Root>) (optionalAstDocument : Ast.Document voption) = task {
+        let inputContext () : IInputExecutionContext =
+            SuaveRequestExecutionContext (HttpContext.empty) :> IInputExecutionContext
+
+        let! result =
+            match optionalAstDocument with
+            | ValueSome ast -> executor.AsyncExecute (ast, inputContext) |> Async.StartAsTask
+            | ValueNone -> executor.AsyncExecute (IntrospectionQuery.Definition, inputContext) |> Async.StartAsTask
+
+        let payload = result |> toResponse |> fun response -> JsonSerializer.Serialize (response, serializerOptions)
+        return okJson payload
+    }
+
+    let private executeOperation
+        (executor : Executor<'Root>)
+        (rootFactory : HttpContext -> 'Root)
+        (httpContext : HttpContext)
+        (content : ParsedGQLQueryRequestContent)
+        =
+        task {
+            let root = rootFactory httpContext
+
+            let inputContext () : IInputExecutionContext =
+                SuaveRequestExecutionContext (httpContext) :> IInputExecutionContext
+
+            let operationName = operationNameAsOption content.OperationName
+            let variables = variablesAsOption content.Variables
+
+            let! result =
+                executor.AsyncExecute (content.Ast, inputContext, root, ?variables = variables, ?operationName = operationName)
+                |> Async.StartAsTask
+
+            let payload = result |> toResponse |> fun response -> JsonSerializer.Serialize (response, serializerOptions)
+            return okJson payload
+        }
+
+    let private checkOperationType (httpContext : HttpContext) =
+        let request = httpContext.request
+
+        if request.method = HttpMethod.GET then
+            Result.Ok (OperationType.IntrospectionQuery ValueNone)
+        else
+            let body = requestBody request
+
+            if String.IsNullOrWhiteSpace body then
+                Result.Ok (OperationType.IntrospectionQuery ValueNone)
+            else
+                try
+                    let gqlRequest = JsonSerializer.Deserialize<GQLRequestContent> (body, serializerOptions)
+                    let ast = gqlRequest.Query |> Parser.tryParse |> Result.mapError (fun message -> problemDetails "Cannot parse GraphQL query" message request.path)
+
+                    ast
+                    |> Result.map (fun ast ->
+                        let parsedContent () = {
+                            Query = gqlRequest.Query
+                            Ast = ast
+                            OperationName = gqlRequest.OperationName
+                            Variables = gqlRequest.Variables
+                        }
+
+                        if ast.IsEmpty then
+                            OperationType.IntrospectionQuery ValueNone
+                        else
+                            match Ast.tryFindOperationByName (operationNameAsValueOption gqlRequest.OperationName) ast with
+                            | None -> OperationType.IntrospectionQuery ValueNone
+                            | Some _ -> parsedContent () |> OperationType.OperationQuery
+                    )
+                with :? JsonException ->
+                    Result.Error (
+                        problemDetails
+                            "Invalid JSON body"
+                            $"Expected JSON similar to value in 'expected', but received value as in 'received': {body}"
+                            request.path
+                    )
+
+    let private handleGraphQL<'Root> (executor : Executor<'Root>) (rootFactory : HttpContext -> 'Root) (httpContext : HttpContext) =
+        async {
+            let! webPart =
+                task {
+                    match checkOperationType httpContext with
+                    | Result.Error payload -> return badRequestJson payload
+                    | Result.Ok (OperationType.IntrospectionQuery optionalAstDocument) -> return! executeIntrospectionQuery executor optionalAstDocument
+                    | Result.Ok (OperationType.OperationQuery content) -> return! executeOperation executor rootFactory httpContext content
+                }
+                |> Async.AwaitTask
+
+            return! webPart httpContext
+        }
+
+    /// <summary>
+    /// Sets the <c>Request-Type</c> response header to <c>Multipart</c> for multipart form requests and <c>Classic</c> otherwise.
+    /// </summary>
+    let setRequestType : WebPart =
+        fun httpContext ->
+            let requestType =
+                if isMultipartRequest httpContext.request then
+                    "Multipart"
+                else
+                    "Classic"
+
+            setHeader "Request-Type" requestType httpContext
+
+    /// <summary>
+    /// Creates a Suave WebPart that handles GraphQL GET and POST requests.
+    /// </summary>
+    /// <param name="executor">The GraphQL executor.</param>
+    /// <param name="rootFactory">Creates the GraphQL root object from the current Suave HTTP context.</param>
+    let graphQL<'Root> (executor : Executor<'Root>) (rootFactory : HttpContext -> 'Root) : WebPart =
+        choose [ Filters.GET; Filters.POST ] >=> handleGraphQL executor rootFactory

tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj

@@ -76,6 +76,7 @@
     <Compile Include="AspNetCore/TestSchema.fs" />
     <Compile Include="AspNetCore/InvalidMessageTests.fs" />
     <Compile Include="AspNetCore/SerializationTests.fs" />
+    <Compile Include="Suave/HttpHandlersTests.fs" />
     <Compile Include="Program.fs" />
   </ItemGroup>
 
@@ -89,5 +90,6 @@
     <ProjectReference Include="..\..\src\FSharp.Data.GraphQL.Server\FSharp.Data.GraphQL.Server.fsproj" />
     <ProjectReference Include="..\..\src\FSharp.Data.GraphQL.Server.AspNetCore\FSharp.Data.GraphQL.Server.AspNetCore.fsproj" />
     <ProjectReference Include="..\..\src\FSharp.Data.GraphQL.Server.Middleware\FSharp.Data.GraphQL.Server.Middleware.fsproj" />
+    <ProjectReference Include="..\..\src\FSharp.Data.GraphQL.Server.Suave\FSharp.Data.GraphQL.Server.Suave.fsproj" />
   </ItemGroup>
 </Project>