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