chore: Improve networking code pt 1

Dockerfile

@@ -99,7 +99,7 @@ COPY cli/src/semgrep/semgrep_interfaces cli/src/semgrep/semgrep_interfaces
 # Visit https://hub.docker.com/r/returntocorp/ocaml/tags to see the latest
 # images available.
 #
-FROM returntocorp/ocaml:alpine-2023-10-17 as semgrep-core-container
+FROM returntocorp/ocaml:alpine-2024-04-25 as semgrep-core-container
 
 WORKDIR /src/semgrep
 COPY --from=semgrep-core-files /src/semgrep .

dune-project

@@ -507,6 +507,7 @@ For more information see https://semgrep.dev
  ; web stuff
  uri
  uuidm
+ (cohttp (= 6.0.0~beta2))
  cohttp-lwt-unix
  cohttp-lwt-jsoo
  tls-lwt ; needed for TLS support in the cohttp HTTP client (only TLS 1.3 seems to work)

flake.nix

@@ -225,8 +225,6 @@
  ocaml-base-compiler = "4.14.2";
  # needed for OCTS and isn't pulled in by semgrep.opam
  tsort = "*";
- # don't use bleeding edge cohttp
- cohttp-lwt = "5.3.0";
  };
 
  # repos = opamRepos to force newest version of opam

js/node_shared/Semgrep_js_node_shared.ml

@@ -42,5 +42,5 @@ end
 (*****************************************************************************)
 
 let init_cohttp () =
- Http_helpers.client_ref :=
- Some (module Patched_cohttp_lwt_jsoo : Cohttp_lwt.S.Client)
+ Http_helpers.set_client_ref
+ (module Patched_cohttp_lwt_jsoo : Cohttp_lwt.S.Client)

libs/networking/http_helpers/http_helpers.mli

@@ -1,39 +1,46 @@
-(* Small wrapper around Cohttp data structures to access conveniently
- * all results (body, http code) from a GET http request.
- *)
-type get_info = { response : Cohttp.Response.t; code : int }
+(* This module provides a simple interface for making HTTP requests. It wraps
+ Cohttp with better error handling, adds network mocking, and proxy support *)
 
