Use cohttp and eio instead of curly

CHANGES.md

@@ -1,3 +1,9 @@
+## unreleased
+
+### Changed
+
+- Use cohttp and eio instead of curly (#44, @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,49 @@ 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 () ->
+  let client = Client.make env in
+  f env client
+
 let run () period user : unit =
   match mode with
   | `Normal ->
+      run_eio @@ fun _env 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 request in
           show ~period ~user contributions)
   | `Save ->
+      run_eio @@ fun _env 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 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

@@ -15,11 +15,16 @@
  (name get-activity)
  (synopsis "Collect activity as markdown")
  (depends
+  cohttp-eio
   (cmdliner
    (>= 1.1.1))
   dune-build-info
+  eio_main
   fmt
   logs
+  mirage-crypto-rng-eio
+  (tls-eio
+   (>= 1.0.0))
   (get-activity-lib
    (= :version))))
 
@@ -30,12 +35,12 @@
   (alcotest :with-test)
   (ppx_expect :with-test)
   astring
-  curly
+  cohttp-eio
   (fmt
    (>= 0.8.7))
   logs
   ppx_yojson_conv
   (yojson
    (>= 1.6))
   (ocaml
-   (>= 4.08))))
+   (>= 5.0))))

get-activity-lib.opam

@@ -10,12 +10,12 @@ depends: [
   "alcotest" {with-test}
   "ppx_expect" {with-test}
   "astring"
-  "curly"
+  "cohttp-eio"
   "fmt" {>= "0.8.7"}
   "logs"
   "ppx_yojson_conv"
   "yojson" {>= "1.6"}
-  "ocaml" {>= "4.08"}
+  "ocaml" {>= "5.0"}
   "odoc" {with-doc}
 ]
 build: [

get-activity.opam

@@ -7,10 +7,14 @@ homepage: "https://github.com/tarides/get-activity"
 bug-reports: "https://github.com/tarides/get-activity/issues"
 depends: [
   "dune" {>= "2.8"}
+  "cohttp-eio"
   "cmdliner" {>= "1.1.1"}
   "dune-build-info"
+  "eio_main"
   "fmt"
   "logs"
+  "mirage-crypto-rng-eio"
+  "tls-eio" {>= "1.0.0"}
   "get-activity-lib" {= version}
   "odoc" {with-doc}
 ]

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,58 @@
+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 { request; body; uri } =
+    Logs.debug (fun m -> m "request: @[%a@]@." Cohttp.Request.pp_hum request);
+    let headers = request.headers in
+    Eio.Switch.run @@ fun sw ->
+    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,15 @@
-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 -> 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
   {