From f20e522b76e2b3926233990c17c20b73ceb20159 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 26 Sep 2024 17:22:19 +0100 Subject: [PATCH] Use cohttp and eio instead of curly --- CHANGES.md | 6 +++ bin/dune | 4 ++ bin/main.ml | 35 ++++++++++++- dune-project | 2 +- get-activity-lib.opam | 2 +- lib/contributions.ml | 2 +- lib/contributions.mli | 2 +- lib/dune | 2 +- lib/graphql.ml | 96 +++++++++++++++++++--------------- lib/graphql.mli | 29 +++++----- test/expect/main.ml | 53 +++++++++++++++++++ test/lib/alcotest_ext.ml | 48 ----------------- test/lib/alcotest_ext.mli | 1 - test/lib/main.ml | 7 +-- test/lib/test_contributions.ml | 44 +--------------- test/lib/test_graphql.ml | 24 --------- 16 files changed, 172 insertions(+), 185 deletions(-) delete mode 100644 test/lib/test_graphql.ml diff --git a/CHANGES.md b/CHANGES.md index f55198c..2cca9b5 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +## unreleased + +### Changed + +- Use cohttp and eio instead of curly (#, @gpetiot) + ## 2.0.1 ### Fixed diff --git a/bin/dune b/bin/dune index 9506f36..5c03137 100644 --- a/bin/dune +++ b/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)) diff --git a/bin/main.ml b/bin/main.ml index f0c1efb..8ddb235 100644 --- a/bin/main.ml +++ b/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: *) diff --git a/dune-project b/dune-project index eb45f87..4f44886 100644 --- a/dune-project +++ b/dune-project @@ -30,7 +30,7 @@ (alcotest :with-test) (ppx_expect :with-test) astring - curly + cohttp-eio (fmt (>= 0.8.7)) logs diff --git a/get-activity-lib.opam b/get-activity-lib.opam index 0c5207c..7cee692 100644 --- a/get-activity-lib.opam +++ b/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" diff --git a/lib/contributions.ml b/lib/contributions.ml index 7bf2236..cbc47e1 100644 --- a/lib/contributions.ml +++ b/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 diff --git a/lib/contributions.mli b/lib/contributions.mli index bfe878c..d1cfe19 100644 --- a/lib/contributions.mli +++ b/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 -> diff --git a/lib/dune b/lib/dune index d96d5c4..198ba81 100644 --- a/lib/dune +++ b/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))) diff --git a/lib/graphql.ml b/lib/graphql.ml index 9b95795..0fcb135 100644 --- a/lib/graphql.ml +++ b/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 "@[GitHub returned errors: %s@]" e)) - | _errors -> - Error - (`Msg - (Format.asprintf "@[GitHub returned errors: %a@]" - (Yojson.Safe.pretty_print ~std:true) - json))) - | Error e -> - Error - (`Msg - (Format.asprintf - "@[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 "@[GitHub returned errors: %s@]" e)) + | _errors -> + Error + (`Msg + (Format.asprintf "@[GitHub returned errors: %a@]" + (Yojson.Safe.pretty_print ~std:true) + json))) + | status -> + Error + (`Msg + (Fmt.str + "@[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 "@[request =@;<1 2>@[%a@]@]" Cohttp.Request.pp_hum r + in + let pp_body ppf () = Fmt.pf ppf "@[body =@;<1 2><...>@]" in + Fmt.pf ppf "@[{@ %a;@ %a@ }@]" pp_request request pp_body () +end diff --git a/lib/graphql.mli b/lib/graphql.mli index f0094c8..5b454f5 100644 --- a/lib/graphql.mli +++ b/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 diff --git a/test/expect/main.ml b/test/expect/main.ml index 877d562..de2e983 100644 --- a/test/expect/main.ml +++ b/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 { diff --git a/test/lib/alcotest_ext.ml b/test/lib/alcotest_ext.ml index 330db4a..f8b4b02 100644 --- a/test/lib/alcotest_ext.ml +++ b/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 - "@[{@;\ - meth = %a;@;\ - url = %S@;\ - headers =@ %a@;\ - body =@ @[%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 diff --git a/test/lib/alcotest_ext.mli b/test/lib/alcotest_ext.mli index d8aecc3..ece7629 100644 --- a/test/lib/alcotest_ext.mli +++ b/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 diff --git a/test/lib/main.ml b/test/lib/main.ml index 1172be5..0845405 100644 --- a/test/lib/main.ml +++ b/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 ] diff --git a/test/lib/test_contributions.ml b/test/lib/test_contributions.ml index b544c68..5adfdfd 100644 --- a/test/lib/test_contributions.ml +++ b/test/lib/test_contributions.ml @@ -166,48 +166,6 @@ let request ~user = }|} User.query user -let test_request = - let make_test name ~period ~user ~token ~expected = - let name = Printf.sprintf "request: %s" name in - let test_fun () = - let actual = Contributions.request ~period ~user ~token in - Alcotest.(check Alcotest_ext.request) name expected actual - in - (name, `Quick, test_fun) - in - [ - (let user = User.Viewer in - make_test "no token" ~user ~token:"" ~period:("", "") - ~expected: - { - meth = `POST; - url = "https://api.github.com/graphql"; - headers = [ ("Authorization", "bearer ") ]; - body = - `Assoc - [ - ("query", `String (request ~user)); - ( "variables", - `Assoc [ ("from", `String ""); ("to", `String "") ] ); - ]; - }); - (let user = User.User "me" in - make_test "no token" ~user ~token:"" ~period:("", "") - ~expected: - { - meth = `POST; - url = "https://api.github.com/graphql"; - headers = [ ("Authorization", "bearer ") ]; - body = - `Assoc - [ - ("query", `String (request ~user)); - ( "variables", - `Assoc [ ("from", `String ""); ("to", `String "") ] ); - ]; - }); - ] - let or_viewer = function User.User u -> u | Viewer -> "gpetiot" let activity_example ~user = @@ -614,4 +572,4 @@ let test_is_empty = ~expected:false; ] -let suite = ("Contributions", test_request @ test_of_json @ test_is_empty) +let suite = ("Contributions", test_of_json @ test_is_empty) diff --git a/test/lib/test_graphql.ml b/test/lib/test_graphql.ml deleted file mode 100644 index a58230d..0000000 --- a/test/lib/test_graphql.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Get_activity - -let test_request = - let make_test name ?variables ~token ~query ~expected () = - let name = Printf.sprintf "request: %s" name in - let test_fun () = - let actual = Graphql.request ?variables ~token ~query () in - Alcotest.(check Alcotest_ext.request) name expected actual - in - (name, `Quick, test_fun) - in - [ - make_test "no token" ~token:"" ~query:"" - ~expected: - { - meth = `POST; - url = "https://api.github.com/graphql"; - headers = [ ("Authorization", "bearer ") ]; - body = `Assoc [ ("query", `String "") ]; - } - (); - ] - -let suite = ("Graphql", test_request)