From 172f0f08ee014310cd2ec4784621a031896bc726 Mon Sep 17 00:00:00 2001
From: Robur <team@robur.coop>
Date: Tue, 7 Sep 2021 13:15:29 +0000
Subject: [PATCH] expose resolve_location

---
 src/http_lwt_client.ml  | 16 ++++++++--------
 src/http_lwt_client.mli |  2 ++
 2 files changed, 10 insertions(+), 8 deletions(-)

diff --git a/src/http_lwt_client.ml b/src/http_lwt_client.ml
index 508ef1e..11205f8 100644
--- a/src/http_lwt_client.ml
+++ b/src/http_lwt_client.ml
@@ -246,17 +246,17 @@ let single_request resolver ?config ?authenticator ~meth ~headers ?body uri =
     Logs.warn (fun m -> m "Initiate an http/1.1 connection despite a requested h2 connection.");
     single_http_1_1_request fd user_pass host meth path headers body
 
-let resolve_location uri loc =
-  match String.split_on_char '/' loc with
-  | "http:" :: "" :: _ -> loc
-  | "https:" :: "" :: _ -> loc
+let resolve_location ~uri ~location =
+  match String.split_on_char '/' location with
+  | "http:" :: "" :: _ -> location
+  | "https:" :: "" :: _ -> location
   | "" :: "" :: _ ->
     let schema = String.sub uri 0 (String.index uri '/') in
-    schema ^ loc
+    schema ^ location
   | "" :: _ ->
     (match String.split_on_char '/' uri with
      | schema :: "" :: user_pass_host_port :: _ ->
-       String.concat "/" [schema ; "" ; user_pass_host_port ^ loc]
+       String.concat "/" [schema ; "" ; user_pass_host_port ^ location]
      | _ -> invalid_arg "expected an absolute uri")
   | _ -> invalid_arg "unknown location (relative path)"
 
@@ -283,8 +283,8 @@ let one_request
         match resp.status with
         | `Moved_permanently | `Found | `See_other | `Temporary_redirect ->
           (match Headers.get resp.headers "location" with
-           | Some loc ->
-             let uri = resolve_location uri loc in
+           | Some location ->
+             let uri = resolve_location ~uri ~location in
              Logs.debug (fun m -> m "following redirect to %s" uri);
              follow_redirect (pred count) uri
            | None -> Lwt_result.return (resp, body))
diff --git a/src/http_lwt_client.mli b/src/http_lwt_client.mli
index a04a3ab..2ade586 100644
--- a/src/http_lwt_client.mli
+++ b/src/http_lwt_client.mli
@@ -12,6 +12,8 @@ type response =
 
 val pp_response : Format.formatter -> response -> unit
 
+val resolve_location : uri:string -> location:string -> string
+
 val one_request
   : ?config : [ `HTTP_1_1 of Httpaf.Config.t | `H2 of H2.Config.t ]
   -> ?authenticator:X509.Authenticator.t