First PoC about a native HTTP client on Mirage with mimic/paf/httpaf/h2

mirage/config.ml

@@ -1,11 +1,7 @@
 open Mirage
 
-type paf = Paf
+type http_client = HTTP_client
-let paf = typ Paf
+let http_client = typ HTTP_client
-
-let paf_conf () =
-  let packages = [ package "paf" ~sublibs:[ "mirage" ] ] in
-  impl ~packages "Paf_mirage.Make" (time @-> tcpv4v6 @-> paf)
 
 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" ;
-      package "paf-cohttp" ~min:"0.0.7" ;
+      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)
+    (kv_rw @-> time @-> pclock @-> stackv4v6 @-> git_client @-> http_client @-> job)
-
-let paf time stackv4v6 = paf_conf () $ time $ tcpv4v6_of_stackv4v6 stackv4v6
 
 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 http_client =
-  let git = git_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) in
+  let connect _ modname = function
-  merge_git_clients (git_tcp tcp git)
+    | [ _time; _pclock; _tcpv4v6; ctx ] ->
-    (git_http ~authenticator:tls_authenticator tcp git)
+      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 ]

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

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

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. *)
+  (_ : sig end)
-  (Paf : Paf_mirage.S with type stack = Stack.TCP.t and type ipaddr = Ipaddr.t)
+  (HTTP : Http_mirage_client.S) = struct
-  (_ : sig end) = 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 =
+  let one_request = Http_mirage_client.one_request ~alpn_protocol:HTTP.alpn_protocol
-    match String.split_on_char '/' location with
+    ~authenticator:HTTP.authenticator
-    | "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 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
+            one_request ~ctx:http_ctx url >>= function
-            | Some str ->
+            | 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