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
48
module Make
    (P : Mirage_clock.PCLOCK)
    (R : Resolver_mirage.S)
    (S : Conduit_mirage.S) =
struct
  module Channel = Mirage_channel.Make (S.Flow)
  module Input_channel = Input_channel.Make (Channel)
  module Endpoint = Conduit_mirage.Endpoint (P)
  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

  let resolve ~ctx uri = R.resolve_uri ~uri ctx.resolver

  let connect_endp ~ctx endp =
    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