forked from
gazagnaire.org/ocaml-mdns
mDNS/DNS-SD service discovery for OCaml (RFC 6762/6763)
Add CLI binaries for mdns and matter
- mdns-query: Query mDNS services (mdns-query _hap._tcp.local)
- matter: Discover and control Matter devices
- matter discover: Find Matter devices
- matter commission: PASE pairing with passcode
- matter on/off/toggle: Control devices
Also includes formatting fixes from dune fmt
+94
+5
bin/dune
+5
bin/dune
+89
bin/mdns_query.ml
+89
bin/mdns_query.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** mdns-query - mDNS service discovery CLI tool *)
7
+
8
+
let pp_domain ppf name = Fmt.pf ppf "%s" (Domain_name.to_string name)
9
+
10
+
let pp_response ppf (r : Mdns.response) =
11
+
(* PTR records: service instances *)
12
+
List.iter
13
+
(fun (service, instance) ->
14
+
Fmt.pf ppf "@[<h>PTR %a -> %a@]@." pp_domain service pp_domain instance)
15
+
r.ptrs;
16
+
(* SRV records: port and target *)
17
+
List.iter
18
+
(fun (instance, port, target) ->
19
+
Fmt.pf ppf "@[<h>SRV %a -> %a:%d@]@." pp_domain instance pp_domain target
20
+
port)
21
+
r.srvs;
22
+
(* TXT records *)
23
+
List.iter
24
+
(fun (instance, txts) ->
25
+
Fmt.pf ppf "@[<h>TXT %a -> %a@]@." pp_domain instance
26
+
Fmt.(list ~sep:(any " ") string)
27
+
txts)
28
+
r.txts;
29
+
(* A records *)
30
+
List.iter
31
+
(fun (name, ip) ->
32
+
Fmt.pf ppf "@[<h>A %a -> %a@]@." pp_domain name Ipaddr.V4.pp ip)
33
+
r.addrs;
34
+
(* AAAA records *)
35
+
List.iter
36
+
(fun (name, ip) ->
37
+
Fmt.pf ppf "@[<h>AAAA %a -> %a@]@." pp_domain name Ipaddr.V6.pp ip)
38
+
r.addrs6
39
+
40
+
let run service timeout =
41
+
Eio_main.run @@ fun env ->
42
+
Eio.Switch.run @@ fun sw ->
43
+
let net = Eio.Stdenv.net env in
44
+
let clock = Eio.Stdenv.clock env in
45
+
let name = Domain_name.of_string_exn service in
46
+
Fmt.pr "Querying %s (timeout: %.1fs)...@.@." service timeout;
47
+
let responses = Mdns.query ~sw ~net ~clock ~timeout name in
48
+
let merged = Mdns.merge responses in
49
+
if
50
+
merged.ptrs = [] && merged.srvs = [] && merged.txts = []
51
+
&& merged.addrs = [] && merged.addrs6 = []
52
+
then Fmt.pr "No responses received.@."
53
+
else begin
54
+
Fmt.pr "Results:@.";
55
+
pp_response Fmt.stdout merged
56
+
end
57
+
58
+
(* Cmdliner interface *)
59
+
open Cmdliner
60
+
61
+
let service =
62
+
let doc = "Service type to query (e.g., _http._tcp.local, _hap._tcp.local)" in
63
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"SERVICE" ~doc)
64
+
65
+
let timeout =
66
+
let doc = "Timeout in seconds to wait for responses." in
67
+
Arg.(value & opt float 3.0 & info [ "t"; "timeout" ] ~docv:"SECONDS" ~doc)
68
+
69
+
let cmd =
70
+
let doc = "Query mDNS services on the local network" in
71
+
let man =
72
+
[
73
+
`S Manpage.s_description;
74
+
`P
75
+
"$(tname) sends an mDNS query for the specified service type and \
76
+
displays all responses received within the timeout period.";
77
+
`S Manpage.s_examples;
78
+
`P "Query for HomeKit accessories:";
79
+
`Pre " $(tname) _hap._tcp.local";
80
+
`P "Query for Matter devices:";
81
+
`Pre " $(tname) _matter._tcp.local";
82
+
`P "Query for HTTP servers with longer timeout:";
83
+
`Pre " $(tname) -t 5 _http._tcp.local";
84
+
]
85
+
in
86
+
let info = Cmd.info "mdns-query" ~version:"%%VERSION%%" ~doc ~man in
87
+
Cmd.v info Term.(const run $ service $ timeout)
88
+
89
+
let () = exit (Cmd.eval cmd)