anil.recoil.org
forked from
gazagnaire.org/ocaml-mdns
mDNS/DNS-SD service discovery for OCaml (RFC 6762/6763)
Initial commit: mdns - mDNS/DNS-SD service discovery (RFC 6762/6763)
+17
.gitignore
+17
.gitignore
+37
.hooks/remove-claude-lines.py
+37
.hooks/remove-claude-lines.py
···
1
+
#!/usr/bin/env python3
2
+
import sys
3
+
import re
4
+
5
+
def has_emoji(text):
6
+
# Unicode ranges for emojis
7
+
emoji_pattern = re.compile(
8
+
"["
9
+
"\U0001F600-\U0001F64F" # emoticons
10
+
"\U0001F300-\U0001F5FF" # symbols & pictographs
11
+
"\U0001F680-\U0001F6FF" # transport & map symbols
12
+
"\U0001F1E0-\U0001F1FF" # flags (iOS)
13
+
"\U00002702-\U000027B0" # dingbats
14
+
"\U000024C2-\U0001F251"
15
+
"]+", flags=re.UNICODE)
16
+
return bool(emoji_pattern.search(text))
17
+
18
+
def main():
19
+
commit_msg_file = sys.argv[1]
20
+
with open(commit_msg_file, 'r', encoding='utf-8') as f:
21
+
lines = f.readlines()
22
+
23
+
# Check for emojis in the commit message
24
+
commit_text = ''.join(lines)
25
+
if has_emoji(commit_text):
26
+
print("Error: Commit message contains emojis, which are not allowed.", file=sys.stderr)
27
+
return 1
28
+
29
+
filtered_lines = [line for line in lines if 'claude' not in line.lower()]
30
+
31
+
with open(commit_msg_file, 'w', encoding='utf-8') as f:
32
+
f.writelines(filtered_lines)
33
+
34
+
return 0
35
+
36
+
if __name__ == '__main__':
37
+
sys.exit(main())
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.28.1
+16
.pre-commit-config.yaml
+16
.pre-commit-config.yaml
···
1
+
repos:
2
+
- repo: local
3
+
hooks:
4
+
- id: dune-format
5
+
name: Auto format with dune
6
+
entry: dune fmt --auto
7
+
language: system
8
+
files: \.(ml|mli|mll|mly)$
9
+
stages: [pre-commit]
10
+
pass_filenames: false
11
+
12
+
- id: remove-claude-attribution
13
+
name: Remove Claude attribution from commit message
14
+
entry: python3 .hooks/remove-claude-lines.py
15
+
language: system
16
+
stages: [commit-msg]
+21
LICENSE.md
+21
LICENSE.md
···
1
+
MIT License
2
+
3
+
Copyright (c) 2025 Thomas Gazagnaire
4
+
5
+
Permission is hereby granted, free of charge, to any person obtaining a copy
6
+
of this software and associated documentation files (the "Software"), to deal
7
+
in the Software without restriction, including without limitation the rights
8
+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9
+
copies of the Software, and to permit persons to whom the Software is
10
+
furnished to do so, subject to the following conditions:
11
+
12
+
The above copyright notice and this permission notice shall be included in all
13
+
copies or substantial portions of the Software.
14
+
15
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16
+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17
+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18
+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19
+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20
+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21
+
SOFTWARE.
+59
README.md
+59
README.md
···
1
+
# mdns
2
+
3
+
mDNS/DNS-SD service discovery (RFC 6762/6763) for OCaml.
4
+
5
+
## Overview
6
+
7
+
mdns provides Multicast DNS for DNS-based Service Discovery as specified in RFC 6762 and RFC 6763. It uses Eio for async networking and the dns library for query encoding.
8
+
9
+
This implementation handles raw domain names to support DNS-SD service instance names containing spaces (e.g., "My Device._http._tcp.local").
10
+
11
+
## Features
12
+
13
+
- **RFC 6762/6763 compliant**: Implements mDNS for DNS-SD
14
+
- **Record types**: PTR, SRV, TXT, A, AAAA
15
+
- **Eio-based**: Modern async networking with Eio
16
+
- **Space-safe**: Handles service names with spaces
17
+
- **Fuzz tested**: Parser tested with Crowbar
18
+
19
+
## Installation
20
+
21
+
```
22
+
opam install mdns
23
+
```
24
+
25
+
## Usage
26
+
27
+
```ocaml
28
+
(* Discover HTTP services on the local network *)
29
+
Eio_main.run @@ fun env ->
30
+
Eio.Switch.run @@ fun sw ->
31
+
let name = Domain_name.of_string_exn "_http._tcp.local" in
32
+
let responses = Mdns.query
33
+
~sw ~net:(Eio.Stdenv.net env)
34
+
~clock:(Eio.Stdenv.clock env)
35
+
~timeout:2.0 name
36
+
in
37
+
let merged = Mdns.merge responses in
38
+
List.iter (fun (_, instance) ->
39
+
Format.printf "Found: %a@." Domain_name.pp instance
40
+
) merged.ptrs
41
+
```
42
+
43
+
## API
44
+
45
+
- `Mdns.query ~sw ~net ~clock ~timeout name` - Send mDNS query and collect responses
46
+
- `Mdns.merge responses` - Combine multiple responses
47
+
- `Mdns.parse buf` - Parse a raw mDNS packet
48
+
- `Mdns.encode_query name` - Encode an mDNS query packet
49
+
50
+
## Related Work
51
+
52
+
- [ocaml-dns](https://github.com/mirage/ocaml-dns) - DNS library used for query encoding. Provides full DNS client/server but doesn't handle mDNS multicast or DNS-SD service names with spaces.
53
+
- [charrua](https://github.com/mirage/charrua) - DHCP implementation for MirageOS, often used alongside mDNS for network discovery.
54
+
55
+
This library provides a focused mDNS/DNS-SD implementation using Eio for modern async networking.
56
+
57
+
## License
58
+
59
+
MIT License. See [LICENSE.md](LICENSE.md) for details.
+27
dune-project
+27
dune-project
···
1
+
(lang dune 3.0)
2
+
3
+
(name mdns)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license MIT)
8
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
9
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
+
(homepage "https://tangled.org/@gazagnaire.org/ocaml-mdns")
11
+
(bug_reports "https://tangled.org/@gazagnaire.org/ocaml-mdns/issues")
12
+
13
+
(package
14
+
(name mdns)
15
+
(synopsis "mDNS/DNS-SD service discovery (RFC 6763)")
16
+
(description
17
+
"A pure OCaml implementation of mDNS (Multicast DNS) for DNS-SD service \
18
+
discovery as specified in RFC 6763. Uses Eio for async networking and \
19
+
the dns library for query encoding.")
20
+
(depends
21
+
(ocaml (>= 4.08))
22
+
(eio (>= 1.0))
23
+
(dns (>= 9.0))
24
+
(ipaddr (>= 5.0))
25
+
(domain-name (>= 0.4))
26
+
(alcotest :with-test)
27
+
(crowbar :with-test)))
+15
fuzz/dune
+15
fuzz/dune
···
1
+
; Crowbar fuzz testing for mdns
2
+
;
3
+
; To run: dune exec fuzz/fuzz_mdns.exe
4
+
; With AFL: afl-fuzz -i fuzz/corpus -o fuzz/findings -- ./_build/default/fuzz/fuzz_mdns.exe @@
5
+
6
+
(executable
7
+
(name fuzz_mdns)
8
+
(modules fuzz_mdns)
9
+
(libraries mdns crowbar))
10
+
11
+
(rule
12
+
(alias fuzz)
13
+
(deps fuzz_mdns.exe)
14
+
(action
15
+
(run %{exe:fuzz_mdns.exe})))
+57
fuzz/fuzz_mdns.ml
+57
fuzz/fuzz_mdns.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Crowbar
7
+
8
+
(* Test that parse never crashes on arbitrary input *)
9
+
let test_parse_crash_safety buf =
10
+
(match Mdns.parse buf with Some _ -> () | None -> ());
11
+
check true
12
+
13
+
(* Test that merge is associative *)
14
+
let test_merge_associative buf1 buf2 buf3 =
15
+
let r1 = match Mdns.parse buf1 with Some r -> r | None -> Mdns.empty in
16
+
let r2 = match Mdns.parse buf2 with Some r -> r | None -> Mdns.empty in
17
+
let r3 = match Mdns.parse buf3 with Some r -> r | None -> Mdns.empty in
18
+
let left = Mdns.merge [ Mdns.merge [ r1; r2 ]; r3 ] in
19
+
let right = Mdns.merge [ r1; Mdns.merge [ r2; r3 ] ] in
20
+
(* Check same number of records (order may differ) *)
21
+
if List.length left.ptrs <> List.length right.ptrs then
22
+
fail "merge not associative (ptrs)"
23
+
else if List.length left.addrs <> List.length right.addrs then
24
+
fail "merge not associative (addrs)"
25
+
else check true
26
+
27
+
(* Test that empty is identity for merge *)
28
+
let test_merge_identity buf =
29
+
match Mdns.parse buf with
30
+
| None -> check true
31
+
| Some r ->
32
+
let merged = Mdns.merge [ r; Mdns.empty ] in
33
+
if List.length r.ptrs <> List.length merged.ptrs then
34
+
fail "empty not identity for merge (ptrs)"
35
+
else if List.length r.addrs <> List.length merged.addrs then
36
+
fail "empty not identity for merge (addrs)"
37
+
else check true
38
+
39
+
(* Test that parse produces valid response structure *)
40
+
let test_parse_valid_structure buf =
41
+
match Mdns.parse buf with
42
+
| None -> check true
43
+
| Some r ->
44
+
(* All lists should be accessible without crash *)
45
+
let _ = List.length r.ptrs in
46
+
let _ = List.length r.srvs in
47
+
let _ = List.length r.txts in
48
+
let _ = List.length r.addrs in
49
+
let _ = List.length r.addrs6 in
50
+
check true
51
+
52
+
let () =
53
+
add_test ~name:"mdns: parse crash safety" [ bytes ] test_parse_crash_safety;
54
+
add_test ~name:"mdns: merge associative" [ bytes; bytes; bytes ]
55
+
test_merge_associative;
56
+
add_test ~name:"mdns: merge identity" [ bytes ] test_merge_identity;
57
+
add_test ~name:"mdns: parse valid structure" [ bytes ] test_parse_valid_structure
+4
lib/dune
+4
lib/dune
+193
lib/mdns.ml
+193
lib/mdns.ml
···
1
+
(** mDNS discovery for DNS-SD (RFC 6763).
2
+
3
+
Uses ocaml-dns for query encoding. Response parsing handles raw domain
4
+
names since the dns library's Ptr.t enforces hostname validation which
5
+
breaks DNS-SD service instance names containing spaces. *)
6
+
7
+
let multicast_addr = "224.0.0.251"
8
+
let port = 5353
9
+
10
+
type response = {
11
+
ptrs : ([ `raw ] Domain_name.t * [ `raw ] Domain_name.t) list;
12
+
srvs : ([ `raw ] Domain_name.t * int * [ `raw ] Domain_name.t) list;
13
+
txts : ([ `raw ] Domain_name.t * string list) list;
14
+
addrs : ([ `raw ] Domain_name.t * Ipaddr.V4.t) list;
15
+
addrs6 : ([ `raw ] Domain_name.t * Ipaddr.V6.t) list;
16
+
}
17
+
18
+
let empty = { ptrs = []; srvs = []; txts = []; addrs = []; addrs6 = [] }
19
+
20
+
(* Binary helpers *)
21
+
let get_u16 buf off = (Char.code buf.[off] lsl 8) lor Char.code buf.[off + 1]
22
+
23
+
(* Collect labels from a DNS name, following compression pointers *)
24
+
let collect_labels buf off =
25
+
let len = String.length buf in
26
+
let rec loop off followed acc =
27
+
(* Bounds check: need at least 1 byte to read length/pointer *)
28
+
if off < 0 || off >= len || followed > 10 then acc
29
+
else
30
+
match Char.code buf.[off] with
31
+
| 0 -> acc
32
+
| b when b land 0xc0 = 0xc0 ->
33
+
(* Compression pointer: need 2 bytes *)
34
+
if off + 2 > len then acc
35
+
else loop (get_u16 buf off land 0x3fff) (followed + 1) acc
36
+
| b ->
37
+
(* Label: need 1 + b bytes *)
38
+
if off + 1 + b > len then acc
39
+
else loop (off + 1 + b) followed (String.sub buf (off + 1) b :: acc)
40
+
in
41
+
List.rev (loop off 0 [])
42
+
43
+
let domain_of_labels labels =
44
+
match Domain_name.of_strings labels with
45
+
| Ok name -> name
46
+
| Error _ -> Domain_name.root
47
+
48
+
(* Skip past a DNS name, return new offset. Returns len on invalid input. *)
49
+
let skip_name buf off =
50
+
let len = String.length buf in
51
+
let rec loop off followed =
52
+
(* Bounds check and recursion limit *)
53
+
if off < 0 || off >= len || followed > 10 then len
54
+
else
55
+
match Char.code buf.[off] with
56
+
| 0 -> off + 1
57
+
| b when b land 0xc0 = 0xc0 ->
58
+
(* Compression pointer: skip 2 bytes, don't follow *)
59
+
if off + 2 > len then len else off + 2
60
+
| b ->
61
+
(* Label: need 1 + b bytes to exist *)
62
+
if off + 1 + b > len then len else loop (off + 1 + b) (followed + 1)
63
+
in
64
+
loop off 0
65
+
66
+
(* Parse TXT record strings with bounds checking *)
67
+
let parse_txt buf off limit =
68
+
let len = String.length buf in
69
+
let rec loop off acc =
70
+
(* Bounds check: off must be valid and within limit *)
71
+
if off < 0 || off >= limit || off >= len then List.rev acc
72
+
else
73
+
let slen = Char.code buf.[off] in
74
+
(* Check string data is within both limit and buffer *)
75
+
if off + 1 + slen <= limit && off + 1 + slen <= len then
76
+
loop (off + 1 + slen) (String.sub buf (off + 1) slen :: acc)
77
+
else List.rev acc
78
+
in
79
+
loop off []
80
+
81
+
(* Generate random 16-bit value for query ID *)
82
+
let random_u16 () = Random.int 0x10000
83
+
84
+
(* Create mDNS query using dns library *)
85
+
let make_query name =
86
+
let header = (random_u16 (), Dns.Packet.Flags.empty) in
87
+
Dns.Packet.create header
88
+
(Dns.Packet.Question.create name Dns.Rr_map.Ptr)
89
+
`Query
90
+
91
+
let encode_query name =
92
+
let pkt = make_query name in
93
+
fst (Dns.Packet.encode `Udp pkt)
94
+
95
+
(* Parse mDNS response *)
96
+
let parse buf =
97
+
let len = String.length buf in
98
+
if len < 12 then None
99
+
else
100
+
let qdcount = get_u16 buf 4 in
101
+
let rr_count = get_u16 buf 6 + get_u16 buf 8 + get_u16 buf 10 in
102
+
let off = ref 12 in
103
+
(* Skip question section with bounds checking *)
104
+
for _ = 1 to qdcount do
105
+
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 *)
109
+
done;
110
+
let ptrs = ref [] and srvs = ref [] and txts = ref [] in
111
+
let addrs = ref [] and addrs6 = ref [] in
112
+
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 = get_u16 buf off' in
120
+
let rdlen = get_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 = get_u16 buf (rdata + 4) in
139
+
let target = domain_of_labels (collect_labels buf (rdata + 6)) in
140
+
srvs := (name, port, target) :: !srvs
141
+
| _ -> ()
142
+
end
143
+
else off := len (* Invalid RR header, abort *)
144
+
end
145
+
done;
146
+
Some
147
+
{
148
+
ptrs = !ptrs;
149
+
srvs = !srvs;
150
+
txts = !txts;
151
+
addrs = !addrs;
152
+
addrs6 = !addrs6;
153
+
}
154
+
155
+
(* Query and collect responses *)
156
+
let query ~sw ~net ~clock ~timeout name =
157
+
let query_buf = encode_query name in
158
+
let sock = Eio.Net.datagram_socket ~sw net `UdpV4 in
159
+
let ip =
160
+
Eio.Net.Ipaddr.of_raw
161
+
(Ipaddr.V4.to_octets (Ipaddr.V4.of_string_exn multicast_addr))
162
+
in
163
+
let dest = `Udp (ip, port) in
164
+
Eio.Net.send sock ~dst:dest [ Cstruct.of_string query_buf ];
165
+
let responses = ref [] in
166
+
let recv_buf = Cstruct.create 4096 in
167
+
let deadline = Eio.Time.now clock +. timeout in
168
+
while Eio.Time.now clock < deadline do
169
+
match
170
+
Eio.Time.with_timeout clock
171
+
(deadline -. Eio.Time.now clock)
172
+
(fun () ->
173
+
let _, len = Eio.Net.recv sock recv_buf in
174
+
Ok (Cstruct.to_string (Cstruct.sub recv_buf 0 len)))
175
+
with
176
+
| Ok buf -> (
177
+
match parse buf with Some r -> responses := r :: !responses | None -> ())
178
+
| Error _ -> ()
179
+
done;
180
+
!responses
181
+
182
+
(* Merge multiple responses *)
183
+
let merge rs =
184
+
List.fold_left
185
+
(fun acc r ->
186
+
{
187
+
ptrs = r.ptrs @ acc.ptrs;
188
+
srvs = r.srvs @ acc.srvs;
189
+
txts = r.txts @ acc.txts;
190
+
addrs = r.addrs @ acc.addrs;
191
+
addrs6 = r.addrs6 @ acc.addrs6;
192
+
})
193
+
empty rs
+67
lib/mdns.mli
+67
lib/mdns.mli
···
1
+
(** mDNS/DNS-SD service discovery (RFC 6763).
2
+
3
+
This module implements Multicast DNS for DNS-based Service Discovery.
4
+
It uses the dns library for query encoding and handles raw domain names
5
+
to support DNS-SD service instance names containing spaces.
6
+
7
+
{2 References}
8
+
- {{:https://datatracker.ietf.org/doc/html/rfc6762} RFC 6762 - Multicast DNS}
9
+
- {{:https://datatracker.ietf.org/doc/html/rfc6763} RFC 6763 - DNS-Based Service Discovery} *)
10
+
11
+
(** {1 Types} *)
12
+
13
+
type response = {
14
+
ptrs : ([ `raw ] Domain_name.t * [ `raw ] Domain_name.t) list;
15
+
(** PTR records: service type -> service instance *)
16
+
srvs : ([ `raw ] Domain_name.t * int * [ `raw ] Domain_name.t) list;
17
+
(** SRV records: service instance, port, target host *)
18
+
txts : ([ `raw ] Domain_name.t * string list) list;
19
+
(** TXT records: service instance -> key=value pairs *)
20
+
addrs : ([ `raw ] Domain_name.t * Ipaddr.V4.t) list;
21
+
(** A records: hostname -> IPv4 address *)
22
+
addrs6 : ([ `raw ] Domain_name.t * Ipaddr.V6.t) list;
23
+
(** AAAA records: hostname -> IPv6 address *)
24
+
}
25
+
(** Parsed mDNS response containing discovered services and addresses. *)
26
+
27
+
val empty : response
28
+
(** Empty response with no records. *)
29
+
30
+
(** {1 Low-level Operations} *)
31
+
32
+
val encode_query : [ `raw ] Domain_name.t -> string
33
+
(** [encode_query name] creates an mDNS query packet for the given service type.
34
+
For example, to discover HTTP services: [encode_query "_http._tcp.local"]. *)
35
+
36
+
val parse : string -> response option
37
+
(** [parse buf] attempts to parse an mDNS response packet.
38
+
Returns [None] if the packet is malformed. *)
39
+
40
+
(** {1 High-level Query} *)
41
+
42
+
val query :
43
+
sw:Eio.Switch.t ->
44
+
net:_ Eio.Net.t ->
45
+
clock:_ Eio.Time.clock ->
46
+
timeout:float ->
47
+
[ `raw ] Domain_name.t ->
48
+
response list
49
+
(** [query ~sw ~net ~clock ~timeout name] sends an mDNS query and collects
50
+
responses until [timeout] seconds have elapsed.
51
+
52
+
@param sw Eio switch for resource management
53
+
@param net Eio network capability
54
+
@param clock Eio clock for timeout
55
+
@param timeout Maximum time to wait for responses in seconds
56
+
@param name Service type to query (e.g., "_http._tcp.local") *)
57
+
58
+
val merge : response list -> response
59
+
(** [merge responses] combines multiple responses into a single response. *)
60
+
61
+
(** {1 Constants} *)
62
+
63
+
val multicast_addr : string
64
+
(** mDNS multicast address: "224.0.0.251" *)
65
+
66
+
val port : int
67
+
(** mDNS port: 5353 *)
+35
mdns.opam
+35
mdns.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "mDNS/DNS-SD service discovery (RFC 6763)"
4
+
description:
5
+
"A pure OCaml implementation of mDNS (Multicast DNS) for DNS-SD service discovery as specified in RFC 6763. Uses Eio for async networking and the dns library for query encoding."
6
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
7
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
+
license: "MIT"
9
+
homepage: "https://tangled.org/@gazagnaire.org/ocaml-mdns"
10
+
bug-reports: "https://tangled.org/@gazagnaire.org/ocaml-mdns/issues"
11
+
depends: [
12
+
"dune" {>= "3.0"}
13
+
"ocaml" {>= "4.08"}
14
+
"eio" {>= "1.0"}
15
+
"dns" {>= "9.0"}
16
+
"ipaddr" {>= "5.0"}
17
+
"domain-name" {>= "0.4"}
18
+
"alcotest" {with-test}
19
+
"crowbar" {with-test}
20
+
"odoc" {with-doc}
21
+
]
22
+
build: [
23
+
["dune" "subst"] {dev}
24
+
[
25
+
"dune"
26
+
"build"
27
+
"-p"
28
+
name
29
+
"-j"
30
+
jobs
31
+
"@install"
32
+
"@runtest" {with-test}
33
+
"@doc" {with-doc}
34
+
]
35
+
]
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "mdns" Test_mdns.suite
+159
test/test_mdns.ml
+159
test/test_mdns.ml
···
1
+
(** Tests for mDNS parsing. *)
2
+
3
+
(* Helper to build minimal DNS packets *)
4
+
let header ?(ancount = 0) ?(arcount = 0) () =
5
+
let buf = Bytes.create 12 in
6
+
Bytes.set_uint16_be buf 6 ancount;
7
+
Bytes.set_uint16_be buf 10 arcount;
8
+
Bytes.to_string buf
9
+
10
+
let dns_name labels =
11
+
let buf = Buffer.create 64 in
12
+
List.iter
13
+
(fun l ->
14
+
Buffer.add_char buf (Char.chr (String.length l));
15
+
Buffer.add_string buf l)
16
+
labels;
17
+
Buffer.add_char buf '\x00';
18
+
Buffer.contents buf
19
+
20
+
let rr_header typ rdlen =
21
+
let buf = Bytes.create 10 in
22
+
Bytes.set_uint16_be buf 0 typ;
23
+
Bytes.set_uint16_be buf 2 1;
24
+
Bytes.set_int32_be buf 4 120l;
25
+
Bytes.set_uint16_be buf 8 rdlen;
26
+
Bytes.to_string buf
27
+
28
+
let test_ptr_with_space () =
29
+
(* rdlen = 9+1 + 4+1 + 4+1 + 5+1 + 1 = 27 bytes *)
30
+
let pkt =
31
+
header ~ancount:1 ()
32
+
^ dns_name [ "_hap"; "_tcp"; "local" ]
33
+
^ rr_header 12 27
34
+
^ dns_name [ "My Device"; "_hap"; "_tcp"; "local" ]
35
+
in
36
+
match Mdns.parse pkt with
37
+
| None -> Alcotest.fail "Failed to parse"
38
+
| Some r ->
39
+
Alcotest.(check int) "PTR count" 1 (List.length r.ptrs);
40
+
let _, instance = List.hd r.ptrs in
41
+
let name =
42
+
match Domain_name.get_label instance 0 with Ok n -> n | Error _ -> ""
43
+
in
44
+
Alcotest.(check string) "Instance name" "My Device" name
45
+
46
+
let test_srv () =
47
+
let target = dns_name [ "mydevice"; "local" ] in
48
+
let srv_rdata =
49
+
let buf = Bytes.create 6 in
50
+
Bytes.set_uint16_be buf 4 8080;
51
+
Bytes.to_string buf ^ target
52
+
in
53
+
let pkt =
54
+
header ~ancount:1 ()
55
+
^ dns_name [ "myservice"; "_tcp"; "local" ]
56
+
^ rr_header 33 (String.length srv_rdata)
57
+
^ srv_rdata
58
+
in
59
+
match Mdns.parse pkt with
60
+
| None -> Alcotest.fail "Failed to parse"
61
+
| Some r ->
62
+
Alcotest.(check int) "SRV count" 1 (List.length r.srvs);
63
+
let _, port, _ = List.hd r.srvs in
64
+
Alcotest.(check int) "Port" 8080 port
65
+
66
+
let test_txt () =
67
+
let txt_rdata = "\x04id=1\x04md=X" in
68
+
let pkt =
69
+
header ~ancount:1 ()
70
+
^ dns_name [ "mydevice"; "local" ]
71
+
^ rr_header 16 (String.length txt_rdata)
72
+
^ txt_rdata
73
+
in
74
+
match Mdns.parse pkt with
75
+
| None -> Alcotest.fail "Failed to parse"
76
+
| Some r ->
77
+
Alcotest.(check int) "TXT count" 1 (List.length r.txts);
78
+
let _, txts = List.hd r.txts in
79
+
Alcotest.(check int) "TXT strings" 2 (List.length txts);
80
+
Alcotest.(check string) "TXT[0]" "id=1" (List.nth txts 0)
81
+
82
+
let test_a () =
83
+
let pkt =
84
+
header ~ancount:1 ()
85
+
^ dns_name [ "mydevice"; "local" ]
86
+
^ rr_header 1 4 ^ "\xc0\xa8\x00\x23"
87
+
in
88
+
match Mdns.parse pkt with
89
+
| None -> Alcotest.fail "Failed to parse"
90
+
| Some r ->
91
+
Alcotest.(check int) "A count" 1 (List.length r.addrs);
92
+
let _, ip = List.hd r.addrs in
93
+
Alcotest.(check string) "IP" "192.168.0.35" (Ipaddr.V4.to_string ip)
94
+
95
+
let test_aaaa () =
96
+
(* 2001:db8::1 *)
97
+
let v6 =
98
+
let b = Bytes.create 16 in
99
+
Bytes.set_uint16_be b 0 0x2001;
100
+
Bytes.set_uint16_be b 2 0x0db8;
101
+
Bytes.set_uint16_be b 4 0x0000;
102
+
Bytes.set_uint16_be b 6 0x0000;
103
+
Bytes.set_uint16_be b 8 0x0000;
104
+
Bytes.set_uint16_be b 10 0x0000;
105
+
Bytes.set_uint16_be b 12 0x0000;
106
+
Bytes.set_uint16_be b 14 0x0001;
107
+
Bytes.to_string b
108
+
in
109
+
let pkt =
110
+
header ~ancount:1 ()
111
+
^ dns_name [ "mydevice"; "local" ]
112
+
^ rr_header 28 16 ^ v6
113
+
in
114
+
match Mdns.parse pkt with
115
+
| None -> Alcotest.fail "Failed to parse AAAA"
116
+
| Some r ->
117
+
Alcotest.(check int) "AAAA count" 1 (List.length r.addrs6);
118
+
let _, ip = List.hd r.addrs6 in
119
+
Alcotest.(check string) "IPv6" "2001:db8::1" (Ipaddr.V6.to_string ip)
120
+
121
+
let test_empty () =
122
+
Alcotest.(check bool) "Too short" true (Mdns.parse "" = None);
123
+
Alcotest.(check bool)
124
+
"Just header" true
125
+
(Mdns.parse "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00" <> None)
126
+
127
+
let test_merge () =
128
+
let r1 =
129
+
{ Mdns.empty with ptrs = [ (Domain_name.root, Domain_name.root) ] }
130
+
in
131
+
let r2 =
132
+
{ Mdns.empty with srvs = [ (Domain_name.root, 80, Domain_name.root) ] }
133
+
in
134
+
let merged = Mdns.merge [ r1; r2 ] in
135
+
Alcotest.(check int) "Merged PTRs" 1 (List.length merged.ptrs);
136
+
Alcotest.(check int) "Merged SRVs" 1 (List.length merged.srvs)
137
+
138
+
let test_encode () =
139
+
let name = Domain_name.of_string_exn "_hap._tcp.local" in
140
+
let buf = Mdns.encode_query name in
141
+
Alcotest.(check bool) "Query not empty" true (String.length buf > 12);
142
+
let len = String.length buf in
143
+
let qtype = (Char.code buf.[len - 4] lsl 8) lor Char.code buf.[len - 3] in
144
+
Alcotest.(check int) "QTYPE is PTR" 12 qtype
145
+
146
+
let suite =
147
+
[
148
+
( "parse",
149
+
[
150
+
Alcotest.test_case "PTR with space" `Quick test_ptr_with_space;
151
+
Alcotest.test_case "SRV" `Quick test_srv;
152
+
Alcotest.test_case "TXT" `Quick test_txt;
153
+
Alcotest.test_case "A" `Quick test_a;
154
+
Alcotest.test_case "AAAA" `Quick test_aaaa;
155
+
Alcotest.test_case "empty" `Quick test_empty;
156
+
] );
157
+
("merge", [ Alcotest.test_case "merge responses" `Quick test_merge ]);
158
+
("encode", [ Alcotest.test_case "encode query" `Quick test_encode ]);
159
+
]