diff --git a/FSharp.Data.GraphQL.Integration.slnx b/FSharp.Data.GraphQL.Integration.slnx index ebd07776..56004703 100644 --- a/FSharp.Data.GraphQL.Integration.slnx +++ b/FSharp.Data.GraphQL.Integration.slnx @@ -13,6 +13,7 @@ + diff --git a/FSharp.Data.GraphQL.slnx b/FSharp.Data.GraphQL.slnx index 6f729a6b..dacee218 100644 --- a/FSharp.Data.GraphQL.slnx +++ b/FSharp.Data.GraphQL.slnx @@ -122,6 +122,7 @@ + diff --git a/Packages.props b/Packages.props index 7d3b9582..56f18495 100644 --- a/Packages.props +++ b/Packages.props @@ -26,6 +26,7 @@ + diff --git a/build/Program.fs b/build/Program.fs index 22bbb133..49780e83 100644 --- a/build/Program.fs +++ b/build/Program.fs @@ -362,6 +362,9 @@ Target.create "PackServerGiraffe" <| fun _ -> pack "Server.Giraffe" let [] PackServerOxpecker = "PackServerOxpecker" Target.create "PackServerOxpecker" <| fun _ -> pack "Server.Oxpecker" +let [] PackServerSuave = "PackServerSuave" +Target.create "PackServerSuave" <| fun _ -> pack "Server.Suave" + let [] PackClientTarget = "PackClient" Target.create PackClientTarget <| fun _ -> pack "Client" @@ -386,6 +389,9 @@ Target.create "PushServerGiraffe" <| fun _ -> push "Server.Giraffe" let [] PushServerOxpecker = "PushServerOxpecker" Target.create "PushServerOxpecker" <| fun _ -> push "Server.Oxpecker" +let [] PushServerSuave = "PushServerSuave" +Target.create "PushServerSuave" <| fun _ -> push "Server.Suave" + let [] PushClientTarget = "PushClient" Target.create PushClientTarget <| fun _ -> push "Client" @@ -430,6 +436,8 @@ PackSharedTarget ==> PushServerGiraffe ==> PackServerOxpecker ==> PushServerOxpecker +==> PackServerSuave +==> PushServerSuave ==> PackMiddlewareTarget ==> PushMiddlewareTarget ==> PackRelayTarget diff --git a/src/FSharp.Data.GraphQL.Server.Suave/FSharp.Data.GraphQL.Server.Suave.fsproj b/src/FSharp.Data.GraphQL.Server.Suave/FSharp.Data.GraphQL.Server.Suave.fsproj new file mode 100644 index 00000000..f78a75a7 --- /dev/null +++ b/src/FSharp.Data.GraphQL.Server.Suave/FSharp.Data.GraphQL.Server.Suave.fsproj @@ -0,0 +1,25 @@ + + + + $(DotNetVersion) + true + true + FSharp implementation of Facebook GraphQL query language (Suave integration) + + + + + + + + + + + + + + + + + + diff --git a/src/FSharp.Data.GraphQL.Server.Suave/HttpHandlers.fs b/src/FSharp.Data.GraphQL.Server.Suave/HttpHandlers.fs new file mode 100644 index 00000000..69c7d7ca --- /dev/null +++ b/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 (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 + } + + /// + /// Sets the Request-Type response header to Multipart for multipart form requests and Classic otherwise. + /// + let setRequestType : WebPart = + fun httpContext -> + let requestType = + if isMultipartRequest httpContext.request then + "Multipart" + else + "Classic" + + setHeader "Request-Type" requestType httpContext + + /// + /// Creates a Suave WebPart that handles GraphQL GET and POST requests. + /// + /// The GraphQL executor. + /// Creates the GraphQL root object from the current Suave HTTP context. + let graphQL<'Root> (executor : Executor<'Root>) (rootFactory : HttpContext -> 'Root) : WebPart = + choose [ Filters.GET; Filters.POST ] >=> handleGraphQL executor rootFactory diff --git a/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj b/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj index 763d841e..387b86d5 100644 --- a/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj +++ b/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj @@ -76,6 +76,7 @@ + @@ -89,5 +90,6 @@ + diff --git a/tests/FSharp.Data.GraphQL.Tests/Suave/HttpHandlersTests.fs b/tests/FSharp.Data.GraphQL.Tests/Suave/HttpHandlersTests.fs new file mode 100644 index 00000000..fca41df8 --- /dev/null +++ b/tests/FSharp.Data.GraphQL.Tests/Suave/HttpHandlersTests.fs @@ -0,0 +1,181 @@ +module FSharp.Data.GraphQL.Tests.Suave.HttpHandlersTests + +open System +open System.Collections.Generic +open System.IO +open System.Text +open System.Text.Json +open Xunit + +open Suave +open Suave.Http +open Suave.Operators + +open FSharp.Data.GraphQL +open FSharp.Data.GraphQL.Types +open FSharp.Data.GraphQL.Server.Suave + +type Root = { Path : string } + +type UploadPayload = { File : FileData } + +let private query = + Define.Object ( + name = "Query", + fields = [ + Define.Field ("path", StringType, resolve = fun _ root -> root.Path) + ] + ) + +let private uploadResult = + Define.Object ( + name = "UploadResult", + fields = [ + Define.Field ("name", StringType, resolve = fun _ file -> file.FileName) + Define.Field ( + "content", + StringType, + resolve = + fun _ file -> + file.Stream.Seek (0L, SeekOrigin.Begin) |> ignore + use reader = new StreamReader (file.Stream, Encoding.UTF8, leaveOpen = true) + reader.ReadToEnd () + ) + ] + ) + +let private mutation = + Define.Object ( + name = "Mutation", + fields = [ + Define.Field ( + "upload", + uploadResult, + args = [ Define.Input ("file", FileType) ], + resolve = fun ctx _ -> ctx.Arg "file" + ) + ] + ) + +let private executor = Executor (Schema (query, mutation)) + +let private rootFactory (httpContext : HttpContext) = { Path = httpContext.request.path } + +let private createRequest + (methodName : string) + (path : string) + (body : byte array) + (headers : (string * string) list) + (files : Runtime.HttpUpload list) + (multiPartFields : (string * string) list) + = + { HttpRequest.empty with + rawMethod = methodName + rawPath = path + headers = List (headers :> seq<_>) + rawForm = body + files = List (files :> seq<_>) + multiPartFields = List (multiPartFields :> seq<_>) } + +let private run webPart httpContext = + match webPart httpContext |> Async.RunSynchronously with + | Some handled -> handled + | None -> failwith "Expected the WebPart to handle the request" + +let private responseHeader name (httpContext : HttpContext) = + httpContext.response.headers + |> Seq.tryPick (fun (key, value) -> + if String.Equals (key, name, StringComparison.OrdinalIgnoreCase) then + Some value + else + None + ) + +let private responseJson httpContext = + match httpContext.response.content with + | HttpContent.Bytes bytes -> JsonDocument.Parse bytes + | content -> failwith $"Expected response bytes but received %A{content}" + +[] +let ``Suave GraphQL handler executes JSON requests`` () = + let body = """{"query":"query { path }"}""" |> Encoding.UTF8.GetBytes + let request = + createRequest + "POST" + "/graphql" + body + [ "Content-Type", "application/json" ] + [] + [] + + let httpContext = { HttpContext.empty with request = request } + + let handled = + HttpHandlers.setRequestType + >=> HttpHandlers.graphQL executor rootFactory + |> fun webPart -> run webPart httpContext + + Assert.Equal (Some "Classic", responseHeader "Request-Type" handled) + + use document = responseJson handled + let value = document.RootElement.GetProperty("data").GetProperty("path").GetString() + Assert.Equal ("/graphql", value) + +[] +let ``Suave GraphQL handler executes GET introspection requests`` () = + let request = createRequest "GET" "/graphql" Array.empty [ "Accept", "application/json" ] [] [] + let httpContext = { HttpContext.empty with request = request } + + let handled = HttpHandlers.graphQL executor rootFactory |> fun webPart -> run webPart httpContext + + use document = responseJson handled + let schema = document.RootElement.GetProperty("data").GetProperty("__schema") + Assert.Equal (JsonValueKind.Object, schema.ValueKind) + +[] +let ``Suave GraphQL handler executes multipart upload requests`` () = + let tempFilePath = Path.GetTempFileName () + + try + File.WriteAllText (tempFilePath, "uploaded from suave") + + let upload : Runtime.HttpUpload = { + fieldName = "file0" + fileName = "hello.txt" + mimeType = "text/plain" + tempFilePath = tempFilePath + } + + let operations = + """{ + "query": "mutation ($file: File!) { upload(file: $file) { name content } }", + "variables": { + "file": "file0" + } + }""" + + let request = + createRequest + "POST" + "/graphql" + Array.empty + [ "Content-Type", "multipart/form-data; boundary=graphql" ] + [ upload ] + [ "operations", operations ] + + let httpContext = { HttpContext.empty with request = request } + + let handled = + HttpHandlers.setRequestType + >=> HttpHandlers.graphQL executor rootFactory + |> fun webPart -> run webPart httpContext + + Assert.Equal (Some "Multipart", responseHeader "Request-Type" handled) + + use document = responseJson handled + let uploadResponse = document.RootElement.GetProperty("data").GetProperty("upload") + Assert.Equal ("hello.txt", uploadResponse.GetProperty("name").GetString()) + Assert.Equal ("uploaded from suave", uploadResponse.GetProperty("content").GetString()) + finally + if File.Exists tempFilePath then + File.Delete tempFilePath