-(* This is functorized because we must run http requests differently
- * depending on the platform (native vs jsoo). To use this module do:
- *
- * module Http_helpers = Http_helpers.Make(Lwt_platform)
- *
- * where this Lwt_platform is defined via the dune 'virtual modules'
- * See libs/lwt_platform/ which defines this run() for more info.
- *)
-module Make (I : sig
- val run : 'a Lwt.t -> 'a
-end) : sig
- val get_async :
- ?headers:(string * string) list ->
- Cap.Network.t ->
- Uri.t ->
- (string * get_info, string * get_info) result Lwt.t
- (** [get_async ~headers caps uri] retrieves [uri] (via HTTP GET) with the
+type server_result = (string, string) result
+(** [server_result] is [Ok body] when the server returns an Ok status*)
+
+type server_response = {
+ body : server_result;
+ response : Cohttp.Response.t;
+ code : int;
+}
+(** [server_response] is whatever the server returns *)
+
+type client_result = (server_response, string) result
+(** [client_result] is [Ok response] when the network request is successful.
+ This does not guarantee the server response was an Ok status code. It
+ just means we made a network response and got /some/ response *)
+
+(* Before we didn't wrap anything here in two results. It used to be one result
+ * with a string error message. This was a mistake. We were trusting cohttp to
+ * not blow up on the smallest stuff, instead of returning a proper error. So
+ * now we have a proper error type. That Cohttp should have done for us. *)
+
+val get :
+ ?headers:(string * string) list ->
+ Cap.Network.t ->
+ Uri.t ->
+ client_result Lwt.t
+(** [get_async ~headers caps uri] retrieves [uri] (via HTTP GET) with the
  provided [headers], asynchronously. The return value is either a promise
  of [Ok body] - if the request was successful, or an error message.
  If a temporary redirect (307) is returned, this function will automatically
  re-query and resolve the redirection.
  *)
 
- val post_async :
-  body:string ->
-  ?headers:(string * string) list ->
-  ?chunked:bool ->
-  Cap.Network.t ->
-  Uri.t ->
-  (string, int * string) result Lwt.t
- (** [post_async ~body ~headers ~chunked caps uri] asynchronously sends a
+val post :
+ body:string ->
+ ?headers:(string * string) list ->
+ ?chunked:bool ->
+ Cap.Network.t ->
+ Uri.t ->
+ client_result Lwt.t
+(** [post_async ~body ~headers ~chunked caps uri] asynchronously sends a
  POST request to [uri] with
  - [headers] (default: content-type: application/json)
  - [chunked] (default: false) this maps to whether we enable
@@ -47,42 +54,16 @@ end) : sig
  successful, or an [Error (code, msg)], including the HTTP status [code]
  and a message. *)
 
- val get :
- ?headers:(string * string) list ->
- Cap.Network.t ->
- Uri.t ->
- (string * get_info, string * get_info) result
- (** [get ~headers caps uri] retrieves [uri] (via HTTP GET) with the provided
- [headers]. The return value is either [Ok body] - if the request was
- successful, or an error message.
- If a temporary redirect (307) is returned, this function will automatically
- re-query and resolve the redirection.
- *)
-
- val post :
- body:string ->
- ?headers:(string * string) list ->
- ?chunked:bool ->
- Cap.Network.t ->
- Uri.t ->
- (string, int * string) result
- (** [post ~body ~headers ~chunked caps uri] sends a POST request to [uri]
- with:
- - [headers] (default: content-type: application/json)
- - [chunked] (default: false)
- - [body] payload to send (e.g. JSON body as string)
-
- The returned value is either [Ok body] if the request was successful, or
- an [Error (code, msg)], including the HTTP status [code] and a message. *)
-end
-
-val client_ref : (module Cohttp_lwt.S.Client) option ref
-(** [client_ref] is a reference to the Cohttp client module used by the
+val set_client_ref : (module Cohttp_lwt.S.Client) -> unit
+(** [set_client_ref] sets a reference to the Cohttp client module used by the
  functions in this module. By default, it is set to
  [Cohttp_lwt_unix.Client], but can be changed to an instance
  of [TestingClient] if you want to test things. *)
 
-val set_client_ref : (module Cohttp_lwt.S.Client) -> unit
+val with_client_ref : (module Cohttp_lwt.S.Client) -> ('a -> 'b) -> 'a -> 'b
+(** [with_client client f x] is a helper function that temporarily sets the client
+ reference to the provided client module, runs the provided function, and
+ then resets the client reference to its original value. *)
 
 (* See Http_mock_client.ml. If this global is set, set_client_ref()
  * above will be a noop (and so leave the mock_http_client in place).

libs/networking/http_mock_client/Http_mock_client.ml

@@ -16,8 +16,8 @@
 (*****************************************************************************)
 (* Prelude *)
 (*****************************************************************************)
-module Request = Cohttp_lwt.Request
-module Response = Cohttp_lwt.Response
+module Request = Cohttp.Request
+module Response = Cohttp.Response
 module Body = Cohttp_lwt.Body
 module Header = Cohttp.Header
 
@@ -36,6 +36,12 @@ module Make (M : S) : Cohttp_lwt.S.Client = struct
  open M
 
  type ctx = unit
+ type 'a io = 'a Lwt.t
+ type body = Body.t
+ type 'a with_context = ?ctx:ctx -> 'a
+
+ let set_cache _ = failwith "Mock client, not implemented"
+ let map_context v f ?ctx = f (v ?ctx)
 
  let mock_response_of_request (req : Cohttp.Request.t) (body : Body.t) =
  Logs.debug (fun m ->
@@ -173,8 +179,9 @@ let with_testing_client make_fn test_fn () =
  let make_response = make_fn
  end))
  in
- Common.save_excursion Http_helpers.in_mock_context true (fun () ->
- Common.save_excursion Http_helpers.client_ref (Some new_client) test_fn)
+ Http_helpers.with_client_ref new_client
+ (fun () -> Common.save_excursion Http_helpers.in_mock_context true test_fn)
+ ()
 
 (*****************************************************************************)
 (* Saved Request/Reponse Mocking *)
@@ -250,15 +257,8 @@ let parse_req =
  in
  let headers = parse_headers headers in
  let body = String.concat "\n" body |> Body.of_string in
- ( {
- Cohttp.Request.meth;
- resource;
- version;
- headers;
- scheme = None;
- encoding = Body.transfer_encoding body;
- },
- body ))
+ let uri = Uri.of_string ("http://localhost/" ^ resource) in
+ (Cohttp.Request.make ~meth ~version ~headers uri, body))
 
 let parse_resp =
  strip_and_parse "< " (fun lines ->
@@ -271,17 +271,7 @@ let parse_resp =
  in
  let headers = parse_headers headers in
  let body = String.concat "\n" body |> Body.of_string in
- ( {
- Cohttp.Response.version;
- headers;
- status;
- (* Not sure exactly how cohttp uses this. Not documented.
- * Doesn't seem like there's any buffering in our tests anyway.
- *)
- flush = true;
- encoding = Body.transfer_encoding body;
- },
- body ))
+ (Cohttp.Response.make ~version ~status ~flush:true ~headers (), body))
 
 let client_from_file req_resp_file =
  let contents = UFile.Legacy.read_file req_resp_file in

