gazagnaire.org
mDNS/DNS-SD service discovery for OCaml (RFC 6762/6763)
fix(fuzz): fix test name prefixes to match module names (E725)
+50
-56
+15
-16
bin/mdns_query.ml
+15
-16
bin/mdns_query.ml
···
39
39
let is_empty (r : Mdns.response) =
40
40
r.ptrs = [] && r.srvs = [] && r.txts = [] && r.addrs = [] && r.addrs6 = []
41
41
42
+
let parse_service service =
43
+
try Domain_name.of_string_exn service
44
+
with Invalid_argument msg ->
45
+
Log.err (fun m -> m "Invalid service name %S: %s" service msg);
46
+
exit 1
47
+
48
+
let print_results merged =
49
+
if is_empty merged then (
50
+
Log.info (fun m -> m "No responses received.");
51
+
exit 1);
52
+
Log.info (fun m -> m "Results:");
53
+
pp_response Fmt.stdout merged
54
+
42
55
let run () service timeout =
56
+
let name = parse_service service in
43
57
Eio_main.run @@ fun env ->
44
58
Eio.Switch.run @@ fun sw ->
45
59
let net = Eio.Stdenv.net env in
46
60
let clock = Eio.Stdenv.clock env in
47
-
let name =
48
-
try Domain_name.of_string_exn service
49
-
with Invalid_argument msg ->
50
-
Log.err (fun m -> m "Invalid service name %S: %s" service msg);
51
-
exit 1
52
-
in
53
61
Log.info (fun m -> m "Querying %s (timeout: %.1fs)..." service timeout);
54
-
let responses = Mdns.query ~sw ~net ~clock ~timeout name in
55
-
let merged = Mdns.merge responses in
56
-
if is_empty merged then begin
57
-
Log.info (fun m -> m "No responses received.");
58
-
exit 1
59
-
end
60
-
else begin
61
-
Log.info (fun m -> m "Results:");
62
-
pp_response Fmt.stdout merged
63
-
end
62
+
print_results (Mdns.merge (Mdns.query ~sw ~net ~clock ~timeout name))
64
63
65
64
(* Cmdliner interface *)
66
65
open Cmdliner
+32
-38
lib/mdns.ml
+32
-38
lib/mdns.ml
···
92
92
let pkt = query name in
93
93
fst (Dns.Packet.encode `Udp pkt)
94
94
95
+
(* Parse a single resource record, advancing [off] past it *)
96
+
let parse_rr buf ~len ~off ~ptrs ~srvs ~txts ~addrs ~addrs6 =
97
+
if !off >= len then ()
98
+
else
99
+
let name = domain_of_labels (collect_labels buf !off) in
100
+
let off' = skip_name buf !off in
101
+
if off' + 10 > len then off := len
102
+
else
103
+
let typ = u16 buf off' in
104
+
let rdlen = u16 buf (off' + 8) in
105
+
let rdata = off' + 10 in
106
+
off := rdata + rdlen;
107
+
if rdata + rdlen <= len then
108
+
match typ with
109
+
| 1 when rdlen = 4 ->
110
+
let ip = Ipaddr.V4.of_int32 (String.get_int32_be buf rdata) in
111
+
addrs := (name, ip) :: !addrs
112
+
| 12 ->
113
+
ptrs := (name, domain_of_labels (collect_labels buf rdata)) :: !ptrs
114
+
| 16 -> txts := (name, parse_txt buf rdata (rdata + rdlen)) :: !txts
115
+
| 28 when rdlen = 16 ->
116
+
let hi = String.get_int64_be buf rdata in
117
+
let lo = String.get_int64_be buf (rdata + 8) in
118
+
addrs6 := (name, Ipaddr.V6.of_int64 (hi, lo)) :: !addrs6
119
+
| 33 when rdlen >= 6 ->
120
+
let port = u16 buf (rdata + 4) in
121
+
let target = domain_of_labels (collect_labels buf (rdata + 6)) in
122
+
srvs := (name, port, target) :: !srvs
123
+
| _ -> ()
124
+
95
125
(* Parse mDNS response *)
96
126
let parse buf =
97
127
let len = String.length buf in
···
100
130
let qdcount = u16 buf 4 in
101
131
let rr_count = u16 buf 6 + u16 buf 8 + u16 buf 10 in
102
132
let off = ref 12 in
103
-
(* Skip question section with bounds checking *)
104
133
for _ = 1 to qdcount do
105
134
let off' = skip_name buf !off in
106
-
(* Need 4 more bytes for qtype/qclass after name *)
107
-
if off' + 4 <= len then off := off' + 4
108
-
else off := len (* Invalid, skip to end *)
135
+
if off' + 4 <= len then off := off' + 4 else off := len
109
136
done;
110
137
let ptrs = ref [] and srvs = ref [] and txts = ref [] in
111
138
let addrs = ref [] and addrs6 = ref [] in
112
139
for _ = 1 to rr_count do
113
-
(* Check we have space for name + 10 byte RR header *)
114
-
if !off < len then begin
115
-
let name = domain_of_labels (collect_labels buf !off) in
116
-
let off' = skip_name buf !off in
117
-
(* Verify off' + 10 <= len before reading RR header *)
118
-
if off' + 10 <= len then begin
119
-
let typ = u16 buf off' in
120
-
let rdlen = u16 buf (off' + 8) in
121
-
let rdata = off' + 10 in
122
-
off := rdata + rdlen;
123
-
(* Verify rdata region is within bounds *)
124
-
if rdata + rdlen <= len then
125
-
match typ with
126
-
| 1 when rdlen = 4 ->
127
-
let ip = Ipaddr.V4.of_int32 (String.get_int32_be buf rdata) in
128
-
addrs := (name, ip) :: !addrs
129
-
| 12 ->
130
-
ptrs :=
131
-
(name, domain_of_labels (collect_labels buf rdata)) :: !ptrs
132
-
| 16 -> txts := (name, parse_txt buf rdata (rdata + rdlen)) :: !txts
133
-
| 28 when rdlen = 16 ->
134
-
let hi = String.get_int64_be buf rdata in
135
-
let lo = String.get_int64_be buf (rdata + 8) in
136
-
addrs6 := (name, Ipaddr.V6.of_int64 (hi, lo)) :: !addrs6
137
-
| 33 when rdlen >= 6 ->
138
-
let port = u16 buf (rdata + 4) in
139
-
let target =
140
-
domain_of_labels (collect_labels buf (rdata + 6))
141
-
in
142
-
srvs := (name, port, target) :: !srvs
143
-
| _ -> ()
144
-
end
145
-
else off := len (* Invalid RR header, abort *)
146
-
end
140
+
parse_rr buf ~len ~off ~ptrs ~srvs ~txts ~addrs ~addrs6
147
141
done;
148
142
Some
149
143
{
+3
-2
lib/mdns.mli
+3
-2
lib/mdns.mli
···
50
50
[ `raw ] Domain_name.t ->
51
51
response list
52
52
(** [query ~sw ~net ~clock ~timeout name] sends an mDNS query and collects
53
-
responses until [timeout] seconds have elapsed.
53
+
responses until [timeout] seconds have elapsed. Returns a list of all
54
+
responses received.
54
55
55
56
@param sw Eio switch for resource management.
56
57
@param net Eio network capability.
57
58
@param clock Eio clock for timeout.
58
59
@param timeout Maximum time to wait for responses in seconds.
59
-
@param name Service type to query (e.g., "_http._tcp.local") *)
60
+
@param name Service type to query (e.g., "_http._tcp.local"). *)
60
61
61
62
val merge : response list -> response
62
63
(** [merge responses] combines multiple responses into a single response. *)