gazagnaire.org
User-mode network gateway (SLIRP / vpnkit) in pure OCaml
11 kB
300 lines
1(* The user-mode network gateway as a standalone process: it moves a guest's
2 TCP/UDP/ICMP out through ordinary host sockets, with no privilege and no
3 Virtualization.framework -- so no entitlement and no code signing. It knows
4 nothing about starting a VM; it only speaks a frame transport over a file
5 descriptor a launcher hands it.
6
7 The gateway drives a connected datagram socket carrying one whole Ethernet
8 frame per datagram -- what Apple's VZFileHandleNetworkDeviceAttachment
9 presents, and what a tap bridge or a test harness can supply. Whatever boots
10 the guest owns the other end and the entitlement; this process owns the
11 gateway and neither.
12
13 The descriptor arrives over a Unix control socket by SCM_RIGHTS, so no raw
14 file-descriptor numbers cross the process boundary:
15
16 slirp --control /path/to.sock listen; the launcher connects and
17 sends the guest transport fd
18
19 Usage: slirp --control PATH [-p HOST:GUEST]... [--mtu BYTES] [--shards N] *)
20
21open Cmdliner
22module Control = Slirp_control.Control
23
24let guest_ip = Ipaddr.V4.of_string_exn "192.168.65.2"
25let gateway_ip = Ipaddr.V4.of_string_exn "192.168.65.1"
26
27(* Docker Desktop's synthetic host interface uses the maximum 16-bit IP MTU, so
28 a whole Ethernet frame stays inside one 65535-byte datagram. *)
29let default_mtu = 65521
30
31(* Wait on the control socket for the launcher to pass the guest transport fd by
32 SCM_RIGHTS. One fd, one connection: the frame transport itself carries every
33 packet after that, so the control socket is setup-only. *)
34let receive_transport_fd ~sw ~path =
35 (try Unix.unlink path with Unix.Unix_error (ENOENT, _, _) -> ());
36 let listener = Unix.socket PF_UNIX SOCK_STREAM 0 in
37 Unix.bind listener (ADDR_UNIX path);
38 Unix.listen listener 1;
39 let listener = Eio_unix.Fd.of_unix ~sw ~close_unix:true listener in
40 let conn, _ =
41 Eio_unix.Fd.use_exn "accept" listener (fun fd ->
42 let conn, addr = Unix.accept fd in
43 (conn, addr))
44 in
45 let conn = Eio_unix.Fd.of_unix ~sw ~close_unix:true conn in
46 let buf = [| Cstruct.create 1 |] in
47 let _, _, fds =
48 Eio_posix.Low_level.recv_msg_with_fds ~sw ~max_fds:1 conn buf
49 in
50 (try Unix.unlink path with Unix.Unix_error _ -> ());
51 match fds with
52 | fd :: _ -> fd
53 | [] -> failwith "slirp: launcher sent no file descriptor"
54
55(* Count every frame both ways for /stats: cheap and on the edge, not per
56 shard. *)
57let count_bytes counters (base : Eio_net.Frame.t) =
58 let count_rx f = Control.add_rx counters (String.length f) in
59 let count_tx f = Control.add_tx counters (String.length f) in
60 let send r =
61 count_tx (Rope.to_string r);
62 base.Eio_net.Frame.send r
63 in
64 {
65 base with
66 Eio_net.Frame.recv =
67 (fun () ->
68 let f = base.Eio_net.Frame.recv () in
69 count_rx f;
70 f);
71 recv_batch =
72 (fun () ->
73 let fs = base.Eio_net.Frame.recv_batch () in
74 List.iter count_rx fs;
75 fs);
76 send;
77 send_batch = List.iter send;
78 }
79
80(* Tap every frame crossing the transport, either direction, to a pcap file. The
81 transport is the one point all guest traffic passes, so the tap needs nothing
82 configured; sends arrive from several shard domains, so the append is
83 serialised. *)
84let tap_pcap ~snaplen path (transport : Eio_net.Frame.t) =
85 let w = Bytesrw.Bytes.Writer.of_out_channel (open_out_bin path) in
86 let cap = Pcap.writer ~snaplen w in
87 let mutex = Mutex.create () in
88 let record frame =
89 Mutex.lock mutex;
90 Pcap.packet cap frame;
91 Mutex.unlock mutex
92 in
93 let send rope =
94 record (Rope.to_string rope);
95 transport.Eio_net.Frame.send rope
96 in
97 {
98 Eio_net.Frame.recv =
99 (fun () ->
100 let f = transport.Eio_net.Frame.recv () in
101 record f;
102 f);
103 recv_batch =
104 (fun () ->
105 let fs = transport.Eio_net.Frame.recv_batch () in
106 List.iter record fs;
107 fs);
108 recv_slice = transport.Eio_net.Frame.recv_slice;
109 send;
110 send_batch = List.iter send;
111 }
112
113(* A worker pool of [shards] domains, or none when a single shard runs the whole
114 gateway inline. *)
115let pool ~sw env shards =
116 if shards <= 1 then None
117 else
118 Some
119 (Eio.Executor_pool.create ~sw ~domain_count:shards
120 (Eio.Stdenv.domain_mgr env))
121
122let log_ready ~mtu ~pcap ~guest_ip ~gateway_ip =
123 Fmt.epr "slirp: gateway up, guest leases %a through %a (MTU %d)%s\n%!"
124 Ipaddr.V4.pp guest_ip Ipaddr.V4.pp gateway_ip mtu
125 (match pcap with Some p -> ", capturing to " ^ p | None -> "")
126
127let run () control api pcap snaplen mtu shards publish deny_egress allow_egress
128 dns hosts =
129 (* A guest that goes away resets the transport; for a gateway that is normal
130 shutdown, not an error, so exit cleanly rather than crash. *)
131 try
132 Eio_main.run @@ fun env ->
133 Eio.Switch.run @@ fun sw ->
134 let fd = receive_transport_fd ~sw ~path:control in
135 let transport =
136 Eio_unix.Fd.use_exn "transport" fd (fun host_fd ->
137 if mtu > 1500 then Slirp_eio.widen_datagram_bufs host_fd;
138 Slirp_eio.transport_of_fd ~sw host_fd)
139 in
140 let counters = Control.counters () in
141 let transport = count_bytes counters transport in
142 let transport =
143 match pcap with
144 | None -> transport
145 | Some path -> tap_pcap ~snaplen path transport
146 in
147 let pool = pool ~sw env shards in
148 let tcp =
149 match pool with
150 | None -> Slirp_eio.Tcp_config.single ()
151 | Some pool ->
152 Slirp_eio.Tcp_config.sharded ~pool ~shards:(max 1 shards) ()
153 in
154 let inbound =
155 List.map (fun (host, guest) -> (host, Ipaddr.V4 guest_ip, guest)) publish
156 in
157 Slirp_eio.run ~sw ~net:(Eio.Stdenv.net env)
158 ~clock:(Eio.Stdenv.mono_clock env)
159 ~random:(Eio.Stdenv.secure_random env)
160 ~tcp ~gateway_ip ~mtu
161 ~egress_deny:(Slirp_eio.default_egress_deny @ deny_egress)
162 ~egress_allow:allow_egress ~dns_upstreams:dns ~dns_hosts:hosts
163 ~dhcp_range:(guest_ip, guest_ip) ~inbound
164 ?on_control:
165 (Option.map
166 (fun path ctrl ->
167 Control.serve ~sw ~net:(Eio.Stdenv.net env)
168 ~tmp:Eio.Path.(Eio.Stdenv.fs env / Filename.get_temp_dir_name ())
169 ctrl counters path)
170 api)
171 transport;
172 log_ready ~mtu ~pcap ~guest_ip ~gateway_ip;
173 (* The fibers run until the switch ends; block this one on it. *)
174 Eio.Fiber.await_cancel ()
175 with Eio.Io (Eio.Net.E (Connection_reset _), _) | End_of_file ->
176 Fmt.epr "slirp: guest disconnected, gateway stopped\n%!"
177
178let control =
179 let doc =
180 "Path to a Unix control socket. The gateway listens on it and takes the \
181 guest transport fd the launcher sends by SCM_RIGHTS."
182 in
183 Arg.(required & opt (some string) None & info [ "control" ] ~docv:"PATH" ~doc)
184
185let api =
186 let doc =
187 "Serve the HTTP+JSON control API (gvproxy-compatible: /stats, \
188 /services/forwarder/{all,expose,unexpose}) on the Unix socket $(docv). \
189 curl it to publish ports while the gateway runs."
190 in
191 Arg.(value & opt (some string) None & info [ "api" ] ~docv:"PATH" ~doc)
192
193let pcap =
194 let doc =
195 "Capture every frame crossing the transport to $(docv), a pcap file that \
196 tcpdump and Wireshark read. The transport is the one point all guest \
197 traffic passes through."
198 in
199 Arg.(value & opt (some string) None & info [ "pcap" ] ~docv:"FILE" ~doc)
200
201let snaplen =
202 let doc = "Bytes captured per frame with $(b,--pcap) (0 = whole frame)." in
203 Arg.(value & opt int 65535 & info [ "snaplen" ] ~docv:"BYTES" ~doc)
204
205let mtu =
206 let doc =
207 "Guest link MTU, advertised over DHCP. A jumbo value (up to 65521) lets \
208 the terminated TCP use big frames. Pass 1500 for conventional Ethernet."
209 in
210 Arg.(value & opt int default_mtu & info [ "mtu" ] ~docv:"BYTES" ~doc)
211
212let shards =
213 let doc =
214 "TCP state-machine shards, each on its own domain; a flow is pinned to one \
215 for its lifetime. Scales the gateway across cores."
216 in
217 Arg.(value & opt int 1 & info [ "shards" ] ~docv:"COUNT" ~doc)
218
219let publish_conv =
220 let parse s =
221 match String.split_on_char ':' s with
222 | [ h; g ] -> (
223 match (int_of_string_opt h, int_of_string_opt g) with
224 | Some h, Some g when h >= 0 && h <= 65535 && g >= 0 && g <= 65535 ->
225 Ok (h, g)
226 | _ -> Error (`Msg "ports must be in [0, 65535]"))
227 | _ -> Error (`Msg "expected HOST:GUEST")
228 in
229 Arg.conv ~docv:"HOST:GUEST" (parse, fun ppf (h, g) -> Fmt.pf ppf "%d:%d" h g)
230
231let publish =
232 let doc = "Publish a host TCP port into the guest ($(b,-p HOST:GUEST))." in
233 Arg.(
234 value & opt_all publish_conv []
235 & info [ "p"; "publish" ] ~docv:"HOST:GUEST" ~doc)
236
237let cidr_conv =
238 Arg.conv ~docv:"CIDR"
239 ( Ipaddr.Prefix.of_string,
240 fun ppf p -> Fmt.string ppf (Ipaddr.Prefix.to_string p) )
241
242let deny_egress =
243 let doc =
244 "Deny the guest outbound access to $(docv) (repeatable). Added to the \
245 built-in denylist (host loopback and the link-local/metadata range), \
246 which stays in force."
247 in
248 Arg.(value & opt_all cidr_conv [] & info [ "deny-egress" ] ~docv:"CIDR" ~doc)
249
250let allow_egress =
251 let doc =
252 "Allow the guest outbound access to $(docv) (repeatable) even if a denied \
253 prefix -- built-in or $(b,--deny-egress) -- also covers it."
254 in
255 Arg.(value & opt_all cidr_conv [] & info [ "allow-egress" ] ~docv:"CIDR" ~doc)
256
257let ip_conv =
258 Arg.conv ~docv:"IP"
259 (Ipaddr.of_string, fun ppf ip -> Fmt.string ppf (Ipaddr.to_string ip))
260
261let dns =
262 let doc =
263 "Upstream DNS resolver the guest's queries are forwarded to (repeatable, \
264 in priority order). Overrides the host's own resolvers."
265 in
266 Arg.(value & opt_all ip_conv [] & info [ "dns" ] ~docv:"IP" ~doc)
267
268let host_conv =
269 (* Split on the first ':' so an IPv6 address (which contains ':') is kept
270 whole as the value. *)
271 let parse s =
272 match String.index_opt s ':' with
273 | Some i ->
274 let name = String.sub s 0 i in
275 let ip = String.sub s (i + 1) (String.length s - i - 1) in
276 Result.map (fun ip -> (name, ip)) (Ipaddr.of_string ip)
277 | None -> Error (`Msg "expected NAME:IP")
278 in
279 Arg.conv ~docv:"NAME:IP"
280 (parse, fun ppf (n, ip) -> Fmt.pf ppf "%s:%s" n (Ipaddr.to_string ip))
281
282let hosts =
283 let doc =
284 "Resolve $(i,NAME) to $(i,IP) locally (repeatable): a custom names entry \
285 the guest sees before any upstream. When given, it replaces the host's \
286 /etc/hosts for the guest."
287 in
288 Arg.(value & opt_all host_conv [] & info [ "host" ] ~docv:"NAME:IP" ~doc)
289
290let cmd =
291 let doc =
292 "User-mode network gateway over a frame transport -- no VM, no sudo."
293 in
294 Cmd.v
295 (Cmd.info "slirp" ~version:Version.string ~doc)
296 Term.(
297 const run $ Observe.setup "slirp" $ control $ api $ pcap $ snaplen $ mtu
298 $ shards $ publish $ deny_egress $ allow_egress $ dns $ hosts)
299
300let () = exit (Cmd.eval cmd)