Merge pull request #60 from andreas/lwt-server

Add Server.start to Graphql_lwt

Author: andreas

examples/jbuild

@@ -1,8 +1,8 @@
 (jbuild_version 1)
 
-(executables
+(executable
  ((libraries (cohttp.lwt graphql-lwt yojson))
-  (names (server))))
+  (name server)))
 
 (alias
   ((name DEFAULT)

examples/server.ml

@@ -69,41 +69,6 @@ let schema = Schema.(schema [
   ]
 )
 
-let json_err = function
-  | Ok _ as ok -> ok
-  | Error err -> Error (`String err)
-
-let execute variables query =
-  let open Lwt_result in
-  Lwt.return @@ json_err @@ Graphql_parser.parse query >>= fun doc ->
-  Schema.execute schema () ~variables doc
-
-let callback conn (req : Cohttp.Request.t) body =
-  Lwt_io.printf "Req: %s\n" req.resource;
-  match (req.meth, req.resource) with
-  | `GET, _ -> C.Server.respond_file "./index.html" ()
-  | `POST, _ ->
-    begin
-      Cohttp_lwt_body.to_string body >>= fun query_json ->
-      Lwt_io.printf "Body: %s\n" query_json;
-      let query = Yojson.Basic.(from_string query_json |> Util.member "query" |> Util.to_string)
-      in
-      let variables =
-        try
-          Yojson.Basic.(from_string query_json |> Util.member "variables" |> Util.to_assoc)
-        with _ -> []
-      in
-      Lwt_io.printf "Query: %s\n" query;
-      execute (variables :> (string * Graphql_parser.const_value) list) query >>= function
-      | Ok data ->
-          let body = Yojson.Basic.to_string data in
-          C.Server.respond_string ~status:`OK ~body ()
-      | Error err ->
-          let body = Yojson.Basic.to_string err in
-          C.Server.respond_error ~body ()
-    end
-  | _ -> C.Server.respond_string ~status:`Not_found ~body:"" ()
-
 let () =
-  C.Server.create ~mode:(`TCP (`Port 8080)) (C.Server.make ~callback ())
+  Server.start ~ctx:(fun () -> ()) schema
   |> Lwt_main.run

graphql-lwt.opam

@@ -12,6 +12,8 @@ depends: [
   "graphql"
   "alcotest" {test}
   "lwt"
+  "cohttp-lwt-unix" {>= "0.99"}
+  "crunch"
 ]
 available: [
   ocaml-version >= "4.03.0"

examples/index.html renamed to graphql-lwt/src/assets/index.html

@@ -57,11 +57,9 @@
         otherParams[k] = parameters[k];
       }
     }
-    var fetchURL = "http://localhost:8080";
-
     // Defines a GraphQL fetcher using the fetch API.
     function graphQLFetcher(graphQLParams) {
-      return fetch(fetchURL, {
+      return fetch(window.location, {
         method: 'post',
         headers: {
           'Accept': 'application/json',
@@ -107,10 +105,10 @@
         onEditQuery: onEditQuery,
         onEditVariables: onEditVariables,
         onEditOperationName: onEditOperationName,
-        query: null,
-        response: null,
-        variables: null,
-        operationName: null,
+        query: parameters.query,
+        response: parameters.response,
+        variables: parameters.variables,
+        operationName: parameters.operationName,
       }),
       document.body
     );

graphql-lwt/src/graphql_lwt.ml

@@ -1 +1,52 @@
-module Schema = Graphql_schema.Make(Lwt)
+open Graphql
+
+module Schema = Graphql_schema.Make(Lwt)
+
+module Server = struct
+  module C = Cohttp_lwt_unix
+  open Lwt
+
+  let static_file_response ?(encoding=`None) path =
+    match Assets.read path with
+    | Some body -> C.Server.respond_string ~status:`OK ~body ()
+    | None -> C.Server.respond_string ~status:`Not_found ~body:"" ()
+
+  let json_err = function
+    | Ok _ as ok -> ok
+    | Error err -> Error (`String err)
+
+  let execute_query ctx schema variables query =
+    let open Lwt_result in
+    Lwt.return @@ json_err @@ Graphql_parser.parse query >>= fun doc ->
+    Schema.execute schema ctx ~variables doc
+
+  let execute_request ctx schema req body =
+    Cohttp_lwt_body.to_string body >>= fun body' ->
+    Lwt_io.printf "Body: %s\n" body';
+    let json = Yojson.Basic.from_string body' in
+    let query = Yojson.Basic.(json |> Util.member "query" |> Util.to_string) in
+    let variables = try Yojson.Basic.Util.(json |> member "variables" |> to_assoc) with _ -> [] in
+    Lwt_io.printf "Query: %s\n" query;
+    let result = execute_query ctx schema (variables :> (string * Graphql_parser.const_value) list) query in
+    result >>= function
+    | Ok data ->
+        let body = Yojson.Basic.to_string data in
+        C.Server.respond_string ~status:`OK ~body ()
+    | Error err ->
+        let body = Yojson.Basic.to_string err in
+        C.Server.respond_error ~body ()
+
+  let mk_callback mk_context schema conn (req : Cohttp.Request.t) body =
+    Lwt_io.printf "Req: %s\n" req.resource;
+    let req_path = Cohttp.Request.uri req |> Uri.path in
+    let path_parts = Str.(split (regexp "/") req_path) in
+      match req.meth, path_parts with
+      | `GET,  ["graphql"]       -> static_file_response "index.html"
+      | `GET,  ["graphql"; path] -> static_file_response path
+      | `POST, ["graphql"]       -> execute_request (mk_context ()) schema req body
+      | _ -> C.Server.respond_string ~status:`Not_found ~body:"" ()
+
+  let start ?(port=8080) ~ctx schema =
+    let callback = mk_callback ctx schema in
+    C.Server.create ~mode:(`TCP (`Port port)) (C.Server.make ~callback ())
+end

graphql-lwt/src/graphql_lwt.mli

@@ -2,3 +2,7 @@
 module Schema : sig
   include Graphql_intf.Schema with type 'a io = 'a Lwt.t
 end
+
+module Server : sig
+  val start : ?port:int -> ctx:(unit -> 'ctx) -> 'ctx Schema.schema -> unit Lwt.t
+end

graphql-lwt/src/jbuild

@@ -1,8 +1,12 @@
 (jbuild_version 1)
 
+(rule
+ ((targets (assets.ml))
+  (deps ((files_recursively_in assets)))
+  (action (run ${bin:ocaml-crunch} -m plain assets -o assets.ml))))
+
 (library
  ((name graphql_lwt)
   (public_name graphql-lwt)
   (wrapped false)
-  (preprocess (pps (ppx_sexp_conv)))
-  (libraries (graphql lwt))))
+  (libraries (str graphql lwt cohttp.lwt))))