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
module Packet = struct
type proto = Ethernet_packet.proto
let pp_proto = Ethernet_packet.pp_proto
type t = Ethernet_packet.t = {
source : Macaddr.t;
destination : Macaddr.t;
ethertype : proto;
}
let sizeof_ethernet = Ethernet_packet.sizeof_ethernet
let of_cstruct = Ethernet_packet.Unmarshal.of_cstruct
let into_cstruct = Ethernet_packet.Marshal.into_cstruct
let make_cstruct = Ethernet_packet.Marshal.make_cstruct
end
module type S = sig
type nonrec error = private [> `Exceeds_mtu ]
val pp_error: error Fmt.t
type t
val disconnect : t -> unit Lwt.t
val write: t -> ?src:Macaddr.t -> Macaddr.t -> Packet.proto -> ?size:int ->
(Cstruct.t -> int) -> (unit, error) result Lwt.t
val mac: t -> Macaddr.t
val mtu: t -> int
val input:
arpv4:(Cstruct.t -> unit Lwt.t) ->
ipv4:(Cstruct.t -> unit Lwt.t) ->
ipv6:(Cstruct.t -> unit Lwt.t) ->
t -> Cstruct.t -> unit Lwt.t
end
open Lwt.Infix
let src = Logs.Src.create "ethernet" ~doc:"Mirage Ethernet"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (Netif : Mirage_net.S) = struct
type error = [ `Exceeds_mtu | `Netif of Netif.error ]
let pp_error ppf = function
| `Exceeds_mtu -> Fmt.string ppf "exceeds MTU"
| `Netif e -> Netif.pp_error ppf e
type t = {
netif: Netif.t;
}
let mac t = Netif.mac t.netif
let mtu t = Netif.mtu t.netif
let input ~arpv4 ~ipv4 ~ipv6 t frame =
let open Ethernet_packet in
let of_interest dest =
Macaddr.compare dest (mac t) = 0 || not (Macaddr.is_unicast dest)
in
match Unmarshal.of_cstruct frame with
| Ok (, payload) when of_interest header.destination ->
begin
match header.Ethernet_packet.ethertype with
| `ARP -> arpv4 payload
| `IPv4 -> ipv4 payload
| `IPv6 -> ipv6 payload
end
| Ok _ -> Lwt.return_unit
| Error s ->
Log.debug (fun f -> f "dropping Ethernet frame: %s" s);
Lwt.return_unit
let write t ?src destination ethertype ?size payload =
let source = match src with None -> mac t | Some x -> x
and eth_hdr_size = Ethernet_packet.sizeof_ethernet
and mtu = mtu t
in
match
match size with
| None -> Ok mtu
| Some s -> if s > mtu then Error () else Ok s
with
| Error () -> Lwt.return (Error `Exceeds_mtu)
| Ok size ->
let size = eth_hdr_size + size in
let hdr = { Ethernet_packet.source ; destination ; ethertype } in
let fill frame =
match Ethernet_packet.Marshal.into_cstruct hdr frame with
| Error msg ->
Log.err (fun m -> m "error %s while marshalling ethernet header into allocated buffer" msg);
0
| Ok () ->
let len = payload (Cstruct.shift frame eth_hdr_size) in
eth_hdr_size + len
in
Netif.write t.netif ~size fill >|= function
| Ok () -> Ok ()
| Error e ->
Log.warn (fun f -> f "netif write errored %a" Netif.pp_error e) ;
Error (`Netif e)
let connect netif =
let t = { netif } in
Log.info (fun f -> f "Connected Ethernet interface %a" Macaddr.pp (mac t));
Lwt.return t
let disconnect t =
Log.info (fun f -> f "Disconnected Ethernet interface %a" Macaddr.pp (mac t));
Lwt.return_unit
end