libs/networking/http_mock_client/Http_mock_client.mli

@@ -32,17 +32,14 @@ let with_foo_client =
  pack_tests "Foo Tests" tests
  *)
 
-type test_response = {
- response : Cohttp_lwt.Response.t;
- body : Cohttp_lwt.Body.t;
-}
+type test_response = { response : Cohttp.Response.t; body : Cohttp_lwt.Body.t }
 (** [test_response] is a response (headers and status), and a path to a file
  * which will make the body of the response. The file is simply read and it's
  * exact bytes are returned
  *)
 
 type make_response_fn =
- Cohttp_lwt.Request.t -> Cohttp_lwt.Body.t -> test_response Lwt.t
+ Cohttp.Request.t -> Cohttp_lwt.Body.t -> test_response Lwt.t
 (** [make_response_fn requst body] takes in a request and its body, and
  * must return a response (see [basic_response]), and a path to a body
  * (see [test_response]).
@@ -73,7 +70,7 @@ val check_method : Cohttp.Code.meth -> Cohttp.Code.meth -> unit
  * Example: [check_method `GET request.meth]
  *)
 
-val check_header : Cohttp_lwt.Request.t -> string -> string -> unit
+val check_header : Cohttp.Request.t -> string -> string -> unit
 (** [check_header request header header_value] will use Alcotest to assert a request
  * was made with a certain header and value
  * Example: [check_header request "Authorization" "Bearer <token>"]
@@ -86,7 +83,7 @@ val check_headers : Cohttp.Header.t -> Cohttp.Header.t -> unit
  * compare equal.
  *)
 
-val get_header : Cohttp_lwt.Request.t -> string -> string option
+val get_header : Cohttp.Request.t -> string -> string option
 (** [get_header request header] will return the value of a header in a request
  * or None if the header is not present
  * Example: [get_header request "Authorization"]

semgrep.opam

@@ -63,6 +63,7 @@ depends: [
  "conf-libcurl" {= "1"}
  "uri"
  "uuidm"
+ "cohttp" {= "6.0.0~beta2"}
  "cohttp-lwt-unix"
  "cohttp-lwt-jsoo"
  "tls-lwt"

src/osemgrep/cli/CLI.ml

@@ -13,7 +13,6 @@
  * LICENSE for more details.
  *)
 module Http_helpers_ = Http_helpers
-module Http_helpers = Http_helpers.Make (Lwt_platform)
 module Env = Semgrep_envvars
 
 (*****************************************************************************)

src/osemgrep/cli_ci/Ci_subcommand.ml

@@ -1,6 +1,5 @@
 open Common
 module OutJ = Semgrep_output_v1_j
-module Http_helpers = Http_helpers.Make (Lwt_platform)
 
 (*****************************************************************************)
 (* TODO: migrate this to the new scan endpoint to match the pysemgrep *)

src/osemgrep/cli_install_semgrep_pro/Install_semgrep_pro_subcommand.ml

@@ -14,7 +14,6 @@
  *)
 open Fpath_.Operators
 module Out = Semgrep_output_v1_j
-module Http_helpers = Http_helpers.Make (Lwt_platform)
 
 (*****************************************************************************)
 (* Prelude *)
@@ -49,24 +48,40 @@ let add_semgrep_pro_version_stamp current_executable_path =
  (* THINK: does this append or write entirely? *)
  UFile.write_file pro_version_stamp_path Version.version
 
-let download_semgrep_pro (caps : < Cap.network ; .. >) platform_kind dest =
+let download_semgrep_pro_async (caps : < Cap.network ; .. >) platform_kind dest
+ =
  let dest = !!dest in
  match (Semgrep_settings.load ()).api_token with
  | None ->
  Logs.err (fun m ->
  m "No API token found, please run `semgrep login` first.");
- false
+ Lwt.return_false
  | Some token -> (
  let caps = Auth.cap_token_and_network token caps in
- match Semgrep_App.fetch_pro_binary caps platform_kind with
- | Error (_, { code = 401; _ }) ->
+ match%lwt Semgrep_App.fetch_pro_binary caps platform_kind with
+ | Ok { body = Ok body; response; _ } ->
+ (* Make sure no such binary exists. We have had weird situations
+ * when the downloaded binary was corrupted, and overwriting it did
+ * not fix it, but it was necessary to `rm -f` it.
+ *)
+ if Sys.file_exists dest then FileUtil.rm [ dest ];
+
+ (* TODO: does this matter if we don't have a progress bar? *)
+ let _file_size =
+ Cohttp.(Header.get (Response.headers response) "Content-Length")
+ |> Option.map int_of_string |> Option.value ~default:0
+ in
+
+ UFile.write_file (Fpath.v dest) body;
+ Lwt.return_true
+ | Ok { code = 401; _ } ->
  Logs.err (fun m ->
  m
  "API token not valid. Try to run `semgrep logout` and `semgrep \
  login` again. Or in CI, ensure your SEMGREP_APP_TOKEN \
  variable is set correctly.");
- false
- | Error (_, { code = 403; _ }) ->
+ Lwt.return_false
+ | Ok { code = 403; _ } ->
  Logs.err (fun m ->
  m
  "Logged in deployment does not have access to Semgrep Pro \
@@ -75,24 +90,17 @@ let download_semgrep_pro (caps : < Cap.network ; .. >) platform_kind dest =
  m
  "Visit https://semgrep.dev/products/pro-engine for more \
  information.");
- false
+ Lwt.return_false
  (* THINK: ??? is this raise for status? *)
- | Error _ -> false
- | Ok (body, { response; _ }) ->
- (* Make sure no such binary exists. We have had weird situations
- * when the downloaded binary was corrupted, and overwriting it did
- * not fix it, but it was necessary to `rm -f` it.
- *)
- if Sys.file_exists dest then FileUtil.rm [ dest ];
-
- (* TODO: does this matter if we don't have a progress bar? *)
- let _file_size =
- Cohttp.(Header.get (Response.headers response) "Content-Length")
- |> Option.map int_of_string |> Option.value ~default:0
- in
-
- UFile.write_file (Fpath.v dest) body;
- true)
+ | Ok { code; body = Error msg; _ } ->
+ Logs.err (fun m -> m "Error downloading Semgrep Pro: %d %s" code msg);
+ Lwt.return_false
+ | Error msg ->
+ Logs.err (fun m -> m "Error downloading Semgrep Pro: %s" msg);
+ Lwt.return_false)
+
+let download_semgrep_pro caps platform_kind dest =
+ Lwt_platform.run (download_semgrep_pro_async caps platform_kind dest)
 
 (*****************************************************************************)
 (* Main logic *)