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
module type S = sig
type t
val disconnect : t -> unit Lwt.t
type error = private [> `Timeout ]
val pp_error: error Fmt.t
val pp : t Fmt.t
val get_ips : t -> Ipaddr.V4.t list
val set_ips : t -> Ipaddr.V4.t list -> unit Lwt.t
val remove_ip : t -> Ipaddr.V4.t -> unit Lwt.t
val add_ip : t -> Ipaddr.V4.t -> unit Lwt.t
val query : t -> Ipaddr.V4.t -> (Macaddr.t, error) result Lwt.t
val input : t -> Cstruct.t -> unit Lwt.t
end
open Lwt.Infix
let logsrc = Logs.Src.create "ARP" ~doc:"Mirage ARP handler"
module Make (Ethernet : Ethernet.S) (Time : Mirage_time.S) = struct
type error = [
| `Timeout
]
let pp_error ppf = function
| `Timeout -> Fmt.pf ppf "could not determine a link-level address for the IP address given"
type t = {
mutable state : ((Macaddr.t, error) result Lwt.t * (Macaddr.t, error) result Lwt.u) Arp_handler.t ;
ethif : Ethernet.t ;
mutable ticking : bool ;
}
let probe_repeat_delay = Duration.of_ms 1500
let output t (arp, destination) =
let size = Arp_packet.size in
Ethernet.write t.ethif destination `ARP ~size
(fun b -> Arp_packet.encode_into arp b ; size) >|= function
| Ok () -> ()
| Error e ->
Logs.warn ~src:logsrc
(fun m -> m "error %a while outputting packet %a to %a"
Ethernet.pp_error e Arp_packet.pp arp Macaddr.pp destination)
let rec tick t () =
if t.ticking then
Time.sleep_ns probe_repeat_delay >>= fun () ->
let state, requests, timeouts = Arp_handler.tick t.state in
t.state <- state ;
Lwt_list.iter_p (output t) requests >>= fun () ->
List.iter (fun (_, u) -> Lwt.wakeup u (Error `Timeout)) timeouts ;
tick t ()
else
Lwt.return_unit
let pp ppf t = Arp_handler.pp ppf t.state
let input t frame =
let state, out, wake = Arp_handler.input t.state frame in
t.state <- state ;
(match out with
| None -> Lwt.return_unit
| Some pkt -> output t pkt) >|= fun () ->
match wake with
| None -> ()
| Some (mac, (_, u)) -> Lwt.wakeup u (Ok mac)
let get_ips t = Arp_handler.ips t.state
let create ?ipaddr t =
let mac = Arp_handler.mac t.state in
let state, out = Arp_handler.create ~logsrc ?ipaddr mac in
t.state <- state ;
match out with
| None -> Lwt.return_unit
| Some x -> output t x
let add_ip t ipaddr =
match Arp_handler.ips t.state with
| [] -> create ~ipaddr t
| _ ->
let state, out, wake = Arp_handler.alias t.state ipaddr in
t.state <- state ;
output t out >|= fun () ->
match wake with
| None -> ()
| Some (_, u) -> Lwt.wakeup u (Ok (Arp_handler.mac t.state))
let init_empty mac =
let state, _ = Arp_handler.create ~logsrc mac in
state
let set_ips t = function
| [] ->
let mac = Arp_handler.mac t.state in
let state = init_empty mac in
t.state <- state ;
Lwt.return_unit
| ipaddr::xs ->
create ~ipaddr t >>= fun () ->
Lwt_list.iter_s (add_ip t) xs
let remove_ip t ip =
let state = Arp_handler.remove t.state ip in
t.state <- state ;
Lwt.return_unit
let query t ip =
let merge = function
| None -> Lwt.wait ()
| Some a -> a
in
let state, res = Arp_handler.query t.state ip merge in
t.state <- state ;
match res with
| Arp_handler.RequestWait (pkt, (tr, _)) -> output t pkt >>= fun () -> tr
| Arp_handler.Wait (t, _) -> t
| Arp_handler.Mac mac -> Lwt.return (Ok mac)
let connect ethif =
let mac = Ethernet.mac ethif in
let state = init_empty mac in
let t = { ethif; state; ticking = true} in
Lwt.async (tick t);
Lwt.return t
let disconnect t =
t.ticking <- false ;
Lwt.return_unit
end