Use cohttp and eio instead of curly

CHANGES.md

@@ -1,3 +1,9 @@
+## unreleased
+
+### Changed
+
+- Use cohttp and eio instead of curly (#<PR_NUMBER>, @gpetiot)
+
 ## 2.0.1
 
 ### Fixed

bin/dune

@@ -4,9 +4,13 @@
  (package get-activity)
  (libraries
   cmdliner
+  cohttp-eio
+  eio_main
+  tls-eio
   dune-build-info
   get-activity-lib
   logs.cli
   logs.fmt
+  mirage-crypto-rng-eio
   fmt.cli
   fmt.tty))

bin/main.ml

@@ -97,19 +97,50 @@ let version =
 
 let info = Cmd.info "get-activity" ~version
 
+module Client = struct
+  let null_auth ?ip:_ ~host:_ _ = Ok None
+
+  let https ~authenticator =
+    let tls_config =
+      match Tls.Config.client ~authenticator () with
+      | Error (`Msg msg) -> failwith ("tls configuration problem: " ^ msg)
+      | Ok tls_config -> tls_config
+    in
+    fun uri raw ->
+      let host =
+        Uri.host uri
+        |> Option.map (fun x -> Domain_name.(host_exn (of_string_exn x)))
+      in
+      Tls_eio.client_of_flow ?host tls_config raw
+
+  let make env =
+    Cohttp_eio.Client.make
+      ~https:(Some (https ~authenticator:null_auth))
+      env#net
+end
+
+let run_eio f =
+  Eio_main.run @@ fun env ->
+  Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+  Eio.Switch.run @@ fun sw ->
+  let client = Client.make env in
+  f env sw client
+
 let run () period user : unit =
   match mode with
   | `Normal ->
+      run_eio @@ fun _env sw client ->
       Period.with_period period ~last_fetch_file ~f:(fun period ->
           let* token = get_token () in
           let request = Contributions.request ~period ~user ~token in
-          let* contributions = Graphql.exec request in
+          let* contributions = Graphql.Request.exec client sw request in
           show ~period ~user contributions)
   | `Save ->
+      run_eio @@ fun _env sw client ->
       Period.with_period period ~last_fetch_file ~f:(fun period ->
           let* token = get_token () in
           let request = Contributions.request ~period ~user ~token in
-          let* contributions = Graphql.exec request in
+          let* contributions = Graphql.Request.exec client sw request in
           Yojson.Safe.to_file "activity.json" contributions)
   | `Load ->
       (* When testing formatting changes, it is quicker to fetch the data once and then load it again for each test: *)

dune-project

@@ -30,7 +30,7 @@
   (alcotest :with-test)
   (ppx_expect :with-test)
   astring
-  curly
+  cohttp-eio
   (fmt
    (>= 0.8.7))
   logs

get-activity-lib.opam

@@ -10,7 +10,7 @@ depends: [
   "alcotest" {with-test}
   "ppx_expect" {with-test}
   "astring"
-  "curly"
+  "cohttp-eio"
   "fmt" {>= "0.8.7"}
   "logs"
   "ppx_yojson_conv"

lib/contributions.ml

@@ -73,7 +73,7 @@ let query user =
 let request ~period:(start, finish) ~user ~token =
   let variables = [ ("from", `String start); ("to", `String finish) ] in
   let query = query user in
-  Graphql.request ~token ~variables ~query ()
+  Graphql.Request.make ~token ~variables ~query ()
 
 module Datetime = struct
   type t = string

lib/contributions.mli

@@ -22,7 +22,7 @@ module Repo_map : Map.S with type key = string
 type t = { username : string; activity : item list Repo_map.t }
 
 val request :
-  period:string * string -> user:User.t -> token:Token.t -> Graphql.request
+  period:string * string -> user:User.t -> token:Token.t -> Graphql.Request.t
 
 val of_json :
   period:string * string ->

lib/dune

@@ -1,6 +1,6 @@
 (library
  (name get_activity)
  (public_name get-activity-lib)
- (libraries astring curly fmt logs yojson)
+ (libraries astring cohttp-eio fmt logs yojson unix)
  (preprocess
   (pps ppx_yojson_conv)))

lib/graphql.ml

@@ -1,47 +1,57 @@
+let ( let* ) = Result.bind
 let ( / ) a b = Yojson.Safe.Util.member b a
 
-type request = {
-  meth : Curly.Meth.t;
-  url : string;
-  headers : Curly.Header.t;
-  body : Yojson.Safe.t;
-}
+module Request = struct
+  type t = { request : Cohttp.Request.t; uri : Uri.t; body : Cohttp_eio.Body.t }
 
-let request ?variables ~token ~query () =
-  let body =
-    `Assoc
-      (("query", `String query)
-      ::
-      (match variables with
-      | None -> []
-      | Some v -> [ ("variables", `Assoc v) ]))
-  in
-  let url = "https://api.github.com/graphql" in
-  let headers = [ ("Authorization", "bearer " ^ token) ] in
-  { meth = `POST; url; headers; body }
+  let make ?variables ~token ~query () =
+    let body =
+      `Assoc
+        (("query", `String query)
+        ::
+        (match variables with
+        | None -> []
+        | Some v -> [ ("variables", `Assoc v) ]))
+      |> Yojson.Safe.to_string |> Cohttp_eio.Body.of_string
+    in
+    let uri = Uri.of_string "https://api.github.com/graphql" in
+    let meth = `POST in
+    let headers = Cohttp.Header.init_with "Authorization" ("bearer " ^ token) in
+    let request = Cohttp.Request.make ~meth ~headers uri in
+    { request; uri; body }
 
-let exec request =
-  let { meth; url; headers; body } = request in
-  let body = Yojson.Safe.to_string body in
-  let request = Curly.Request.make ~headers ~body ~url ~meth () in
-  Logs.debug (fun m -> m "request: @[%a@]@." Curly.Request.pp request);
-  match Curly.run request with
-  | Ok ({ Curly.Response.body; _ } as response) -> (
-      Logs.debug (fun m -> m "response: @[%a@]@." Curly.Response.pp response);
-      let json = Yojson.Safe.from_string body in
-      match json / "message" with
-      | `Null -> Ok json
-      | `String e ->
-          Error (`Msg (Format.asprintf "@[<v2>GitHub returned errors: %s@]" e))
-      | _errors ->
-          Error
-            (`Msg
-              (Format.asprintf "@[<v2>GitHub returned errors: %a@]"
-                 (Yojson.Safe.pretty_print ~std:true)
-                 json)))
-  | Error e ->
-      Error
-        (`Msg
-          (Format.asprintf
-             "@[<v2>Error performing GraphQL query on GitHub: %a@]"
-             Curly.Error.pp e))
+  let exec client sw { request; body; uri } =
+    Logs.debug (fun m -> m "request: @[%a@]@." Cohttp.Request.pp_hum request);
+    let headers = request.headers in
+    let resp, body = Cohttp_eio.Client.post ~sw ~body ~headers client uri in
+    match resp.status with
+    | `OK -> (
+        Logs.debug (fun m -> m "response: @[%a@]@." Http.Response.pp resp);
+        let* body = (Eio.Buf_read.(parse take_all) body) ~max_size:max_int in
+        let json = Yojson.Safe.from_string body in
+        match json / "message" with
+        | `Null -> Ok json
+        | `String e ->
+            Error
+              (`Msg (Format.asprintf "@[<v2>GitHub returned errors: %s@]" e))
+        | _errors ->
+            Error
+              (`Msg
+                (Format.asprintf "@[<v2>GitHub returned errors: %a@]"
+                   (Yojson.Safe.pretty_print ~std:true)
+                   json)))
+    | status ->
+        Error
+          (`Msg
+            (Fmt.str
+               "@[<v2>Error performing GraphQL query on GitHub: Unexpected \
+                HTTP status %a@]"
+               Http.Status.pp status))
+
+  let pp ppf { request; uri = _; body = _ } =
+    let pp_request ppf r =
+      Fmt.pf ppf "@[<v>request =@;<1 2>@[<v2>%a@]@]" Cohttp.Request.pp_hum r
+    in
+    let pp_body ppf () = Fmt.pf ppf "@[<v>body =@;<1 2><...>@]" in
+    Fmt.pf ppf "@[<v2>{@ %a;@ %a@ }@]" pp_request request pp_body ()
+end

lib/graphql.mli

@@ -1,15 +1,18 @@
-type request = {
-  meth : Curly.Meth.t;
-  url : string;
-  headers : Curly.Header.t;
-  body : Yojson.Safe.t;
-}
+module Request : sig
+  type t
 
-val request :
-  ?variables:(string * Yojson.Safe.t) list ->
-  token:string ->
-  query:string ->
-  unit ->
-  request
+  val make :
+    ?variables:(string * Yojson.Safe.t) list ->
+    token:string ->
+    query:string ->
+    unit ->
+    t
 
-val exec : request -> (Yojson.Safe.t, [ `Msg of string ]) result
+  val exec :
+    Cohttp_eio.Client.t ->
+    Eio.Switch.t ->
+    t ->
+    (Yojson.Safe.t, [ `Msg of string ]) result
+
+  val pp : t Fmt.t
+end

test/expect/main.ml

@@ -1,5 +1,58 @@
 open Get_activity
 
+let%expect_test "Graphql.Request.make" =
+  let request = Graphql.Request.make ~token:"" ~query:"" () in
+  Fmt.pr "%a" Graphql.Request.pp request;
+  [%expect
+    {|
+    {
+      request =
+        ((headers
+      ((Authorization "bearer ") (host api.github.com)
+       (user-agent ocaml-cohttp/v6.0.0_beta2)))
+     (meth POST) (scheme (https)) (resource /graphql) (version HTTP_1_1)
+     (encoding Unknown));
+      body =
+        <...>
+      }
+    |}]
+
+let%expect_test "Contributions.request viewer" =
+  let user = User.Viewer in
+  let request = Contributions.request ~period:("", "") ~user ~token:"" in
+  Fmt.pr "%a" Graphql.Request.pp request;
+  [%expect
+    {|
+    {
+      request =
+        ((headers
+      ((Authorization "bearer ") (host api.github.com)
+       (user-agent ocaml-cohttp/v6.0.0_beta2)))
+     (meth POST) (scheme (https)) (resource /graphql) (version HTTP_1_1)
+     (encoding Unknown));
+      body =
+        <...>
+      }
+    |}]
+
+let%expect_test "Contributions.request user" =
+  let user = User.User "me" in
+  let request = Contributions.request ~period:("", "") ~user ~token:"" in
+  Fmt.pr "%a" Graphql.Request.pp request;
+  [%expect
+    {|
+    {
+      request =
+        ((headers
+      ((Authorization "bearer ") (host api.github.com)
+       (user-agent ocaml-cohttp/v6.0.0_beta2)))
+     (meth POST) (scheme (https)) (resource /graphql) (version HTTP_1_1)
+     (encoding Unknown));
+      body =
+        <...>
+      }
+    |}]
+
 let contributions_example ~user =
   let open Contributions in
   {

test/lib/alcotest_ext.ml

@@ -25,51 +25,3 @@ module Yojson = struct
 end
 
 let yojson = Yojson.testable
-
-module Curly = struct
-  module Meth = struct
-    type t = Curly.Meth.t
-
-    let pp = Curly.Meth.pp
-
-    let eq (x : t) (y : t) =
-      let x = Format.asprintf "%a" Curly.Meth.pp x in
-      let y = Format.asprintf "%a" Curly.Meth.pp y in
-      String.equal x y
-  end
-
-  module Header = struct
-    type t = Curly.Header.t
-
-    let pp = Curly.Header.pp
-
-    let eq (x : t) (y : t) =
-      let x = Format.asprintf "%a" Curly.Header.pp x in
-      let y = Format.asprintf "%a" Curly.Header.pp y in
-      String.equal x y
-  end
-end
-
-module Request = struct
-  type t = Get_activity.Graphql.request
-
-  let pp fs (x : t) =
-    Format.fprintf fs
-      "@[<hv 2>{@;\
-       meth = %a;@;\
-       url = %S@;\
-       headers =@ %a@;\
-       body =@ @[<hv 0>%a@];@]@;\
-       }"
-      Curly.Meth.pp x.meth x.url Curly.Header.pp x.headers Yojson.pp x.body
-
-  let eq (x : t) (y : t) =
-    Curly.Meth.eq x.meth y.meth
-    && String.equal x.url y.url
-    && Curly.Header.eq x.headers y.headers
-    && Yojson.eq x.body y.body
-
-  let testable = Alcotest.testable pp eq
-end
-
-let request = Request.testable

test/lib/alcotest_ext.mli

@@ -5,4 +5,3 @@ val or_msg :
   'a Alcotest.testable -> ('a, [ `Msg of string ]) result Alcotest.testable
 
 val yojson : Yojson.Safe.t Alcotest.testable
-val request : Get_activity.Graphql.request Alcotest.testable

test/lib/main.ml

@@ -1,8 +1,3 @@
 let () =
   Alcotest.run "get-activity-lib"
-    [
-      Test_token.suite;
-      Test_period.suite;
-      Test_graphql.suite;
-      Test_contributions.suite;
-    ]
+    [ Test_token.suite; Test_period.suite; Test_contributions.suite ]