package cohttp-mirage

  1. Overview
  2. Docs

Source file net.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct
  module Channel = Mirage_channel.Make (S.Flow)
  module Input_channel = Input_channel.Make (Channel)
  module IO = Io.Make (Channel)
  open IO

  type ctx = {
    resolver : R.t;
    conduit : S.t option;
    authenticator : X509.Authenticator.t option;
  }

  let sexp_of_ctx { resolver; _ } = R.sexp_of_t resolver

  let default_ctx =
    lazy { resolver = R.localhost; conduit = None; authenticator = None }

  type endp = Conduit.endp
  type client

  let tunnel _ _ = failwith "Unimplemented"
  let connect_client ~ctx:_ _ = failwith "Unimplemented"
  let resolve ~ctx uri = R.resolve_uri ~uri ctx.resolver

  let connect_endp ~ctx endp =
    Conduit_mirage.Endpoint.client ?tls_authenticator:ctx.authenticator endp
    >>= fun client ->
    match ctx.conduit with
    | None -> failwith "conduit not initialised"
    | Some c ->
        S.connect c client >>= fun flow ->
        let ch = Channel.create flow in
        Lwt.return (flow, Input_channel.create ch, ch)

  let connect_uri ~ctx uri = resolve ~ctx uri >>= connect_endp ~ctx
  let close_in _ = ()
  let close_out _ = ()

  let close ic _oc =
    Lwt.ignore_result
    @@ Lwt.catch
         (fun () -> Input_channel.close ic)
         (fun e ->
           Logs.warn (fun f ->
               f "Closing channel failed: %s" (Printexc.to_string e));
           Lwt.return @@ Ok ())
end