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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
let src = Logs.Src.create "mnet.ipv6"
let[@inline always] now () = Mkernel.clock_monotonic ()
module SBstr = Slice_bstr
module Log = (val Logs.src_log src : Logs.LOG)
module Packet = struct
let _unsafe_hdr_into ?(hop_limit = 64) src dst ~protocol ?(off = 0) bstr =
Bstr.set_int32_be bstr (off + 0) 0x60000000l;
Bstr.set_uint16_be bstr (off + 4) 0;
Bstr.set_uint8 bstr (off + 6) protocol;
Bstr.set_uint8 bstr (off + 7) hop_limit;
let src = Ipaddr.V6.to_string src in
Bstr.blit_from_string src ~src_off:0 bstr ~dst_off:(off + 8) ~len:16;
let dst = Ipaddr.V6.to_string dst in
Bstr.blit_from_string dst ~src_off:0 bstr ~dst_off:(off + 24) ~len:16
end
let ( let* ) = Result.bind
module Key = struct
type t = { src: Ipaddr.V6.t; dst: Ipaddr.V6.t; uid: int; protocol: int }
let equal a b =
Ipaddr.V6.compare a.src b.src = 0
&& Ipaddr.V6.compare a.dst b.dst = 0
&& a.uid = b.uid
let hash t = Hashtbl.hash (t.src, t.dst, t.uid)
end
module Frags = Fragments.Make (Key)
type t = {
eth: Ethernet.t
; mutable ndpv6: NDPv6.t
; fragments: Frags.t
; lmtu: int
; tags: Logs.Tag.set
; mutable handler: handler
; cnt: int Atomic.t
}
and payload = Fragments.payload = Slice of SBstr.t | String of string
and handler = protocol:int -> Ipaddr.V6.t -> Ipaddr.V6.t -> payload -> unit
and daemon = unit Miou.t
let write eth { NDPv6.Packet.dst; len; fn } =
let fn bstr = fn bstr; len in
let protocol = Ethernet.IPv6 in
Ethernet.write_directly_into eth ~len ~dst ~protocol fn
let ignore ~protocol:_ _src _dst _payload = ()
let _1s = 1_000_000_000
let rec daemon t =
let now = now () in
let ndpv6, outs = NDPv6.tick t.ndpv6 ~now `Tick in
t.ndpv6 <- ndpv6;
List.iter (write t.eth) outs;
Mkernel.sleep _1s;
daemon t
let kill = Miou.cancel
type mode = NDPv6.mode = Random | EUI64 | Static of Ipaddr.V6.Prefix.t
let create ?(handler = ignore) eth mode =
let lmtu = Ethernet.mtu eth in
let mac = Ethernet.mac eth in
let now = now () in
let ndpv6, pkts = NDPv6.make ~now ~lmtu ~mac mode in
List.iter (write eth) pkts;
let tags = Logs.Tag.empty in
let cnt = Atomic.make 0 in
let fragments = Frags.create () in
let t = { eth; ndpv6; lmtu; tags; handler; cnt; fragments } in
let daemon = Miou.async @@ fun () -> daemon t in
Ok (t, daemon)
let set_handler t handler =
Atomic.incr t.cnt;
t.handler <- handler;
if Atomic.get t.cnt > 1 then
Log.warn (fun m -> m ~tags:t.tags "IPv6 handler modified more than once")
let with_hdr ~src ~dst ~protocol ~len fn =
let fn bstr =
Bstr.set_int32_be bstr 0 0x60000000l;
Bstr.set_uint16_be bstr 4 len;
Bstr.set_uint8 bstr 6 protocol;
Bstr.set_uint8 bstr 7 64 ;
let src = Ipaddr.V6.to_octets src in
Bstr.blit_from_string src ~src_off:0 bstr ~dst_off:8 ~len:16;
let dst = Ipaddr.V6.to_octets dst in
Bstr.blit_from_string dst ~src_off:0 bstr ~dst_off:24 ~len:16;
fn (Bstr.shift bstr 40)
in
fn
let into ~mtu ~src ~dst ~protocol ~len user's_fn =
if len > mtu - 40 then begin
let bstr = Bstr.create len in
let tmp = Bytes.create 4 in
Mirage_crypto_rng.generate_into tmp ~off:0 4;
let uid = Bytes.get_int32_ne tmp 0 in
user's_fn bstr;
let max = (mtu - 48) / 8 * 8 in
let rec go acc src_off =
if len - src_off <= 0 then List.rev acc
else
let chunk = Int.min max (len - src_off) in
let last = if src_off + chunk >= len then true else false in
let fn dst =
Bstr.set_uint8 dst 0 protocol;
Bstr.set_uint8 dst 1 0;
let v = (src_off / 8) lsl 3 in
let v = if last then v else v lor 1 in
Bstr.set_uint16_be dst 2 v;
Bstr.set_int32_be dst 4 uid;
Bstr.blit bstr ~src_off dst ~dst_off:8 ~len:chunk
in
let fn = with_hdr ~src ~dst ~protocol:44 ~len:(chunk + 8) fn in
go ({ NDPv6.Packet.len= chunk + 48; fn } :: acc) (src_off + chunk)
in
go [] 0
end
else
let fn = with_hdr ~src ~dst ~protocol ~len user's_fn in
[ { NDPv6.Packet.len= len + 40; fn } ]
let at_most_one = function [] | [ _ ] -> true | _ -> false
let src t ~dst = NDPv6.src t.ndpv6 dst
let addresses t = NDPv6.addresses t.ndpv6
let write_directly t ?src dst ~protocol ~len user's_fn =
let src = NDPv6.src t.ndpv6 ?src dst in
let* ndpv6, next_hop, mtu = NDPv6.next_hop t.ndpv6 dst in
match mtu with
| None ->
let mtu = 1280 in
let pkts = into ~mtu ~src ~dst ~protocol ~len user's_fn in
if protocol = 6 && not (at_most_one pkts) then
Log.warn (fun m -> m "Fragmentation of IPv6/TCP packets");
let now = now () in
let ndpv6, outs = NDPv6.send ndpv6 ~now ~dst next_hop pkts in
List.iter (write t.eth) outs;
t.ndpv6 <- ndpv6;
Ok ()
| Some mtu ->
let pkts = into ~mtu ~src ~dst ~protocol ~len user's_fn in
let now = now () in
let ndpv6, outs = NDPv6.send ndpv6 ~now ~dst next_hop pkts in
List.iter (write t.eth) outs;
t.ndpv6 <- ndpv6;
Ok ()
let input t pkt =
match NDPv6.decode t.ndpv6 pkt.Ethernet.payload with
| Error (`Unknown_ICMP_packet _) -> ()
| Error `Drop -> ()
| Error err ->
Log.err (fun m -> m "Invalid IPv6 packet: %a" NDPv6.pp_error err);
let str = SBstr.to_string pkt.Ethernet.payload in
Log.err (fun m -> m "@[<hov>%a@]" (Hxd_string.pp Hxd.default) str)
| Ok (`Packet (protocol, src, dst, payload)) ->
t.handler ~protocol src dst (Slice payload)
| Ok
(`Fragment (src, dst, { NDPv6.Fragment.protocol; uid; off; last; payload }))
->
let now = now () in
let key = { Key.src; dst; uid; protocol } in
let len = SBstr.length payload in
let pkt = Frags.insert ~now t.fragments key ~off ~len ~last payload in
let fn ({ Key.src; dst; protocol; _ }, payload) =
t.handler ~protocol src dst payload
in
Option.iter fn pkt
| Ok event ->
let now = now () in
let ndpv6, outs = NDPv6.tick ~now t.ndpv6 event in
List.iter (write t.eth) outs;
t.ndpv6 <- ndpv6