GraphQL skeleton support

Still needs:

- Subscriptions via WebSockets.
- Streaming.
- Variables.

dream.opam

@@ -1,5 +1,8 @@
 opam-version: "2.0"
 
+# TODO Test dependency cone, i.e. list dependencies actually installed and make
+# sure nothing questionable silently creeps in.
+
 depends: [
   "base-unix"
   "base64" {>= "3.1.0"}  # Base64.encode_string.
@@ -8,6 +11,8 @@ depends: [
   "cstruct"
   "dune" {>= "2.7.0"}  # --instrument-with.
   "fmt" {>= "0.8.7"}  # `Italic. This constrains Dream to OCaml >= 4.05.
+  "graphql_parser"
+  "graphql-lwt"  # Should be factored out; Menhir as recursive dependency.
   "hmap"
   "jwto" {>= "0.2.2"}  # Jwto.get_payload. TODO LATER Probably system deps.
   "lwt"
@@ -18,6 +23,7 @@ depends: [
   "multipart-form-data" {>= "0.3.0"}
   "ocaml" {>= "4.05.0"}  # String.split_on_char, String.index_from_opt.
   "uri"
+  "yojson"  # ...
 
   # Currently vendored.
   # "gluten"

example/j-graphql/Makefile

@@ -0,0 +1,6 @@
+.PHONY : run
+run :
+	@tput rmam || true
+	@stty -echo || true
+	@dune exec --no-print-directory -- ./graphql.exe
+	@tput smam || true

example/j-graphql/README.md

@@ -0,0 +1 @@
+<!-- TODO -->

example/j-graphql/dune

@@ -0,0 +1,3 @@
+(executable
+ (name graphql)
+ (libraries dream))

example/j-graphql/dune-project

@@ -0,0 +1 @@
+(lang dune 2.0)

example/j-graphql/graphql.ml

@@ -0,0 +1,37 @@
+type user = {
+  id : int;
+  name : string;
+}
+
+let hardcoded_users = [
+  {id = 1; name = "alice"};
+  {id = 2; name = "bob"};
+]
+
+let user =
+  Graphql_lwt.Schema.(obj "user"
+    ~doc:"A user"
+    ~fields:(fun _ -> [
+      field "id"
+        ~doc:"User id"
+        ~typ:(non_null int)
+        ~args:Arg.[]
+        ~resolve:(fun _ user -> user.id);
+      field "name"
+        ~doc:"User name"
+        ~typ:(non_null string)
+        ~args:Arg.[]
+        ~resolve:(fun _ user -> user.name);
+    ]))
+
+let schema =
+  Graphql_lwt.Schema.(schema [
+    field "users"
+      ~typ:(non_null (list (non_null user)))
+      ~args:Arg.[]
+      ~resolve:(fun _ () -> hardcoded_users);
+  ])
+
+let () =
+  Dream.run
+    (Dream.graphql Lwt.return schema)

example/j-graphql/graphql.opam

@@ -0,0 +1,7 @@
+opam-version: "2.0"
+
+depends: [
+  "dream"
+  "dune" {>= "2.0.0"}
+  "ocaml"
+]

src/dream.ml

@@ -39,6 +39,8 @@ include Dream__middleware.Csrf
 let content_length =
   Dream__middleware.Content_length.content_length
 
+include Dream__graphql.Graphql
+
 include Dream__middleware.Error
 include Dream__http.Http
 

src/dream.mli

@@ -630,6 +630,7 @@ type form = [
     usage. The remaining constructors, [`Invalid_token], [`Missing_token],
     [`Many_tokens], [`Not_form_urlencoded] correspond to bugs or suspicious
     activity. *)
+(* TODO Rename to form_result. *)
 
 (* TODO Link to the tag helper for dream.csrf and backup instructions for
    generating it. *)
@@ -935,6 +936,14 @@ val close : websocket -> unit Lwt.t
 
 
 
+(** {1 GraphQL} *)
+
+val graphql : (request -> 'a Lwt.t) -> 'a Graphql_lwt.Schema.schema -> handler
+(* TODO Any neat way to hide the context-maker for super basic usage? *)
+(* TODO Either that, or give it a name so that it's clearer. *)
+
+
+
 (** {1 Logging} *)
 
 val log : ('a, Format.formatter, unit, unit) format4 -> 'a

src/dune

@@ -2,9 +2,11 @@
  (public_name dream)
  (wrapped false)
  (libraries
+  dream.graphql
   dream.http
   dream.middleware
   dream.pure
+  graphql-lwt
   logs
   lwt
   lwt.unix

src/graphql/dune

@@ -0,0 +1,11 @@
+(library
+ (public_name dream.graphql)
+ (name dream__graphql)
+ (libraries
+  dream.pure
+  graphql_parser
+  graphql-lwt
+  lwt
+  yojson
+ )
+ (instrumentation (backend bisect_ppx)))

src/graphql/graphql.ml

@@ -0,0 +1,40 @@
+(* This file is part of Dream, released under the MIT license. See
+   LICENSE.md for details, or visit https://github.com/aantron/dream.
+
+   Copyright 2021 Anton Bachin *)
+
+
+
+module Dream = Dream__pure.Inmost
+
+
+
+let graphql context schema = fun request ->
+  let open Lwt.Infix in
+
+  Dream.body request
+  >>= fun body ->
+
+  prerr_endline "body";
+
+  (* TODO Actual error checking, logging, response, etc. *)
+  let query = Graphql_parser.parse body |> Result.get_ok in
+
+  context request
+  >>= fun context ->
+
+  (* TODO ?variables *)
+  (* TODO ?operation_name *)
+  Graphql_lwt.Schema.execute schema context query
+  >>= fun graphql_response ->
+
+  (* TODO Handle all the cases. *)
+  match graphql_response with
+  | Ok (`Response json) ->
+    (* TODO Review JSON library choice. *)
+    (* TODO Proper headers, etc. *)
+    Yojson.Basic.to_string json
+    |> Dream.respond
+  | _ ->
+    (* TODO Way more detail. *)
+    Dream.respond ~status:`Internal_Server_Error ""