Skip to content

Commit f77980a

Browse files
rr0girr0gi
authored
web: expose http_request_k (#58)
1 parent 4efc8ba commit f77980a

1 file changed

Lines changed: 82 additions & 63 deletions

File tree

‎web.ml‎

Lines changed: 82 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -120,9 +120,9 @@ module type CURL = sig
120120
end
121121

122122
type ('body,'ret) http_request_ =
123+
?verbose:bool ->
123124
?ua:string ->
124125
?timeout:int ->
125-
?verbose:bool ->
126126
?setup:(Curl.t -> unit) ->
127127
?timer:Action.timer ->
128128
?max_size:int ->
@@ -141,30 +141,53 @@ module type HTTP = sig
141141
type ('body,'ret) request_ = ('body,'ret IO.t) http_request_
142142
type 'ret request = 'ret IO.t http_request
143143

144-
val http_request' : [> `Error of Curl.curlCode | `Ok of int * string ] request
145-
val http_request : [> `Error of string | `Ok of string ] request
144+
(** this is the most general form, pass [result] callback to massage the result before returning from the function
145+
e.g. if you need the redirect url in case of 3xx, do [http_request_k ~result:http_result] *)
146+
val http_request_k : result:(Curl.t * (int * string, Curl.curlCode) result -> 'r) -> 'r request
147+
148+
(** this is the most straightforward result of http status code and content or error code *)
149+
val http_request' : [ `Error of Curl.curlCode | `Ok of int * string ] request
150+
151+
(** even easier - content on HTTP 2xx or error message *)
152+
val http_request : [ `Error of string | `Ok of string ] request
153+
154+
(** same as {!http_request} but raise exception on non-2xx *)
146155
val http_request_exn : string request
147-
val http_query : (string * string, [> `Error of string | `Ok of string ]) request_
156+
157+
(** send GET with a given content-type and body *)
158+
val http_query : (string * string, [ `Error of string | `Ok of string ]) request_
159+
160+
(** send POST with key-value form parameters *)
148161
val http_submit :
162+
?verbose:bool ->
149163
?ua:string ->
150164
?timeout:int ->
151-
?verbose:bool ->
152165
?setup:(Curl.t -> unit) ->
153166
?timer:Action.timer ->
154167
?http_1_0:bool ->
155168
?headers:string list ->
156169
?action:http_action ->
157170
string ->
158-
(string * string) list -> [> `Error of string | `Ok of string ] IO.t
171+
(string * string) list -> [ `Error of string | `Ok of string ] IO.t
159172
end
160173

161174
let show_result ?(verbose=false) = function
162-
| `Error code -> sprintf "(%d) %s" (Curl.errno code) (Curl.strerror code)
163-
| `Ok (n, content) -> sprintf "http %d%s" n (if verbose then ": " ^ content else "")
164-
165-
let simple_result ?(is_ok=(fun code -> code / 100 = 2)) ?verbose = function
166-
| `Ok (code, s) when is_ok code -> `Ok s
167-
| r -> `Error (show_result ?verbose r)
175+
| Error code -> sprintf "(%d) %s" (Curl.errno code) (Curl.strerror code)
176+
| Ok (n, content) -> sprintf "http %d%s" n (if verbose then ": " ^ content else "")
177+
178+
let simple_result ?verbose (_,r) =
179+
match r with
180+
| Ok (n,s) when n / 100 = 2 -> `Ok s
181+
| r -> `Error (show_result ?verbose r)
182+
183+
let http_result ?verbose (h,r) =
184+
match r with
185+
| Error _ -> `Error (show_result ?verbose r)
186+
| Ok (n,(s:string)) ->
187+
match n/100 with
188+
| 2 -> `Ok (n,s)
189+
| 3 -> `Redirect (n, Curl.get_redirecturl h)
190+
| _ -> `Http (n,s)
168191

169192
let nr_http = ref 0
170193

@@ -190,6 +213,7 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
190213
"server.address", `String (Curl.get_primaryip h);
191214
(* NOTE: this crashes with
192215
exn File "curl.ml", line 1365, characters 9-15: Assertion failed
216+
before ocurl 0.11.0
193217
"network.protocol.version", `String (match Curl.get_http_version h with
194218
| HTTP_VERSION_1_0 -> "1.0" | HTTP_VERSION_1_1 -> "1.1"
195219
| HTTP_VERSION_2 | HTTP_VERSION_2TLS | HTTP_VERSION_2_PRIOR_KNOWLEDGE -> "2"
@@ -210,33 +234,27 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
210234
()
211235

212236
(* deprecated *)
213-
let http_gets ?(setup=ignore) ?timer ?max_size ?(check=(fun _ -> true)) ?(result=(fun _ _ -> return_unit)) url =
237+
let http_gets ~setup ?timer ?max_size ~result url =
214238
with_curl_cache begin fun h ->
215239
Curl.set_url h url;
216240
curl_default_setup h;
217-
let () = setup h in
241+
setup h;
218242
let b = Buffer.create 10 in
219243
let read_size = ref 0 in
220244
Curl.set_writefunction h begin fun s ->
221-
match check h with
222-
| false -> 0
223-
| true ->
224-
Buffer.add_string b s;
225-
let l = String.length s in
226-
read_size += l;
227-
match max_size with
228-
| Some max_size when !read_size > max_size -> Exn.fail "received too much data (%db) when max is %db" !read_size max_size
229-
| _ -> l
245+
Buffer.add_string b s;
246+
let l = String.length s in
247+
read_size += l;
248+
match max_size with
249+
| Some max_size when !read_size > max_size -> Exn.fail "received too much data (%db) when max is %db" !read_size max_size
250+
| _ -> l
230251
end;
231252
timer |> Option.may (fun t -> t#mark "Web.http");
232253
catch (fun () -> Curl_IO.perform h) (fun exn -> update_timer h timer; IO.raise exn) >>= fun code ->
233-
(update_timer h timer; result h code) >>= fun () ->
234-
return @@ match code with
235-
| Curl.CURLE_OK -> `Ok (Curl.get_httpcode h, Buffer.contents b)
236-
| code -> `Error code
254+
(update_timer h timer; return @@ result (h,match code with CURLE_OK -> Ok (Curl.get_httpcode h, Buffer.contents b) | err -> Error err))
237255
end
238256

239-
let verbose_curl_result_plain nr_http action t h code =
257+
let verbose_curl_result_plain nr_http action t (h,r) =
240258
let open Curl in
241259
let b = Buffer.create 10 in
242260
bprintf b "%s #%d %s ⇓%s ⇑%s %s "
@@ -245,9 +263,9 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
245263
(Action.bytes_string_f @@ get_sizeupload h)
246264
(get_primaryip h)
247265
;
248-
begin match code with
249-
| CURLE_OK ->
250-
bprintf b "HTTP %d %s" (get_httpcode h) (get_effectiveurl h);
266+
begin match r with
267+
| Ok (code,_) ->
268+
bprintf b "HTTP %d %s" code (get_effectiveurl h);
251269
begin match get_redirecturl h with
252270
| "" -> ()
253271
| s -> bprintf b " -> %s" s
@@ -256,12 +274,12 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
256274
| 0 -> ()
257275
| n -> bprintf b " after %d redirects" n
258276
end
259-
| _ ->
277+
| Error code ->
260278
bprintf b "error (%d) %s (errno %d)" (errno code) (strerror code) (Curl.get_oserrno h)
261279
end;
262280
log #info_s (Buffer.contents b)
263281

264-
let verbose_curl_result_logfmt nr_http action t h code =
282+
let verbose_curl_result_logfmt nr_http action t (h,r) =
265283
let open Curl in
266284
let size_down = get_sizedownload h in
267285
let size_up = get_sizeupload h in
@@ -279,13 +297,13 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
279297
| 0 -> base
280298
| n -> ("http_status", string_of_int n) :: base
281299
in
282-
match code with
283-
| CURLE_OK ->
300+
match r with
301+
| Ok _ ->
284302
let pairs = ("url", get_effectiveurl h) :: base in
285303
let pairs = match get_redirecturl h with "" -> pairs | s -> ("redirect", s) :: pairs in
286304
let pairs = match get_redirectcount h with 0 -> pairs | n -> ("redirect_count", string_of_int n) :: pairs in
287305
log #info ~pairs "http done"
288-
| _ ->
306+
| Error code ->
289307
let pairs =
290308
("err", strerror code) ::
291309
("errno", string_of_int (errno code)) ::
@@ -294,10 +312,10 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
294312
in
295313
log #info ~pairs "http error"
296314

297-
let verbose_curl_result nr_http action t h code =
315+
let verbose_curl_result nr_http action t hr =
298316
match Log.State.get_cur_format () with
299-
| `Plain, _ -> verbose_curl_result_plain nr_http action t h code
300-
| `Logfmt, _ -> verbose_curl_result_logfmt nr_http action t h code
317+
| `Plain, _ -> verbose_curl_result_plain nr_http action t hr
318+
| `Logfmt, _ -> verbose_curl_result_logfmt nr_http action t hr
301319

302320
(* Given a list of strings, check pre-existing entry starting with `~name`; and adds the concatenation of `~name` and `~value` if not. *)
303321
let add_if_absent ~name ~value strs =
@@ -308,7 +326,7 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
308326

309327
(* NOTE don't forget to set http_1_0=true when sending requests to a Httpev-based server *)
310328
(* Don't use curl_setheaders when using ?headers option *)
311-
let http_request' ?ua ?timeout ?(verbose=false) ?(setup=ignore) ?timer ?max_size ?(http_1_0=false) ?headers ?body (action:http_action) url =
329+
let http_request_k ~result ?(verbose=false) ?ua ?timeout ?(setup=ignore) ?timer ?max_size ?(http_1_0=false) ?headers ?body (action:http_action) url =
312330
let open Curl in
313331
let action_name = string_of_http_action action in
314332
let ch_query_id = ref None in
@@ -382,7 +400,7 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
382400
let span_name = Printf.sprintf "devkit.web.%s" action_name in
383401
(* We set the value of `__FUNCTION__` to preserve the build with OCaml < 4.12. *)
384402
Possibly_otel.enter_manual_span
385-
~__FUNCTION__:"Devkit.Web.Http.http_request'" ~__FILE__ ~__LINE__ ~data:describe span_name in
403+
~__FUNCTION__:"Devkit.Web.Http.http_request_k" ~__FILE__ ~__LINE__ ~data:describe span_name in
386404

387405
let headers = match Possibly_otel.Traceparent.get_ambient ~explicit_span () with
388406
| None -> headers
@@ -396,38 +414,37 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
396414
in
397415

398416
let t = new Action.timer in
399-
let result = Some (fun h code ->
400-
if verbose then verbose_curl_result nr_http action t h code;
401-
if Trace_core.enabled () then (
417+
let result (h,_ as res) =
418+
if verbose then verbose_curl_result nr_http action t res;
419+
if Trace_core.enabled () then
420+
begin
402421
let data = get_curl_data h in
403-
let data = match !ch_query_id with None -> data
404-
| Some v -> ("http.response.header.x-clickhouse-query-id", `String v) :: data in
405-
let data = match !ch_summary with None -> data
406-
| Some v -> ("http.response.header.x-clickhouse-summary", `String v) :: data in
407-
let data = match !resp_content_encoding with None -> data
408-
| Some v -> ("http.response.header.content-encoding", `String v) :: data in
422+
let data = match !ch_query_id with None -> data | Some v -> ("http.response.header.x-clickhouse-query-id", `String v) :: data in
423+
let data = match !ch_summary with None -> data | Some v -> ("http.response.header.x-clickhouse-summary", `String v) :: data in
424+
let data = match !resp_content_encoding with None -> data | Some v -> ("http.response.header.content-encoding", `String v) :: data in
409425
Trace_core.add_data_to_span explicit_span data
410-
);
426+
end;
411427
Trace_core.exit_span explicit_span;
412-
return ()
413-
) in
428+
result res
429+
in
430+
431+
http_gets ~setup:(setup ~headers set_body_and_headers) ?timer ?max_size ~result url
414432

415-
http_gets ~setup:(setup ~headers set_body_and_headers) ?timer ?result ?max_size url
433+
(* could be [~result:snd], but need to keep compatibility *)
434+
let http_request' = http_request_k ~result:(function (_,Ok x) -> `Ok x | (_,Error e) -> `Error e)
416435

417-
let http_request ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
418-
http_request' ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url >>= fun res ->
419-
return @@ simple_result ?verbose res
436+
let http_request ?verbose = http_request_k ?verbose ~result:(simple_result ?verbose)
420437

421-
let http_request_exn ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
422-
http_request ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url
438+
let http_request_exn ?verbose ?ua ?timeout ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
439+
http_request ?verbose ?ua ?timeout ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url
423440
>>= function `Ok s -> return s | `Error error -> fail "%s" error
424441

425-
let http_query ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
442+
let http_query ?verbose ?ua ?timeout ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
426443
let body = match body with Some (ct,s) -> Some (`Raw (ct,s)) | None -> None in
427-
http_request ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url
444+
http_request ?verbose ?ua ?timeout ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url
428445

429-
let http_submit ?ua ?timeout ?verbose ?setup ?timer ?http_1_0 ?headers ?(action=`POST) url args =
430-
http_request ?ua ?timeout ?verbose ?setup ?timer ?http_1_0 ?headers ~body:(`Form args) action url
446+
let http_submit ?verbose ?ua ?timeout ?setup ?timer ?http_1_0 ?headers ?(action=`POST) url args =
447+
http_request ?verbose ?ua ?timeout ?setup ?timer ?http_1_0 ?headers ~body:(`Form args) action url
431448

432449
end
433450

@@ -471,6 +488,7 @@ end
471488
module Http_blocking = Http(IO_blocking)(Curl_blocking)
472489
module Http_lwt = Http(IO_lwt)(Curl_lwt_for_http)
473490

491+
(* there is also Http_blocking.http_request_k *)
474492
let with_curl = Http_blocking.with_curl
475493
let with_curl_cache = Http_blocking.with_curl_cache
476494
let http_request' = Http_blocking.http_request'
@@ -479,6 +497,7 @@ let http_request_exn = Http_blocking.http_request_exn
479497
let http_query = Http_blocking.http_query
480498
let http_submit = Http_blocking.http_submit
481499

500+
(* there is also Http_lwt.http_request_k *)
482501
let http_request_lwt' = Http_lwt.http_request'
483502
let http_request_lwt = Http_lwt.http_request
484503
let http_request_lwt_exn = Http_lwt.http_request_exn

0 commit comments

Comments
 (0)