From 236e09b7e07ca8e217ec84e598cbf530fe91635d Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 29 Aug 2022 18:32:32 +0200 Subject: [PATCH] First PoC about a native HTTP client on Mirage with mimic/paf/httpaf/h2 --- mirage/config.ml | 41 +++-- mirage/http_mirage_client.ml | 338 ++++++++++++++++++++++++++++++++++ mirage/http_mirage_client.mli | 35 ++++ mirage/unikernel.ml | 115 +----------- 4 files changed, 406 insertions(+), 123 deletions(-) create mode 100644 mirage/http_mirage_client.ml create mode 100644 mirage/http_mirage_client.mli diff --git a/mirage/config.ml b/mirage/config.ml index 63f8dce..b4cc42a 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -1,11 +1,7 @@ open Mirage -type paf = Paf -let paf = typ Paf - -let paf_conf () = - let packages = [ package "paf" ~sublibs:[ "mirage" ] ] in - impl ~packages "Paf_mirage.Make" (time @-> tcpv4v6 @-> paf) +type http_client = HTTP_client +let http_client = typ HTTP_client let remote = let doc = Key.Arg.info @@ -26,15 +22,14 @@ let mirror = foreign "Unikernel.Make" ~keys:[ Key.v remote ; Key.v tls_authenticator ] ~packages:[ - package "paf" ~min:"0.0.9" ; - package "paf-cohttp" ~min:"0.0.7" ; + package "paf" ; + package "h2" ; + package "httpaf" ; package ~min:"3.0.0" "irmin-mirage-git" ; package ~min:"3.7.0" "git-paf" ; package "opam-file-format" ; ] - (kv_rw @-> time @-> pclock @-> stackv4v6 @-> dns_client @-> paf @-> git_client @-> job) - -let paf time stackv4v6 = paf_conf () $ time $ tcpv4v6_of_stackv4v6 stackv4v6 + (kv_rw @-> time @-> pclock @-> stackv4v6 @-> git_client @-> http_client @-> job) let stack = generic_stackv4v6 default_network @@ -42,10 +37,24 @@ let dns = generic_dns_client stack let tcp = tcpv4v6_of_stackv4v6 stack -let git_client = - let git = git_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) in - merge_git_clients (git_tcp tcp git) - (git_http ~authenticator:tls_authenticator tcp git) +let http_client = + let connect _ modname = function + | [ _time; _pclock; _tcpv4v6; ctx ] -> + Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx + | _ -> assert false in + impl ~connect "Http_mirage_client.Make" + (time @-> pclock @-> tcpv4v6 @-> git_client @-> http_client) +(* XXX(dinosaure): [git_client] seems bad but it becames from a long discussion + when a "mimic" device seems not accepted by everyone. We can copy [git_happy_eyeballs] + and provide an [http_client] instead of a [git_client] but that mostly means that + 2 instances of happy-eyeballs will exists together which is not really good + (it puts a pressure on the scheduler). *) + +let git_client, http_client = + let happy_eyeballs = git_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) in + merge_git_clients (git_tcp tcp happy_eyeballs) + (git_http ~authenticator:tls_authenticator tcp happy_eyeballs), + http_client $ default_time $ default_posix_clock $ tcp $ happy_eyeballs let program_block_size = let doc = Key.Arg.info [ "program-block-size" ] in @@ -56,4 +65,4 @@ let kv_rw = chamelon ~program_block_size block let () = register "mirror" - [ mirror $ kv_rw $ default_time $ default_posix_clock $ stack $ dns $ paf default_time stack $ git_client ] + [ mirror $ kv_rw $ default_time $ default_posix_clock $ stack $ git_client $ http_client ] diff --git a/mirage/http_mirage_client.ml b/mirage/http_mirage_client.ml new file mode 100644 index 0000000..b00b8c2 --- /dev/null +++ b/mirage/http_mirage_client.ml @@ -0,0 +1,338 @@ +let http_scheme = Mimic.make ~name:"http-scheme" +let http_port = Mimic.make ~name:"http-port" +let http_hostname = Mimic.make ~name:"http-hostname" +let http_sleep = Mimic.make ~name:"http-sleep" +let tls_config = Mimic.make ~name:"tls-config" + +open Lwt.Infix + +module type S = sig + val connect : Mimic.ctx -> Mimic.ctx Lwt.t + val alpn_protocol : Mimic.flow -> string option + val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result +end + +module Make + (Time : Mirage_time.S) + (Pclock : Mirage_clock.PCLOCK) + (TCP : Tcpip.Tcp.S) + (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct + module TCP = struct + include TCP + type endpoint = Happy_eyeballs.t * string * int + type nonrec write_error = + [ `Write of write_error | `Connect of string | `Closed ] + let pp_write_error ppf = function + | `Connect err -> Fmt.string ppf err + | `Write err -> pp_write_error ppf err + | `Closed as err -> pp_write_error ppf err + + let write flow cs = + let open Lwt.Infix in + write flow cs >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let writev flow css = + writev flow css >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let connect (happy_eyeballs, hostname, port) = + Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function + | Error (`Msg err) -> Lwt.return_error (`Connect err) + | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow + end + + let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP) + + module TLS = struct + type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int + + include Tls_mirage.Make (TCP) + + let connect (happy_eyeballs, cfg, hostname, port) = + let peer_name = + Result.(to_option (bind (Domain_name.of_string hostname) Domain_name.host)) in + Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function + | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow + | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err)) + end + + let tls_edn, tls_protocol = + Mimic.register ~name:"tls" (module TLS) + + let connect ctx = + let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with + | "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port) + | _ -> Lwt.return_none in + let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = match http_scheme with + | "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port) + | _ -> Lwt.return_none in + let ctx = Mimic.fold tcp_edn + Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs + ; req http_scheme; req http_hostname; dft http_port 80 ] + ~k:k0 ctx in + let ctx = Mimic.fold tls_edn + Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs + ; req http_scheme; req http_hostname; dft http_port 443 + ; req tls_config ] + ~k:k1 ctx in + Lwt.return (Mimic.add http_sleep Time.sleep_ns ctx) + + let alpn_protocol flow = + let module M = (val (Mimic.repr tls_protocol)) in + match flow with + | M.T flow -> + ( match TLS.epoch flow with + | Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol + | Error _ -> None ) + | _ -> None + + let authenticator = + let module V = Ca_certs_nss.Make (Pclock) in + V.authenticator () +end + +module Version = Httpaf.Version +module Status = H2.Status +module Headers = H2.Headers + +type response = + { version : Version.t + ; status : Status.t + ; reason : string + ; headers : Headers.t } + +module HTTP_1_1 = struct + include Httpaf.Client_connection + let yield_reader _ = assert false + let next_read_operation t = + (next_read_operation t :> [ `Close | `Read | `Yield ]) +end + +let add_authentication ~add headers = function + | None -> headers + | Some (user, pass) -> + let data = Base64.encode_string (user ^ ":" ^ pass) in + add headers "authorization" ("Basic " ^ data) + +let prepare_http_1_1_headers headers host user_pass body_length = + let headers = Httpaf.Headers.of_list headers in + let add = Httpaf.Headers.add_unless_exists in + let headers = add headers "user-agent" ("http-mirage-client/%%VERSION%%") in + let headers = add headers "host" host in + let headers = add headers "connection" "close" in + let headers = match body_length with + | None -> headers + | Some v -> add headers "content-length" (string_of_int v) in + add_authentication ~add headers user_pass + +let single_http_1_1_request ~sleep ?config flow user_pass host meth path headers body = + let body_length = Option.map String.length body in + let headers = prepare_http_1_1_headers headers host user_pass body_length in + let req = Httpaf.Request.create ~headers meth path in + let finished, notify_finished = Lwt.wait () in + let wakeup = let w = ref false in + fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in + let response_handler response body = + let buf = Buffer.create 0x100 in + let rec on_eof () = + let response = + { version= response.Httpaf.Response.version + ; status = (response.Httpaf.Response.status :> H2.Status.t) + ; reason = response.Httpaf.Response.reason + ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in + wakeup (Ok (response, Some (Buffer.contents buf))) + and on_read ba ~off ~len = + Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ; + Httpaf.Body.schedule_read body ~on_read ~on_eof in + let on_eof () = + let response = + { version= response.Httpaf.Response.version + ; status = (response.Httpaf.Response.status :> H2.Status.t) + ; reason = response.Httpaf.Response.reason + ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in + wakeup (Ok (response, None)) in + Httpaf.Body.schedule_read body ~on_read ~on_eof in + let error_handler e = + let err = match e with + | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x)) + | `Invalid_response_body_length _ -> Error (`Msg ("Invalid response body length")) + | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in + wakeup err in + let request_body, conn = Httpaf.Client_connection.request ?config req ~error_handler + ~response_handler in + Lwt.async (fun () -> Paf.run (module HTTP_1_1) ~sleep conn flow) ; + Option.iter (Httpaf.Body.write_string request_body) body ; + Httpaf.Body.close_writer request_body ; + finished + +let prepare_h2_headers headers host user_pass body_length = + let headers = H2.Headers.of_list headers in + let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in + let headers = add headers ":authority" host in + let headers = add headers "content-length" (string_of_int (Option.value ~default:0 body_length)) in + add_authentication ~add headers user_pass + +let single_h2_request ~sleep ?config ~scheme flow user_pass host meth path headers body = + let body_length = Option.map String.length body in + let headers = prepare_h2_headers headers host user_pass body_length in + let req = H2.Request.create ~scheme ~headers meth path in + let finished, notify_finished = Lwt.wait () in + let wakeup = let w = ref false in + fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in + let response_handler response response_body = + let buf = Buffer.create 0x100 in + let rec on_eof () = + let response = + { version= { major= 2; minor= 0; } + ; status = response.H2.Response.status + ; reason = "" + ; headers= response.H2.Response.headers } in + wakeup (Ok (response, Some (Buffer.contents buf))) + and on_read ba ~off ~len = + Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ; + H2.Body.Reader.schedule_read response_body + ~on_read ~on_eof in + let on_eof () = + let response = + { version= { major= 2; minor= 0; } + ; status = response.H2.Response.status + ; reason = "" + ; headers= response.H2.Response.headers } in + wakeup (Ok (response, None)) in + H2.Body.Reader.schedule_read response_body + ~on_read ~on_eof in + let error_handler e = + let err = match e with + | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x)) + | `Invalid_response_body_length _ -> Error (`Msg "Invalid response body length") + | `Protocol_error (err, msg) -> + let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in + Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum err msg + | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in + wakeup err in + let conn = H2.Client_connection.create ?config ?push_handler:None + ~error_handler in + let request_body = H2.Client_connection.request conn req ~error_handler ~response_handler in + Lwt.async (fun () -> Paf.run (module H2.Client_connection) ~sleep conn flow) ; + Option.iter (H2.Body.Writer.write_string request_body) body ; + H2.Body.Writer.close request_body ; + finished + +let decode_uri ~ctx uri = + let ( >>= ) = Result.bind in + match String.split_on_char '/' uri with + | proto :: "" :: user_pass_host_port :: path -> + ( if String.equal proto "http:" + then Ok ("http", Mimic.add http_scheme "http" ctx) + else if String.equal proto "https:" + then Ok ("https", Mimic.add http_scheme "https" ctx) + else Error (`Msg "Couldn't decode user and password") ) >>= fun (scheme, ctx) -> + let decode_user_pass up = match String.split_on_char ':' up with + | [ user; pass; ] -> Ok (user, pass) + | _ -> Error (`Msg "Couldn't decode user and password") in + ( match String.split_on_char '@' user_pass_host_port with + | [ host_port ] -> Ok (None, host_port) + | [ user_pass; host_port ] -> + decode_user_pass user_pass >>= fun up -> + Ok (Some up, host_port) + | _ -> Error (`Msg "Couldn't decode URI") ) >>= fun (user_pass, host_port) -> + ( match String.split_on_char ':' host_port with + | [] -> Error (`Msg "Empty host & port") + | [ hostname ] -> Ok (hostname, Mimic.add http_hostname hostname ctx) + | hd :: tl -> + let port, hostname = match List.rev (hd :: tl) with + | hd :: tl -> hd, String.concat ":" (List.rev tl) + | _ -> assert false in + ( try Ok (hostname, Mimic.add http_hostname hostname (Mimic.add http_port (int_of_string port) ctx)) + with Failure _ -> Error (`Msg "Couldn't decode port") ) ) >>= fun (hostname, ctx) -> + Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path) + | _ -> Error (`Msg "Couldn't decode URI on top") + +let ( >>? ) = Lwt_result.bind + +let alpn_protocol_of_string = function + | "http/1.1" -> Some `HTTP_1_1 + | "h2" -> Some `H2 + | _ -> None + +let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri = + let sleep = Option.get (Mimic.get http_sleep ctx) in + Lwt.return (decode_uri ~ctx uri) >>? fun (ctx, scheme, host, user_pass, path) -> + let ctx = match Lazy.force cfg with + | Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx + | Ok (`Default cfg) -> + ( match Result.bind (Domain_name.of_string host) Domain_name.host with + | Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx + | Error _ -> Mimic.add tls_config cfg ctx ) + | Error _ -> ctx in + Mimic.resolve ctx >>? fun flow -> + match Option.bind (alpn_protocol flow) alpn_protocol_of_string, config with + | (Some `HTTP_1_1 | None), Some (`HTTP_1_1 config) -> + single_http_1_1_request ~sleep ~config flow user_pass host meth path headers body + | (Some `HTTP_1_1 | None), None -> + single_http_1_1_request ~sleep flow user_pass host meth path headers body + | (Some `H2 | None), Some (`H2 config) -> + single_h2_request ~sleep ~config ~scheme flow user_pass host meth path headers body + | Some `H2, None -> + single_h2_request ~sleep ~scheme flow user_pass host meth path headers body + | Some `H2, (Some (`HTTP_1_1 _)) -> + single_h2_request ~sleep ~scheme flow user_pass host meth path headers body + | Some `HTTP_1_1, Some (`H2 _) -> + single_http_1_1_request ~sleep flow user_pass host meth path headers body + +let tls_config ?tls_config ?config authenticator = + lazy ( match tls_config with + | Some cfg -> Ok (`Custom cfg) + | None -> + let alpn_protocols = match config with + | None -> [ "h2"; "http/1.1" ] + | Some (`H2 _) -> [ "h2" ] + | Some (`HTTP_1_1 _) -> [ "http/1.1" ] in + Result.map (fun authenticator -> `Default (Tls.Config.client ~alpn_protocols ~authenticator ())) authenticator ) + +let resolve_location ~uri ~location = + match String.split_on_char '/' location with + | "http:" :: "" :: _ -> Ok location + | "https:" :: "" :: _ -> Ok location + | "" :: "" :: _ -> + let schema = String.sub uri 0 (String.index uri '/') in + Ok (schema ^ location) + | "" :: _ -> + (match String.split_on_char '/' uri with + | schema :: "" :: user_pass_host_port :: _ -> + Ok (String.concat "/" [schema ; "" ; user_pass_host_port ^ location]) + | _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri))) + | _ -> Error (`Msg ("unknown location (relative path): " ^ location)) + +let one_request + ?config + ?tls_config:cfg + ~ctx + ~alpn_protocol + ~authenticator + ?(meth= `GET) + ?(headers= []) + ?body + ?(max_redirect= 5) + ?(follow_redirect= true) uri = + let tls_config = tls_config ?tls_config:cfg ?config authenticator in + if not follow_redirect + then single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri + else + let rec follow_redirect count uri = + if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded") + else + single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri + >>? fun (resp, body) -> + match resp.status with + | #Status.redirection -> + ( match Headers.get resp.headers "location" with + | Some location -> + Lwt.return (resolve_location ~uri ~location) >>? fun uri -> + follow_redirect (pred count) uri + | None -> Lwt.return_ok (resp, body) ) + | _ -> Lwt.return_ok (resp, body) in + follow_redirect max_redirect uri diff --git a/mirage/http_mirage_client.mli b/mirage/http_mirage_client.mli new file mode 100644 index 0000000..eaa7878 --- /dev/null +++ b/mirage/http_mirage_client.mli @@ -0,0 +1,35 @@ +module type S = sig + val connect : Mimic.ctx -> Mimic.ctx Lwt.t + val alpn_protocol : Mimic.flow -> string option + val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result +end + +module Make + (Time : Mirage_time.S) + (Pclock : Mirage_clock.PCLOCK) + (TCP : Tcpip.Tcp.S) + (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S + +module Version = Httpaf.Version +module Status = H2.Status +module Headers = H2.Headers + +type response = + { version : Version.t + ; status : Status.t + ; reason : string + ; headers : Headers.t } + +val one_request : + ?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] -> + ?tls_config:Tls.Config.client -> + ctx:Mimic.ctx -> + alpn_protocol:(Mimic.flow -> string option) -> + authenticator:(X509.Authenticator.t, [> `Msg of string ]) result -> + ?meth:Httpaf.Method.t -> + ?headers:(string * string) list -> + ?body:string -> + ?max_redirect:int -> + ?follow_redirect:bool -> + string -> + (response * string option, [> Mimic.error ]) result Lwt.t diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index 5ceb576..d8950e8 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -14,60 +14,12 @@ module Make (Time : Mirage_time.S) (Pclock : Mirage_clock.PCLOCK) (Stack : Tcpip.Stack.V4V6) - (Dns : DNS) (* XXX(dinosaure): ask @hannesm to provide a signature. *) - (Paf : Paf_mirage.S with type stack = Stack.TCP.t and type ipaddr = Ipaddr.t) - (_ : sig end) = struct + (_ : sig end) + (HTTP : Http_mirage_client.S) = struct module Store = Irmin_mirage_git.Mem.KV.Make(Irmin.Contents.String) module Sync = Irmin.Sync.Make(Store) - module Client = Paf_cohttp - module Nss = Ca_certs_nss.Make(Pclock) - - let authenticator = Result.get_ok (Nss.authenticator ()) - let default_tls_cfg = Tls.Config.client ~authenticator () - - let stack = Mimic.make ~name:"stack" - let tls = Mimic.make ~name:"tls" - - let with_stack v ctx = Mimic.add stack (Stack.tcp v) ctx - - let with_tcp ctx = - let k scheme stack ipaddr port = - match scheme with - | `HTTP -> Lwt.return_some (stack, ipaddr, port) - | _ -> Lwt.return_none - in - Mimic.(fold Paf.tcp_edn Fun.[ req Client.scheme - ; req stack - ; req Client.ipaddr - ; dft Client.port 80 ] ~k ctx) - - let with_tls ctx = - let k scheme domain_name cfg stack ipaddr port = - match scheme with - | `HTTPS -> Lwt.return_some (domain_name, cfg, stack, ipaddr, port) - | _ -> Lwt.return_none - in - Mimic.(fold Paf.tls_edn Fun.[ req Client.scheme - ; opt Client.domain_name - ; dft tls default_tls_cfg - ; req stack - ; req Client.ipaddr - ; dft Client.port 443 ] ~k ctx) - - let dns = Mimic.make ~name:"dns" - - let with_dns v ctx = Mimic.add dns v ctx - let with_sleep ctx = Mimic.add Paf_cohttp.sleep Time.sleep_ns ctx - - let with_resolv ctx = - let k dns domain_name = - Dns.gethostbyname dns domain_name >>= function - | Ok ipv4 -> Lwt.return_some (Ipaddr.V4 ipv4) - | _ -> Lwt.return_none in - Mimic.(fold Client.ipaddr Fun.[ req dns; req Client.domain_name ] ~k ctx) - module SM = Map.Make(String) module HM = Map.Make(struct @@ -406,21 +358,10 @@ module Make Error `Not_found end - let resolve_location ~uri ~location = - match String.split_on_char '/' location with - | "http:" :: "" :: _ -> Ok location - | "https:" :: "" :: _ -> Ok location - | "" :: "" :: _ -> - let schema = String.sub uri 0 (String.index uri '/') in - Ok (schema ^ location) - | "" :: _ -> - (match String.split_on_char '/' uri with - | schema :: "" :: user_pass_host_port :: _ -> - Ok (String.concat "/" [schema ; "" ; user_pass_host_port ^ location]) - | _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri))) - | _ -> Error (`Msg ("unknown location (relative path): " ^ location)) + let one_request = Http_mirage_client.one_request ~alpn_protocol:HTTP.alpn_protocol + ~authenticator:HTTP.authenticator - let start kv _time _pclock stack dns _paf_cohttp git_ctx = + let start kv _time _pclock stack git_ctx http_ctx = Git.connect git_ctx >>= fun (store, upstream) -> Git.pull store upstream >>= function | Error `Msg msg -> Lwt.fail_with msg @@ -428,46 +369,6 @@ module Make Logs.info (fun m -> m "git: %s" msg); Git.find_urls store >>= fun urls -> Disk.init kv >>= fun disk -> - let ctx = - Mimic.empty - |> with_sleep - |> with_tcp (* stack -> ipaddr -> port => (stack * ipaddr * port) *) - |> with_tls (* domain_name -> tls -> stack -> ipaddr -> port => (domain_name * tls * stack * ipaddr * port) *) - |> with_resolv (* domain_name => ipaddr *) - |> with_stack stack (* stack *) - |> with_dns dns (* dns *) in - let rec follow count uri = - if count = 0 then begin - Logs.err (fun m -> m "redirection limit exceeded"); - Lwt.return None - end else begin - Logs.info (fun m -> m "retrieving %s" uri); - Client.get ~ctx (Uri.of_string uri) >>= fun (resp, body) -> - match resp.Cohttp.Response.status with - | `OK -> - Cohttp_lwt.Body.to_string body >|= fun str -> - Some str - | #Cohttp.Code.redirection_status -> - begin match Cohttp.Header.get resp.Cohttp.Response.headers "location" with - | Some location -> - begin match resolve_location ~uri ~location with - | Error `Msg msg -> - Logs.err (fun m -> m "error %s resolving redirect location %s" - msg location); - Lwt.return None - | Ok new_uri -> follow (pred count) new_uri - end - | None -> - Logs.err (fun m -> m "redirect without location"); - Lwt.return None - end - | s -> - Logs.err (fun m -> m "error %s while fetching %s" - (Cohttp.Code.string_of_status resp.Cohttp.Response.status) - uri); - Lwt.return None - end - in Lwt_list.iter_p (fun (url, csums) -> HM.fold (fun h v r -> r >>= function @@ -478,11 +379,11 @@ module Make Logs.info (fun m -> m "ignoring %s (already present)" url); Lwt.return_unit | false -> - follow 20 url >>= function - | Some str -> + one_request ~ctx:http_ctx url >>= function + | Ok (resp, Some str) -> Logs.info (fun m -> m "writing (%d)" (String.length str)); Disk.write disk str csums - | None -> Lwt.return_unit) + | _ -> Lwt.return_unit) (SM.bindings urls) >|= fun () -> Logs.info (fun m -> m "done") end