gazagnaire.org
User-mode network gateway (SLIRP / vpnkit) in pure OCaml
slirp-eio: add reusable gateway startup
In-process launchers need the same frame accounting, source selection, and control-server wiring. Keep that policy with slirp so VM backends can share it.
author
Thomas Gazagnaire
date
(Jul 22, 2026, 4:33 AM UTC)
commit
a9e534fb
a9e534fbea0271cfb2bb47ac21b03e37b47f3ff6
parent
cb7098d7
cb7098d762dd621736ded7e700949623a91c319a
+391
-16
+94
-16
bin/control.ml
+94
-16
bin/control.ml
···
1
-
(* A small HTTP+JSON control plane over a Unix socket, the shape gvproxy and
2
-
Docker expose: curl-able, no protobuf, no codegen. It drives the gateway's
3
-
runtime {!Slirp_eio.controller} -- publish and unpublish host ports, reload
4
-
the DNS forwarder, dump state -- and reports byte counters.
1
+
(* A small HTTP+JSON control plane over a Unix socket, compatible with the
2
+
endpoints exposed by gvproxy and Docker and usable with curl. It drives the
3
+
gateway's runtime {!Slirp_eio.controller} -- publish and unpublish host
4
+
ports, reload the DNS forwarder, dump state -- and reports byte counters.
5
5
6
-
The HTTP is Respond's server (nox-http request parsing, so malformed and
7
-
request-smuggling shapes are rejected before a handler runs); every JSON body
8
-
and reply goes through a nox-json {!Json.Codec}, never a hand-scan or a
9
-
hand-built string. The routes:
6
+
The HTTP server uses Respond over nox-http for request framing. nox-json
7
+
{!Json.Codec} values parse every JSON body and encode every reply. The routes:
10
8
GET /stats byte counters and live-flow counts
11
9
GET /connections the live NAT flows
12
10
GET /services/forwarder/all the published forwards
···
22
20
let add_rx t bytes = ignore (Atomic.fetch_and_add t.rx_bytes bytes : int)
23
21
let add_tx t bytes = ignore (Atomic.fetch_and_add t.tx_bytes bytes : int)
24
22
23
+
let count_transport counters (base : Eio_net.Frame.t) =
24
+
let count_rx frame = add_rx counters (String.length frame) in
25
+
let send rope =
26
+
add_tx counters (Rope.length rope);
27
+
base.Eio_net.Frame.send rope
28
+
in
29
+
{
30
+
base with
31
+
Eio_net.Frame.recv =
32
+
(fun () ->
33
+
let frame = base.Eio_net.Frame.recv () in
34
+
count_rx frame;
35
+
frame);
36
+
recv_batch =
37
+
(fun () ->
38
+
let frames = base.Eio_net.Frame.recv_batch () in
39
+
List.iter count_rx frames;
40
+
frames);
41
+
send;
42
+
send_batch = List.iter send;
43
+
}
44
+
45
+
let count_sources counters ~shards tx_sources =
46
+
Option.map
47
+
(fun sources shard ->
48
+
List.map
49
+
(fun pull () ->
50
+
let frames = pull () in
51
+
List.iter
52
+
(function
53
+
| Slirp.Frame frame -> add_rx counters (String.length frame)
54
+
| Slirp.Frame_rope { headers; payload } ->
55
+
add_rx counters (String.length headers + Rope.length payload)
56
+
| _ -> ())
57
+
frames;
58
+
frames)
59
+
(sources ~shards shard))
60
+
tx_sources
61
+
62
+
let count_owned counters owned_frames =
63
+
Option.map
64
+
(fun (source : Slirp_eio.owned_frames) ->
65
+
let recv_batch () =
66
+
let frames = source.recv_batch () in
67
+
List.iter
68
+
(fun (frame : Slirp_eio.owned_frame) -> add_rx counters frame.length)
69
+
frames;
70
+
frames
71
+
in
72
+
Slirp_eio.{ source with recv_batch })
73
+
owned_frames
74
+
75
+
let count_emitters counters shard_emitters =
76
+
Option.map
77
+
(fun emitters shard ->
78
+
let emit = emitters shard in
79
+
fun emission ->
80
+
let frame =
81
+
match emission with
82
+
| Slirp_eio.Frame frame -> frame
83
+
| Slirp_eio.Gso { frame; _ } -> frame
84
+
in
85
+
add_tx counters (Rope.length frame);
86
+
emit emission)
87
+
shard_emitters
88
+
89
+
let histogram_stats name recorder =
90
+
let histogram = Hdr.Recorder.snapshot recorder in
91
+
let metric field value = (Fmt.str "%s.%s" name field, value) in
92
+
[
93
+
metric "count" (Hdr.count histogram);
94
+
metric "min" (Hdr.min histogram);
95
+
metric "p50" (Hdr.value_at_percentile histogram 50.);
96
+
metric "p90" (Hdr.value_at_percentile histogram 90.);
97
+
metric "p99" (Hdr.value_at_percentile histogram 99.);
98
+
metric "p999" (Hdr.value_at_percentile histogram 99.9);
99
+
metric "max" (Hdr.max histogram);
100
+
metric "mean" (int_of_float (Float.round (Hdr.mean histogram)));
101
+
metric "stddev" (int_of_float (Float.round (Hdr.stddev histogram)));
102
+
]
103
+
25
104
type transport_counter = { name : string; value : int }
26
105
27
106
module C = Json.Codec
···
78
157
|> O.member "value" C.int ~enc:(fun c -> c.value)
79
158
|> O.seal
80
159
81
-
(* A published forward. Structured fields, so the address needs no bespoke
82
-
parsing: [guest_ip] is validated with {!Ipaddr.V4.of_string}. *)
160
+
(* A published forward. [guest_ip] is validated with
161
+
{!Ipaddr.V4.of_string}. *)
83
162
type forward = { host_port : int; guest_ip : string; guest_port : int }
84
163
85
164
let forward_codec =
···
217
296
218
297
(* {1 The SQLite snapshot download} *)
219
298
220
-
(* A per-request name for the on-disk snapshot, unique within the process
221
-
without a clock or RNG. *)
299
+
(* An atomic sequence number gives each on-disk snapshot a process-local name. *)
222
300
let snapshot_seq = Atomic.make 0
223
301
224
302
(* Render the live NAT state to a self-contained SQLite database and return its
···
245
323
let bad_request = error 400
246
324
247
325
(* Decode a request body with [codec], passing the value to [k]; a body that is
248
-
not valid JSON of the expected shape is a 400. *)
326
+
not valid JSON for that codec is a 400. *)
249
327
let with_body codec (req : Respond.post_request) k =
250
328
match Json.of_string codec req.body with
251
329
| Ok v -> k v
···
320
398
let routes ~tmp ?transport_stats ctrl counters =
321
399
read_routes ~tmp ?transport_stats ctrl counters @ write_routes ctrl
322
400
323
-
(* Serve the control API on a Unix socket until the switch ends. Its own switch
324
-
so the blocking [run] does not hold up gateway setup. [tmp] is a scratch
325
-
directory the snapshot endpoint stages its SQLite file in. *)
401
+
(* Serve the control API on a Unix socket until the switch ends. A daemon switch
402
+
starts it asynchronously with gateway setup. The snapshot endpoint stages
403
+
its SQLite file in [tmp]. *)
326
404
let serve ~sw ~net ~tmp ?transport_stats ctrl counters path =
327
405
(try Unix.unlink path with Unix.Unix_error _ -> ());
328
406
Eio.Fiber.fork_daemon ~sw (fun () ->
+29
bin/control.mli
+29
bin/control.mli
···
12
12
val add_tx : counters -> int -> unit
13
13
(** [add_tx counters bytes] records host-to-guest frame bytes. *)
14
14
15
+
val count_transport : counters -> Eio_net.Frame.t -> Eio_net.Frame.t
16
+
(** [count_transport counters transport] records the byte length of every frame
17
+
received from or sent to the guest. *)
18
+
19
+
val count_sources :
20
+
counters ->
21
+
shards:int ->
22
+
(shards:int -> int -> (unit -> Slirp.input list) list) option ->
23
+
(int -> (unit -> Slirp.input list) list) option
24
+
(** [count_sources counters ~shards sources] records guest-to-host frame bytes
25
+
read through per-shard sources. *)
26
+
27
+
val count_owned :
28
+
counters -> Slirp_eio.owned_frames option -> Slirp_eio.owned_frames option
29
+
(** [count_owned counters source] records guest-to-host bytes read from owned
30
+
device buffers. *)
31
+
32
+
val count_emitters :
33
+
counters ->
34
+
(int -> Slirp_eio.emission -> unit) option ->
35
+
(int -> Slirp_eio.emission -> unit) option
36
+
(** [count_emitters counters emitters] records host-to-guest frame bytes sent
37
+
through per-shard emitters. *)
38
+
39
+
val histogram_stats : string -> Hdr.Recorder.t -> (string * int) list
40
+
(** [histogram_stats name recorder] snapshots [recorder] and returns count,
41
+
minimum, p50, p90, p99, p99.9, maximum, mean, and standard deviation as flat
42
+
integer metrics prefixed by [name]. *)
43
+
15
44
val serve :
16
45
sw:Eio.Switch.t ->
17
46
net:_ Eio.Net.t ->
+3
bin/dune
+3
bin/dune
+2
bin/test/dune
+2
bin/test/dune
+25
bin/test/test_control.ml
+25
bin/test/test_control.ml
···
99
99
Alcotest.(check string)
100
100
"transport snapshot" {|[{"name":"queue.dropped","value":7}]|} transport)
101
101
102
+
let test_histogram_stats () =
103
+
let recorder = Hdr.Recorder.v ~highest:1_000 () in
104
+
List.iter (Hdr.Recorder.record recorder) [ 10; 20; 30 ];
105
+
let stats = Control.histogram_stats "rx.bytes" recorder in
106
+
let metric name = List.assoc ("rx.bytes." ^ name) stats in
107
+
Alcotest.(check int) "count" 3 (metric "count");
108
+
Alcotest.(check int) "minimum" 10 (metric "min");
109
+
Alcotest.(check int) "maximum" 30 (metric "max")
110
+
111
+
let test_gateway_constructors () =
112
+
let guest = Ipaddr.V4.of_string_exn "192.168.65.2" in
113
+
let config = Slirp_eio_gateway.config ~dhcp_range:(guest, guest) () in
114
+
Alcotest.(check int) "one shard" 1 config.tcp_shards;
115
+
Alcotest.(check int) "standard MTU" 1500 config.mtu;
116
+
Alcotest.(check bool)
117
+
"verify receive checksums" true config.verify_tcp_checksum;
118
+
Alcotest.(check (option int)) "no GSO" None config.tx_gso_max_size;
119
+
let device = Slirp_eio_gateway.device () in
120
+
Alcotest.(check bool)
121
+
"no device fast path" true
122
+
(Option.is_none device.shard_emitters && Option.is_none device.tx_sources)
123
+
102
124
let suite =
103
125
( "control",
104
126
[
105
127
Alcotest.test_case "atomic and transport snapshots" `Quick
106
128
test_atomic_counters_and_transport_stats;
129
+
Alcotest.test_case "histogram stats" `Quick test_histogram_stats;
130
+
Alcotest.test_case "gateway constructor defaults" `Quick
131
+
test_gateway_constructors;
107
132
] )
+1
dune-project
+1
dune-project
+4
lib/gateway/dune
+4
lib/gateway/dune
+83
lib/gateway/slirp_eio_gateway.ml
+83
lib/gateway/slirp_eio_gateway.ml
···
1
+
module Control = Slirp_control.Control
2
+
3
+
type config = {
4
+
tcp_shards : int;
5
+
mtu : int;
6
+
verify_tcp_checksum : bool;
7
+
tx_checksum_offload : bool;
8
+
tx_gso_max_size : int option;
9
+
dhcp_range : Ipaddr.V4.t * Ipaddr.V4.t;
10
+
inbound : (int * Ipaddr.t * int) list;
11
+
recycle_payload : bool;
12
+
emit_per_input : bool;
13
+
tcp_ack_every : int option;
14
+
tcp_write_batch_bytes : int;
15
+
api : string option;
16
+
}
17
+
18
+
type device = {
19
+
shard_emitters : (int -> Slirp_eio.emission -> unit) option;
20
+
owned_frames : Slirp_eio.owned_frames option;
21
+
tx_sources : (shards:int -> int -> (unit -> Slirp.input list) list) option;
22
+
on_frame_handled : (unit -> unit) option;
23
+
transport_stats : (unit -> (string * int) list) option;
24
+
}
25
+
26
+
let config ?(tcp_shards = 1) ?(mtu = 1500) ?(verify_tcp_checksum = true)
27
+
?(tx_checksum_offload = false) ?tx_gso_max_size ?(inbound = [])
28
+
?(recycle_payload = false) ?(emit_per_input = false) ?tcp_ack_every
29
+
?(tcp_write_batch_bytes = Tcp_eio.Splice.default_write_batch_bytes) ?api
30
+
~dhcp_range () =
31
+
{
32
+
tcp_shards;
33
+
mtu;
34
+
verify_tcp_checksum;
35
+
tx_checksum_offload;
36
+
tx_gso_max_size;
37
+
dhcp_range;
38
+
inbound;
39
+
recycle_payload;
40
+
emit_per_input;
41
+
tcp_ack_every;
42
+
tcp_write_batch_bytes;
43
+
api;
44
+
}
45
+
46
+
let device ?shard_emitters ?owned_frames ?tx_sources ?on_frame_handled
47
+
?transport_stats () =
48
+
{
49
+
shard_emitters;
50
+
owned_frames;
51
+
tx_sources;
52
+
on_frame_handled;
53
+
transport_stats;
54
+
}
55
+
56
+
let run ~sw ~net ~clock ~random ?pool ~tmp ~counters config device transport =
57
+
let transport = Control.count_transport counters transport in
58
+
let shard_frame_sources =
59
+
Control.count_sources counters ~shards:config.tcp_shards device.tx_sources
60
+
in
61
+
(* Per-shard sources replace the callback source. Reading both would leave a
62
+
fiber blocked on a queue that the device no longer fills. *)
63
+
let owned_frames =
64
+
if Option.is_some shard_frame_sources then None
65
+
else Control.count_owned counters device.owned_frames
66
+
in
67
+
let shard_emitters = Control.count_emitters counters device.shard_emitters in
68
+
Slirp_eio.run ~sw ~net ~clock ~random ?pool ~tcp_shards:config.tcp_shards
69
+
~mtu:config.mtu ~verify_tcp_checksum:config.verify_tcp_checksum
70
+
~tx_checksum_offload:config.tx_checksum_offload
71
+
?tx_gso_max_size:config.tx_gso_max_size ~dhcp_range:config.dhcp_range
72
+
~inbound:config.inbound ?shard_emitters ?shard_frame_sources
73
+
~recycle_payload:config.recycle_payload
74
+
~emit_per_input:config.emit_per_input ?tcp_ack_every:config.tcp_ack_every
75
+
~tcp_write_batch_bytes:config.tcp_write_batch_bytes
76
+
?on_frame_handled:device.on_frame_handled ?owned_frames
77
+
?on_control:
78
+
(Option.map
79
+
(fun path controller ->
80
+
Control.serve ~sw ~net ~tmp ?transport_stats:device.transport_stats
81
+
controller counters path)
82
+
config.api)
83
+
transport
+73
lib/gateway/slirp_eio_gateway.mli
+73
lib/gateway/slirp_eio_gateway.mli
···
1
+
(** Common slirp startup for in-process VM launchers. *)
2
+
3
+
type config = {
4
+
tcp_shards : int;
5
+
mtu : int;
6
+
verify_tcp_checksum : bool;
7
+
tx_checksum_offload : bool;
8
+
tx_gso_max_size : int option;
9
+
dhcp_range : Ipaddr.V4.t * Ipaddr.V4.t;
10
+
inbound : (int * Ipaddr.t * int) list;
11
+
recycle_payload : bool;
12
+
emit_per_input : bool;
13
+
tcp_ack_every : int option;
14
+
tcp_write_batch_bytes : int;
15
+
api : string option;
16
+
}
17
+
(** Gateway policy chosen by the launcher. *)
18
+
19
+
type device = {
20
+
shard_emitters : (int -> Slirp_eio.emission -> unit) option;
21
+
owned_frames : Slirp_eio.owned_frames option;
22
+
tx_sources : (shards:int -> int -> (unit -> Slirp.input list) list) option;
23
+
on_frame_handled : (unit -> unit) option;
24
+
transport_stats : (unit -> (string * int) list) option;
25
+
}
26
+
(** Optional frame paths and statistics supplied by a guest network device. *)
27
+
28
+
val config :
29
+
?tcp_shards:int ->
30
+
?mtu:int ->
31
+
?verify_tcp_checksum:bool ->
32
+
?tx_checksum_offload:bool ->
33
+
?tx_gso_max_size:int ->
34
+
?inbound:(int * Ipaddr.t * int) list ->
35
+
?recycle_payload:bool ->
36
+
?emit_per_input:bool ->
37
+
?tcp_ack_every:int ->
38
+
?tcp_write_batch_bytes:int ->
39
+
?api:string ->
40
+
dhcp_range:Ipaddr.V4.t * Ipaddr.V4.t ->
41
+
unit ->
42
+
config
43
+
(** [config ~dhcp_range ()] uses one TCP shard, a 1500-byte MTU, checksum
44
+
verification enabled, transmit offload disabled, an empty published-port
45
+
list, and the defaults of {!Slirp_eio.run}. Optional arguments replace the
46
+
corresponding fields. *)
47
+
48
+
val device :
49
+
?shard_emitters:(int -> Slirp_eio.emission -> unit) ->
50
+
?owned_frames:Slirp_eio.owned_frames ->
51
+
?tx_sources:(shards:int -> int -> (unit -> Slirp.input list) list) ->
52
+
?on_frame_handled:(unit -> unit) ->
53
+
?transport_stats:(unit -> (string * int) list) ->
54
+
unit ->
55
+
device
56
+
(** [device ()] describes a device using the frame transport passed to {!run}.
57
+
Optional arguments add device-specific fast paths and statistics. *)
58
+
59
+
val run :
60
+
sw:Eio.Switch.t ->
61
+
net:_ Eio.Net.t ->
62
+
clock:_ Eio.Time.Mono.t ->
63
+
random:_ Eio.Flow.source ->
64
+
?pool:Eio.Executor_pool.t ->
65
+
tmp:Eio.Fs.dir_ty Eio.Path.t ->
66
+
counters:Slirp_control.Control.counters ->
67
+
config ->
68
+
device ->
69
+
Slirp_eio.transport ->
70
+
unit
71
+
(** [run ~sw ~net ~clock ~random ~tmp ~counters config device transport] counts
72
+
frame bytes, selects either per-shard or callback-based input, starts the
73
+
optional control server, and starts {!Slirp_eio.run}. *)
+1
slirp-eio.opam
+1
slirp-eio.opam
+4
test/gateway/dune
+4
test/gateway/dune
+1
test/gateway/test.ml
+1
test/gateway/test.ml
···
1
+
let () = Alcotest.run "slirp-eio-gateway" [ Test_slirp_eio_gateway.suite ]
+67
test/gateway/test_slirp_eio_gateway.ml
+67
test/gateway/test_slirp_eio_gateway.ml
···
1
+
let guest_ip = Ipaddr.V4.of_string_exn "192.168.65.2"
2
+
3
+
let test_config_defaults () =
4
+
let config = Slirp_eio_gateway.config ~dhcp_range:(guest_ip, guest_ip) () in
5
+
Alcotest.(check int) "one shard" 1 config.tcp_shards;
6
+
Alcotest.(check int) "standard MTU" 1500 config.mtu;
7
+
Alcotest.(check bool) "checksum verification" true config.verify_tcp_checksum;
8
+
Alcotest.(check bool) "transmit checksum" false config.tx_checksum_offload;
9
+
Alcotest.(check (option int)) "GSO size" None config.tx_gso_max_size;
10
+
Alcotest.(check int) "published ports" 0 (List.length config.inbound);
11
+
Alcotest.(check bool) "payload recycling" false config.recycle_payload;
12
+
Alcotest.(check bool) "per-input emission" false config.emit_per_input;
13
+
Alcotest.(check (option int)) "ACK interval" None config.tcp_ack_every;
14
+
Alcotest.(check int)
15
+
"write batch" Tcp_eio.Splice.default_write_batch_bytes
16
+
config.tcp_write_batch_bytes;
17
+
Alcotest.(check (option string)) "control API" None config.api
18
+
19
+
let test_config_overrides () =
20
+
let inbound = [ (8080, Ipaddr.V4 guest_ip, 80) ] in
21
+
let config =
22
+
Slirp_eio_gateway.config ~tcp_shards:4 ~mtu:65521 ~verify_tcp_checksum:false
23
+
~tx_checksum_offload:true ~tx_gso_max_size:524280 ~inbound
24
+
~recycle_payload:true ~emit_per_input:true ~tcp_ack_every:4
25
+
~tcp_write_batch_bytes:2_000_000 ~api:"/tmp/slirp.sock"
26
+
~dhcp_range:(guest_ip, guest_ip) ()
27
+
in
28
+
Alcotest.(check int) "four shards" 4 config.tcp_shards;
29
+
Alcotest.(check int) "jumbo MTU" 65521 config.mtu;
30
+
Alcotest.(check bool) "checksum verification" false config.verify_tcp_checksum;
31
+
Alcotest.(check bool) "transmit checksum" true config.tx_checksum_offload;
32
+
Alcotest.(check (option int)) "GSO size" (Some 524280) config.tx_gso_max_size;
33
+
Alcotest.(check int) "published port" 1 (List.length config.inbound);
34
+
Alcotest.(check (option int)) "ACK interval" (Some 4) config.tcp_ack_every;
35
+
Alcotest.(check (option string))
36
+
"control API" (Some "/tmp/slirp.sock") config.api
37
+
38
+
let test_device_paths () =
39
+
let owned_frames : Slirp_eio.owned_frames =
40
+
{ recv_batch = (fun () -> []); release = ignore; dropped = ignore }
41
+
in
42
+
let device =
43
+
Slirp_eio_gateway.device
44
+
~shard_emitters:(fun _ _ -> ())
45
+
~owned_frames
46
+
~tx_sources:(fun ~shards:_ _ -> [])
47
+
~on_frame_handled:ignore
48
+
~transport_stats:(fun () -> [ ("frames", 3) ])
49
+
()
50
+
in
51
+
Alcotest.(check bool) "emitter" true (Option.is_some device.shard_emitters);
52
+
Alcotest.(check bool) "owned frames" true (Option.is_some device.owned_frames);
53
+
Alcotest.(check bool) "sources" true (Option.is_some device.tx_sources);
54
+
Alcotest.(check bool)
55
+
"completion callback" true
56
+
(Option.is_some device.on_frame_handled);
57
+
Alcotest.(check bool)
58
+
"transport stats" true
59
+
(Option.is_some device.transport_stats)
60
+
61
+
let suite =
62
+
( "slirp_eio_gateway",
63
+
[
64
+
Alcotest.test_case "config defaults" `Quick test_config_defaults;
65
+
Alcotest.test_case "config overrides" `Quick test_config_overrides;
66
+
Alcotest.test_case "device paths" `Quick test_device_paths;
67
+
] )