From 0cd5e07af2a5caa5d5e3b3e56b833c8829932757 Mon Sep 17 00:00:00 2001 From: Thibaut Mattio Date: Wed, 8 Apr 2020 23:19:17 -0400 Subject: [PATCH 1/2] Generalize graphql-cohttp to support other backends --- README.md | 2 +- examples/{ => cohttp}/dune | 0 examples/{ => cohttp}/server.ml | 0 examples/opium/dune | 7 ++ examples/opium/graphql_opium.ml | 49 ++++++++ examples/opium/schema.ml | 43 +++++++ examples/opium/server.ml | 9 ++ graphql.opam | 1 + graphql/src/dune | 2 +- graphql/src/graphql.ml | 2 + graphql/src/graphql.mli | 2 + graphql/src/graphql_server.ml | 199 ++++++++++++++++++++++++++++++++ graphql/src/graphql_server.mli | 73 ++++++++++++ 13 files changed, 387 insertions(+), 2 deletions(-) rename examples/{ => cohttp}/dune (100%) rename examples/{ => cohttp}/server.ml (100%) create mode 100644 examples/opium/dune create mode 100644 examples/opium/graphql_opium.ml create mode 100644 examples/opium/schema.ml create mode 100644 examples/opium/server.ml create mode 100644 graphql/src/graphql_server.ml create mode 100644 graphql/src/graphql_server.mli diff --git a/README.md b/README.md index 2af5c07..6f6b974 100644 --- a/README.md +++ b/README.md @@ -45,7 +45,7 @@ To run a sample GraphQL server also serving GraphiQL, do the following: ```bash opam install dune graphql-lwt graphql-cohttp cohttp-lwt-unix git clone git@github.com:andreas/ocaml-graphql-server.git -dune exec examples/server.exe +dune exec examples/cohttp/server.exe ``` Now open [http://localhost:8080/graphql](http://localhost:8080/graphql). diff --git a/examples/dune b/examples/cohttp/dune similarity index 100% rename from examples/dune rename to examples/cohttp/dune diff --git a/examples/server.ml b/examples/cohttp/server.ml similarity index 100% rename from examples/server.ml rename to examples/cohttp/server.ml diff --git a/examples/opium/dune b/examples/opium/dune new file mode 100644 index 0000000..957a9d8 --- /dev/null +++ b/examples/opium/dune @@ -0,0 +1,7 @@ +(executable + (name server) + (libraries digestif.c cohttp-lwt-unix graphql-lwt opium yojson)) + +(alias + (name DEFAULT) + (deps server.exe)) diff --git a/examples/opium/graphql_opium.ml b/examples/opium/graphql_opium.ml new file mode 100644 index 0000000..9c6caca --- /dev/null +++ b/examples/opium/graphql_opium.ml @@ -0,0 +1,49 @@ +module Io = struct + type 'a t = 'a Lwt.t + + let ( >>= ) = Lwt.bind + + let return = Lwt.return + + type ic = Lwt_io.input_channel + + type oc = Lwt_io.output_channel +end + +module Body = Opium_kernel.Body + +module Request = struct + type t = Opium_kernel.Rock.Request.t + + let uri (req : t) = Uri.of_string req.target + + let header ~header (req : t) = + let headers = req.headers in + Httpaf.Headers.get headers header + + let method_ (req : t) = + match req.meth with `GET as m -> m | `POST as m -> m | _ -> `OTHER +end + +module Response = struct + type t = Opium_kernel.Rock.Response.t + + let make_ok ~body () = + Opium_kernel.Rock.Response.make ~status:`OK + ~body:(Opium_kernel.Body.of_string body) + () + + let make_bad_request ~body () = + Opium_kernel.Rock.Response.make ~status:`Bad_request + ~body:(Opium_kernel.Body.of_string body) + () + + let make_not_found ~body () = + Opium_kernel.Rock.Response.make ~status:`Not_found + ~body:(Opium_kernel.Body.of_string body) + () +end + +module Graphql_opium = + Graphql_server.Make (Graphql_lwt.Schema) (Io) (Request) (Response) (Body) +include Graphql_opium diff --git a/examples/opium/schema.ml b/examples/opium/schema.ml new file mode 100644 index 0000000..8b85e13 --- /dev/null +++ b/examples/opium/schema.ml @@ -0,0 +1,43 @@ +open Graphql_lwt + +type context = unit + +type role = User | Admin + +type user = { id : int; name : string; role : role } + +let users = + [ + { id = 1; name = "Alice"; role = Admin }; + { id = 2; name = "Bob"; role = User }; + ] + +let role : (context, role option) Graphql_lwt.Schema.typ = + Schema.( + enum "role" ~doc:"The role of a user" + ~values:[ enum_value "USER" ~value:User; enum_value "ADMIN" ~value:Admin ]) + +let user : (context, user option) Graphql_lwt.Schema.typ = + Schema.( + obj "user" ~doc:"A user in the system" ~fields:(fun _ -> + [ + field "id" ~doc:"Unique user identifier" ~typ:(non_null int) + ~args:Arg.[] + ~resolve:(fun _info p -> p.id); + field "name" ~typ:(non_null string) + ~args:Arg.[] + ~resolve:(fun _info p -> p.name); + field "role" ~typ:(non_null role) + ~args:Arg.[] + ~resolve:(fun _info p -> p.role); + ])) + +let schema = + Schema.( + schema + [ + field "users" + ~typ:(non_null (list (non_null user))) + ~args:Arg.[] + ~resolve:(fun _info () -> users); + ]) diff --git a/examples/opium/server.ml b/examples/opium/server.ml new file mode 100644 index 0000000..0db6b14 --- /dev/null +++ b/examples/opium/server.ml @@ -0,0 +1,9 @@ +open Opium.Std + +let graphql = + get "/" (fun req -> + let schema = Schema.schema in + let callback = Graphql_opium.make_callback (fun _req -> ()) schema in + callback req req.body) + +let _ = App.empty |> graphql |> App.run_command diff --git a/graphql.opam b/graphql.opam index 0130d63..f52e1a9 100644 --- a/graphql.opam +++ b/graphql.opam @@ -18,6 +18,7 @@ depends: [ "yojson" "rresult" "seq" + "uri" "alcotest" {with-test} ] diff --git a/graphql/src/dune b/graphql/src/dune index 6f8d690..f692512 100644 --- a/graphql/src/dune +++ b/graphql/src/dune @@ -2,6 +2,6 @@ (name graphql) (public_name graphql) (wrapped false) - (libraries graphql_parser yojson rresult seq) + (libraries graphql_parser yojson rresult uri seq) (flags (:standard -w -30))) diff --git a/graphql/src/graphql.ml b/graphql/src/graphql.ml index 1df00e7..c03525c 100644 --- a/graphql/src/graphql.ml +++ b/graphql/src/graphql.ml @@ -24,3 +24,5 @@ module Schema = let extensions_of_field_error _t = None end) + +module Server = Graphql_server diff --git a/graphql/src/graphql.mli b/graphql/src/graphql.mli index be2e9c2..c82f956 100644 --- a/graphql/src/graphql.mli +++ b/graphql/src/graphql.mli @@ -6,3 +6,5 @@ module Schema : sig and type 'a Io.Stream.t = 'a Seq.t and type field_error = string end + +module Server = Graphql_server diff --git a/graphql/src/graphql_server.ml b/graphql/src/graphql_server.ml new file mode 100644 index 0000000..e739178 --- /dev/null +++ b/graphql/src/graphql_server.ml @@ -0,0 +1,199 @@ +module type Io = sig + type 'a t + + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t + + val return : 'a -> 'a t + + type ic + + type oc +end + +module type HttpBody = sig + type t + + type +'a io + + val to_string : t -> string io + + val of_string : string -> t +end + +module type HttpRequest = sig + type t + + val uri : t -> Uri.t + + val header : header:string -> t -> string option + + val method_ : t -> [ `GET | `POST | `OTHER ] +end + +module type HttpResponse = sig + type t + + val make_ok : body:string -> unit -> t + + val make_bad_request : body:string -> unit -> t + + val make_not_found : body:string -> unit -> t +end + +module type S = sig + module Io : Io + + type body + + type request + + type response + + type 'ctx schema + + type callback + + val execute_request : 'ctx schema -> 'ctx -> callback + + val make_callback : (request -> 'ctx) -> 'ctx schema -> callback +end + +module Option = struct + let bind t ~f = match t with None -> None | Some x -> f x + + let map t ~f = bind t ~f:(fun x -> Some (f x)) + + let first_some t t' = match t with None -> t' | Some _ -> t +end + +module Params (Request : HttpRequest) = struct + type t = + { query : string option + ; variables : (string * Yojson.Basic.t) list option + ; operation_name : string option + } + + let empty = { query = None; variables = None; operation_name = None } + + let of_uri_exn uri = + let variables = + Uri.get_query_param uri "variables" + |> Option.map ~f:Yojson.Basic.from_string + |> Option.map ~f:Yojson.Basic.Util.to_assoc + in + { query = Uri.get_query_param uri "query" + ; variables + ; operation_name = Uri.get_query_param uri "operationName" + } + + let of_json_body_exn body = + if body = "" then + empty + else + let json = Yojson.Basic.from_string body in + { query = + Yojson.Basic.Util.(json |> member "query" |> to_option to_string) + ; variables = + Yojson.Basic.Util.(json |> member "variables" |> to_option to_assoc) + ; operation_name = + Yojson.Basic.Util.( + json |> member "operationName" |> to_option to_string) + } + + let of_graphql_body body = + { query = Some body; variables = None; operation_name = None } + + let merge t t' = + { query = Option.first_some t.query t'.query + ; variables = Option.first_some t.variables t'.variables + ; operation_name = Option.first_some t.operation_name t'.operation_name + } + + let post_params_exn req body = + let header = Request.header req ~header:"Content-Type" in + match header with + | Some "application/graphql" -> + of_graphql_body body + | Some "application/json" -> + of_json_body_exn body + | _ -> + empty + + let of_req_exn req body = + let uri = Request.uri req in + let get_params = of_uri_exn uri in + let post_params = post_params_exn req body in + merge get_params post_params + + let extract req body = + try + let params = of_req_exn req body in + match params.query with + | Some query -> + Ok + ( query + , (params.variables + :> (string * Graphql_parser.const_value) list option) + , params.operation_name ) + | None -> + Error "Must provide query string" + with + | Yojson.Json_error msg -> + Error msg +end + +module Make + (Schema : Graphql_intf.Schema) + (Io : Io with type 'a t = 'a Schema.Io.t) + (Request : HttpRequest) + (Response : HttpResponse) + (Body : HttpBody with type +'a io := 'a Schema.Io.t) = +struct + module Params = Params (Request) + + let ( >>= ) = Io.( >>= ) + + let execute_query ctx schema variables operation_name query = + match Graphql_parser.parse query with + | Ok doc -> + Schema.execute schema ctx ?variables ?operation_name doc + | Error e -> + Schema.Io.return (Error (`String e)) + + let execute_request schema ctx req body = + Body.to_string body >>= fun body_string -> + match Params.extract req body_string with + | Error err -> + Io.return @@ Response.make_bad_request ~body:err () + | Ok (query, variables, operation_name) -> + execute_query ctx schema variables operation_name query >>= ( function + | Ok (`Response data) -> + let body = Yojson.Basic.to_string data in + Io.return @@ Response.make_ok ~body () + | Ok (`Stream stream) -> + Schema.Io.Stream.close stream; + let body = "Subscriptions are only supported via websocket transport" in + Io.return @@ Response.make_bad_request ~body () + | Error err -> + let body = Yojson.Basic.to_string err in + Io.return @@ Response.make_bad_request ~body () ) + + let make_callback make_context schema req body = + let method_ = Request.method_ req in + match method_ with + | `GET -> + if + Request.header req ~header:"Connection" = Some "Upgrade" + && Request.header req ~header:"Upgrade" = Some "websocket" + then + (* let handle_conn = Websocket_transport.handle (execute_query + (make_context req) schema) in Io.return (Ws.upgrade_connection req + handle_conn) *) + assert false + else + execute_request schema (make_context req) req body + | `POST -> + execute_request schema (make_context req) req body + | _ -> + Io.return @@ Response.make_not_found ~body:"Not found" () +end diff --git a/graphql/src/graphql_server.mli b/graphql/src/graphql_server.mli new file mode 100644 index 0000000..b789564 --- /dev/null +++ b/graphql/src/graphql_server.mli @@ -0,0 +1,73 @@ +module type Io = sig + type 'a t + + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t + + val return : 'a -> 'a t + + type ic + + type oc +end + +module type HttpBody = sig + type t + + type +'a io + + val to_string : t -> string io + + val of_string : string -> t +end + +module type HttpRequest = sig + type t + + val uri : t -> Uri.t + + val header : header:string -> t -> string option + + val method_ : t -> [ `GET | `POST | `OTHER ] +end + +module type HttpResponse = sig + type t + + val make_ok : body:string -> unit -> t + + val make_bad_request : body:string -> unit -> t + + val make_not_found : body:string -> unit -> t +end + +module type S = sig + module Io : Io + + type body + + type request + + type response + + type 'ctx schema + + type callback + + val execute_request : 'ctx schema -> 'ctx -> callback + + val make_callback : (request -> 'ctx) -> 'ctx schema -> callback +end + +module Make + (Schema : Graphql_intf.Schema) + (Io : Io with type 'a t = 'a Schema.Io.t) + (Request : HttpRequest) + (Response : HttpResponse) + (Body : HttpBody with type +'a io := 'a Schema.Io.t) : + S + with type 'ctx schema := 'ctx Schema.schema + and module Io := Io + and type body := Body.t + and type request := Request.t + and type response := Response.t + and type callback := Request.t -> Body.t -> Response.t Io.t From a4c1d5e2d204717d33d316c28ab934c3cff461fe Mon Sep 17 00:00:00 2001 From: Thibaut Mattio Date: Wed, 8 Apr 2020 23:41:02 -0400 Subject: [PATCH 2/2] Remove unused types --- examples/opium/graphql_opium.ml | 4 - graphql/src/graphql_server.ml | 130 +++++++++++++++----------------- graphql/src/graphql_server.mli | 4 - 3 files changed, 59 insertions(+), 79 deletions(-) diff --git a/examples/opium/graphql_opium.ml b/examples/opium/graphql_opium.ml index 9c6caca..9488042 100644 --- a/examples/opium/graphql_opium.ml +++ b/examples/opium/graphql_opium.ml @@ -4,10 +4,6 @@ module Io = struct let ( >>= ) = Lwt.bind let return = Lwt.return - - type ic = Lwt_io.input_channel - - type oc = Lwt_io.output_channel end module Body = Opium_kernel.Body diff --git a/graphql/src/graphql_server.ml b/graphql/src/graphql_server.ml index e739178..0baa6d0 100644 --- a/graphql/src/graphql_server.ml +++ b/graphql/src/graphql_server.ml @@ -4,10 +4,6 @@ module type Io = sig val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t val return : 'a -> 'a t - - type ic - - type oc end module type HttpBody = sig @@ -67,11 +63,11 @@ module Option = struct end module Params (Request : HttpRequest) = struct - type t = - { query : string option - ; variables : (string * Yojson.Basic.t) list option - ; operation_name : string option - } + type t = { + query : string option; + variables : (string * Yojson.Basic.t) list option; + operation_name : string option; + } let empty = { query = None; variables = None; operation_name = None } @@ -81,43 +77,42 @@ module Params (Request : HttpRequest) = struct |> Option.map ~f:Yojson.Basic.from_string |> Option.map ~f:Yojson.Basic.Util.to_assoc in - { query = Uri.get_query_param uri "query" - ; variables - ; operation_name = Uri.get_query_param uri "operationName" + { + query = Uri.get_query_param uri "query"; + variables; + operation_name = Uri.get_query_param uri "operationName"; } let of_json_body_exn body = - if body = "" then - empty + if body = "" then empty else let json = Yojson.Basic.from_string body in - { query = - Yojson.Basic.Util.(json |> member "query" |> to_option to_string) - ; variables = - Yojson.Basic.Util.(json |> member "variables" |> to_option to_assoc) - ; operation_name = + { + query = + Yojson.Basic.Util.(json |> member "query" |> to_option to_string); + variables = + Yojson.Basic.Util.(json |> member "variables" |> to_option to_assoc); + operation_name = Yojson.Basic.Util.( - json |> member "operationName" |> to_option to_string) + json |> member "operationName" |> to_option to_string); } let of_graphql_body body = { query = Some body; variables = None; operation_name = None } let merge t t' = - { query = Option.first_some t.query t'.query - ; variables = Option.first_some t.variables t'.variables - ; operation_name = Option.first_some t.operation_name t'.operation_name + { + query = Option.first_some t.query t'.query; + variables = Option.first_some t.variables t'.variables; + operation_name = Option.first_some t.operation_name t'.operation_name; } let post_params_exn req body = let header = Request.header req ~header:"Content-Type" in match header with - | Some "application/graphql" -> - of_graphql_body body - | Some "application/json" -> - of_json_body_exn body - | _ -> - empty + | Some "application/graphql" -> of_graphql_body body + | Some "application/json" -> of_json_body_exn body + | _ -> empty let of_req_exn req body = let uri = Request.uri req in @@ -130,16 +125,13 @@ module Params (Request : HttpRequest) = struct let params = of_req_exn req body in match params.query with | Some query -> - Ok - ( query - , (params.variables - :> (string * Graphql_parser.const_value) list option) - , params.operation_name ) - | None -> - Error "Must provide query string" - with - | Yojson.Json_error msg -> - Error msg + Ok + ( query, + ( params.variables + :> (string * Graphql_parser.const_value) list option ), + params.operation_name ) + | None -> Error "Must provide query string" + with Yojson.Json_error msg -> Error msg end module Make @@ -155,45 +147,41 @@ struct let execute_query ctx schema variables operation_name query = match Graphql_parser.parse query with - | Ok doc -> - Schema.execute schema ctx ?variables ?operation_name doc - | Error e -> - Schema.Io.return (Error (`String e)) + | Ok doc -> Schema.execute schema ctx ?variables ?operation_name doc + | Error e -> Schema.Io.return (Error (`String e)) let execute_request schema ctx req body = Body.to_string body >>= fun body_string -> match Params.extract req body_string with - | Error err -> - Io.return @@ Response.make_bad_request ~body:err () - | Ok (query, variables, operation_name) -> - execute_query ctx schema variables operation_name query >>= ( function - | Ok (`Response data) -> - let body = Yojson.Basic.to_string data in - Io.return @@ Response.make_ok ~body () - | Ok (`Stream stream) -> - Schema.Io.Stream.close stream; - let body = "Subscriptions are only supported via websocket transport" in - Io.return @@ Response.make_bad_request ~body () - | Error err -> - let body = Yojson.Basic.to_string err in - Io.return @@ Response.make_bad_request ~body () ) + | Error err -> Io.return @@ Response.make_bad_request ~body:err () + | Ok (query, variables, operation_name) -> ( + execute_query ctx schema variables operation_name query >>= function + | Ok (`Response data) -> + let body = Yojson.Basic.to_string data in + Io.return @@ Response.make_ok ~body () + | Ok (`Stream stream) -> + Schema.Io.Stream.close stream; + let body = + "Subscriptions are only supported via websocket transport" + in + Io.return @@ Response.make_bad_request ~body () + | Error err -> + let body = Yojson.Basic.to_string err in + Io.return @@ Response.make_bad_request ~body () ) let make_callback make_context schema req body = let method_ = Request.method_ req in match method_ with | `GET -> - if - Request.header req ~header:"Connection" = Some "Upgrade" - && Request.header req ~header:"Upgrade" = Some "websocket" - then - (* let handle_conn = Websocket_transport.handle (execute_query - (make_context req) schema) in Io.return (Ws.upgrade_connection req - handle_conn) *) - assert false - else - execute_request schema (make_context req) req body - | `POST -> - execute_request schema (make_context req) req body - | _ -> - Io.return @@ Response.make_not_found ~body:"Not found" () + if + Request.header req ~header:"Connection" = Some "Upgrade" + && Request.header req ~header:"Upgrade" = Some "websocket" + then + (* let handle_conn = Websocket_transport.handle (execute_query + (make_context req) schema) in Io.return (Ws.upgrade_connection req + handle_conn) *) + assert false + else execute_request schema (make_context req) req body + | `POST -> execute_request schema (make_context req) req body + | _ -> Io.return @@ Response.make_not_found ~body:"Not found" () end diff --git a/graphql/src/graphql_server.mli b/graphql/src/graphql_server.mli index b789564..287d02d 100644 --- a/graphql/src/graphql_server.mli +++ b/graphql/src/graphql_server.mli @@ -4,10 +4,6 @@ module type Io = sig val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t val return : 'a -> 'a t - - type ic - - type oc end module type HttpBody = sig