Matter smart home protocol implementation for OCaml
Squashed 'ocaml-matter/' content from commit f8ab743 git-subtree-split: f8ab743637244f925f92891cff87d02a7f873ff9
+3269
+17
.gitignore
+17
.gitignore
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.28.1
+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.
+61
README.md
+61
README.md
···
1
+
# matter
2
+
3
+
Matter protocol implementation for OCaml.
4
+
5
+
## Overview
6
+
7
+
This library provides an implementation of the Matter smart home protocol
8
+
as specified in the [Matter Core Specification](https://csa-iot.org/developer-resource/specifications-download-request/).
9
+
10
+
## Features
11
+
12
+
- TLV (Tag-Length-Value) encoding and decoding
13
+
- Support for all Matter TLV types: integers, booleans, floats, strings, bytes, null
14
+
- Nested containers: structures, arrays, lists
15
+
- All tag forms: anonymous, context-specific, common/implicit profile, fully-qualified
16
+
17
+
## Installation
18
+
19
+
```
20
+
opam install matter
21
+
```
22
+
23
+
## Usage
24
+
25
+
```ocaml
26
+
open Matter.Tlv
27
+
28
+
(* Create elements *)
29
+
let elem = structure [
30
+
ctx_int 1 42;
31
+
ctx_string 2 "hello";
32
+
ctx_bool 3 true;
33
+
]
34
+
35
+
(* Encode to binary *)
36
+
let binary = encode_one elem
37
+
38
+
(* Decode from binary *)
39
+
match decode binary with
40
+
| Ok elements -> (* process elements *)
41
+
| Error msg -> (* handle error *)
42
+
```
43
+
44
+
## API
45
+
46
+
### TLV Module
47
+
48
+
- `Matter.Tlv.encode` - Encode elements to binary TLV
49
+
- `Matter.Tlv.decode` - Decode binary TLV to elements
50
+
- `Matter.Tlv.int`, `uint`, `bool`, `string`, `bytes`, `null` - Value constructors
51
+
- `Matter.Tlv.structure`, `array`, `list` - Container constructors
52
+
- `Matter.Tlv.ctx_int`, `ctx_uint`, etc. - Context-tagged constructors
53
+
54
+
## Related Work
55
+
56
+
- [matter-go](https://github.com/project-chip/connectedhomeip) - Reference implementation in C++
57
+
- [matter-rs](https://github.com/project-chip/matter-rs) - Rust implementation
58
+
59
+
## License
60
+
61
+
MIT License. See [LICENSE.md](LICENSE.md) for details.
+5
bin/dune
+5
bin/dune
+257
bin/matter_cli.ml
+257
bin/matter_cli.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** matter - Matter device discovery and control CLI *)
7
+
8
+
open Cmdliner
9
+
10
+
(* Exit code for errors *)
11
+
let exit_error = 1
12
+
13
+
(* Device filter for discover command *)
14
+
type device_filter = Operational | Commissionable | All
15
+
16
+
let device_filter_conv =
17
+
let parse = function
18
+
| "operational" | "op" -> Ok Operational
19
+
| "commissionable" | "comm" -> Ok Commissionable
20
+
| "all" -> Ok All
21
+
| s ->
22
+
Error
23
+
(`Msg
24
+
(Fmt.str
25
+
"unknown filter %S, expected: operational, commissionable, all"
26
+
s))
27
+
in
28
+
let print ppf = function
29
+
| Operational -> Fmt.string ppf "operational"
30
+
| Commissionable -> Fmt.string ppf "commissionable"
31
+
| All -> Fmt.string ppf "all"
32
+
in
33
+
Arg.conv (parse, print)
34
+
35
+
(* Power action for control command *)
36
+
type power_action = On | Off | Toggle
37
+
38
+
let power_action_conv =
39
+
let parse = function
40
+
| "on" -> Ok On
41
+
| "off" -> Ok Off
42
+
| "toggle" -> Ok Toggle
43
+
| s ->
44
+
Error (`Msg (Fmt.str "unknown action %S, expected: on, off, toggle" s))
45
+
in
46
+
let print ppf = function
47
+
| On -> Fmt.string ppf "on"
48
+
| Off -> Fmt.string ppf "off"
49
+
| Toggle -> Fmt.string ppf "toggle"
50
+
in
51
+
Arg.conv (parse, print)
52
+
53
+
(* Common arguments *)
54
+
let timeout_arg =
55
+
let doc = "Timeout in seconds for network operations." in
56
+
Arg.(value & opt float 3.0 & info [ "t"; "timeout" ] ~docv:"SECONDS" ~doc)
57
+
58
+
let quiet_arg =
59
+
let doc = "Suppress informational messages." in
60
+
Arg.(value & flag & info [ "q"; "quiet" ] ~doc)
61
+
62
+
(* Discover command *)
63
+
let discover_cmd =
64
+
let doc = "Discover Matter devices on the local network" in
65
+
let man =
66
+
[
67
+
`S Manpage.s_description;
68
+
`P
69
+
"Discovers Matter devices using mDNS/DNS-SD. By default, shows \
70
+
operational devices (already commissioned). Use $(b,--filter) to \
71
+
change which devices are shown.";
72
+
`P "Exit status is 0 if devices were found, 1 otherwise.";
73
+
`S Manpage.s_examples;
74
+
`P "Find operational devices:";
75
+
`Pre " $(mname) $(tname)";
76
+
`P "Find devices in pairing mode:";
77
+
`Pre " $(mname) $(tname) --filter commissionable";
78
+
`P "Find all Matter devices:";
79
+
`Pre " $(mname) $(tname) -f all";
80
+
]
81
+
in
82
+
let info = Cmd.info "discover" ~doc ~man in
83
+
let filter_arg =
84
+
let doc =
85
+
"Filter devices: $(b,operational) (default) shows commissioned devices, \
86
+
$(b,commissionable) shows devices in pairing mode, $(b,all) shows both."
87
+
in
88
+
Arg.(
89
+
value
90
+
& opt device_filter_conv Operational
91
+
& info [ "f"; "filter" ] ~docv:"FILTER" ~doc)
92
+
in
93
+
let run timeout quiet filter =
94
+
Eio_main.run @@ fun env ->
95
+
Eio.Switch.run @@ fun sw ->
96
+
let net = Eio.Stdenv.net env in
97
+
let clock = Eio.Stdenv.clock env in
98
+
let devices =
99
+
match filter with
100
+
| Operational ->
101
+
Matter.Discovery.discover_operational ~sw ~net ~clock ~timeout ()
102
+
| Commissionable ->
103
+
Matter.Discovery.discover_commissionable ~sw ~net ~clock ~timeout ()
104
+
| All -> Matter.Discovery.discover_all ~sw ~net ~clock ~timeout ()
105
+
in
106
+
if devices = [] then begin
107
+
if not quiet then Fmt.pr "No devices found.@.";
108
+
exit exit_error
109
+
end
110
+
else Fmt.pr "%a@." Matter.Discovery.pp devices
111
+
in
112
+
Cmd.v info Term.(const run $ timeout_arg $ quiet_arg $ filter_arg)
113
+
114
+
(* Commission command *)
115
+
let commission_cmd =
116
+
let doc = "Establish a PASE session with a Matter device" in
117
+
let man =
118
+
[
119
+
`S Manpage.s_description;
120
+
`P
121
+
"Establishes a secure session with a Matter device using the device's \
122
+
passcode (PASE protocol). This is the first step in commissioning a \
123
+
new device.";
124
+
`P
125
+
"The passcode is typically an 8-digit number printed on the device or \
126
+
its packaging (e.g., 20202021).";
127
+
`S Manpage.s_examples;
128
+
`P "Commission a device:";
129
+
`Pre " $(mname) $(tname) 192.168.1.100 --passcode 20202021";
130
+
`P "With non-default port:";
131
+
`Pre " $(mname) $(tname) 192.168.1.100 -p 5541 --passcode 20202021";
132
+
]
133
+
in
134
+
let info = Cmd.info "commission" ~doc ~man in
135
+
let ip_arg =
136
+
let doc = "IP address of the Matter device." in
137
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"IP" ~doc)
138
+
in
139
+
let port_arg =
140
+
let doc = "UDP port of the Matter device." in
141
+
Arg.(value & opt int 5540 & info [ "p"; "port" ] ~docv:"PORT" ~doc)
142
+
in
143
+
let passcode_arg =
144
+
let doc = "Device passcode (8-digit number)." in
145
+
Arg.(required & opt (some int) None & info [ "passcode" ] ~docv:"CODE" ~doc)
146
+
in
147
+
let run quiet ip port passcode =
148
+
Eio_main.run @@ fun env ->
149
+
Eio.Switch.run @@ fun sw ->
150
+
let net = Eio.Stdenv.net env in
151
+
let clock = Eio.Stdenv.clock env in
152
+
if not quiet then Fmt.pr "Commissioning %s:%d...@." ip port;
153
+
match Matter.Session.establish_pase ~net ~sw ~clock ~ip ~port ~passcode with
154
+
| Ok conn ->
155
+
if not quiet then begin
156
+
Fmt.pr "PASE successful.@.";
157
+
Fmt.pr "Session: %a@." Matter.Session.pp_session conn.session
158
+
end
159
+
| Error (`Msg e) ->
160
+
Fmt.epr "Error: %s@." e;
161
+
exit exit_error
162
+
in
163
+
Cmd.v info Term.(const run $ quiet_arg $ ip_arg $ port_arg $ passcode_arg)
164
+
165
+
(* Control command - unified on/off/toggle *)
166
+
let control_cmd =
167
+
let doc = "Control power state of a Matter device" in
168
+
let man =
169
+
[
170
+
`S Manpage.s_description;
171
+
`P
172
+
"Sends a power control command (on, off, or toggle) to a Matter \
173
+
device. Requires the device passcode for authentication.";
174
+
`S Manpage.s_examples;
175
+
`P "Turn on a device:";
176
+
`Pre " $(mname) $(tname) on 192.168.1.100 --passcode 20202021";
177
+
`P "Turn off with specific endpoint:";
178
+
`Pre " $(mname) $(tname) off 192.168.1.100 --passcode 20202021 -e 2";
179
+
`P "Toggle device state:";
180
+
`Pre " $(mname) $(tname) toggle 192.168.1.100 --passcode 20202021";
181
+
]
182
+
in
183
+
let info = Cmd.info "control" ~doc ~man in
184
+
let action_arg =
185
+
let doc = "Power action: $(b,on), $(b,off), or $(b,toggle)." in
186
+
Arg.(
187
+
required
188
+
& pos 0 (some power_action_conv) None
189
+
& info [] ~docv:"ACTION" ~doc)
190
+
in
191
+
let ip_arg =
192
+
let doc = "IP address of the Matter device." in
193
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"IP" ~doc)
194
+
in
195
+
let port_arg =
196
+
let doc = "UDP port of the Matter device." in
197
+
Arg.(value & opt int 5540 & info [ "p"; "port" ] ~docv:"PORT" ~doc)
198
+
in
199
+
let passcode_arg =
200
+
let doc = "Device passcode (8-digit number)." in
201
+
Arg.(required & opt (some int) None & info [ "passcode" ] ~docv:"CODE" ~doc)
202
+
in
203
+
let endpoint_arg =
204
+
let doc = "Endpoint ID for the on/off cluster." in
205
+
Arg.(value & opt int 1 & info [ "e"; "endpoint" ] ~docv:"ID" ~doc)
206
+
in
207
+
let run quiet action ip port passcode endpoint =
208
+
Eio_main.run @@ fun env ->
209
+
Eio.Switch.run @@ fun sw ->
210
+
let net = Eio.Stdenv.net env in
211
+
let clock = Eio.Stdenv.clock env in
212
+
match Matter.Session.establish_pase ~net ~sw ~clock ~ip ~port ~passcode with
213
+
| Error (`Msg e) ->
214
+
Fmt.epr "PASE error: %s@." e;
215
+
exit exit_error
216
+
| Ok conn -> (
217
+
let cmd_fn =
218
+
match action with
219
+
| On -> Matter.Session.turn_on
220
+
| Off -> Matter.Session.turn_off
221
+
| Toggle -> Matter.Session.toggle
222
+
in
223
+
let action_str =
224
+
match action with On -> "on" | Off -> "off" | Toggle -> "toggled"
225
+
in
226
+
match cmd_fn ~clock conn ~endpoint_id:endpoint with
227
+
| Ok _ -> if not quiet then Fmt.pr "Device turned %s.@." action_str
228
+
| Error `Timeout ->
229
+
Fmt.epr "Error: timeout waiting for response.@.";
230
+
exit exit_error)
231
+
in
232
+
Cmd.v info
233
+
Term.(
234
+
const run $ quiet_arg $ action_arg $ ip_arg $ port_arg $ passcode_arg
235
+
$ endpoint_arg)
236
+
237
+
(* Main command group *)
238
+
let cmd =
239
+
let doc = "Matter device discovery and control" in
240
+
let man =
241
+
[
242
+
`S Manpage.s_description;
243
+
`P
244
+
"$(tname) provides tools for discovering and controlling Matter smart \
245
+
home devices on the local network.";
246
+
`S Manpage.s_commands;
247
+
`P "$(b,discover) - Find Matter devices using mDNS";
248
+
`P "$(b,commission) - Establish PASE session with a device";
249
+
`P "$(b,control) - Send on/off/toggle commands";
250
+
`S Manpage.s_bugs;
251
+
`P "Report issues at https://github.com/samoht/ocaml-matter/issues";
252
+
]
253
+
in
254
+
let info = Cmd.info "matter" ~version:"%%VERSION%%" ~doc ~man in
255
+
Cmd.group info [ discover_cmd; commission_cmd; control_cmd ]
256
+
257
+
let () = exit (Cmd.eval cmd)
+37
dune-project
+37
dune-project
···
1
+
(lang dune 3.0)
2
+
3
+
(name matter)
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://github.com/samoht/ocaml-matter")
11
+
(bug_reports "https://github.com/samoht/ocaml-matter/issues")
12
+
13
+
(package
14
+
(name matter)
15
+
(synopsis "Matter protocol implementation for OCaml")
16
+
(description
17
+
"Implementation of the Matter smart home protocol for OCaml.
18
+
Includes TLV encoding/decoding, PASE authentication using SPAKE2+,
19
+
message framing, mDNS device discovery, and AES-CCM encryption
20
+
as specified in the Matter Core Specification.")
21
+
(depends
22
+
(ocaml (>= 4.14))
23
+
(dune-configurator (< 3.21))
24
+
(digestif (>= 1.0))
25
+
(eio (>= 1.0))
26
+
(kdf (>= 0.1))
27
+
(mdns (>= 0.1))
28
+
(spake2 (>= 0.1))
29
+
(crypto (>= 1.0))
30
+
(crypto-rng (>= 1.0))
31
+
(cstruct (>= 6.0))
32
+
(ipaddr (>= 5.0))
33
+
(domain-name (>= 0.4))
34
+
(logs (>= 0.7))
35
+
(fmt (>= 0.9))
36
+
(alcotest :with-test)
37
+
(crowbar :with-test)))
+15
fuzz/dune
+15
fuzz/dune
···
1
+
; Crowbar fuzz testing for matter
2
+
;
3
+
; To run: dune exec fuzz/fuzz_tlv.exe
4
+
; With AFL: afl-fuzz -i fuzz/corpus -o fuzz/findings -- ./_build/default/fuzz/fuzz_tlv.exe @@
5
+
6
+
(executable
7
+
(name fuzz_tlv)
8
+
(modules fuzz_tlv)
9
+
(libraries matter crowbar))
10
+
11
+
(rule
12
+
(alias fuzz)
13
+
(deps fuzz_tlv.exe)
14
+
(action
15
+
(run %{exe:fuzz_tlv.exe})))
+160
fuzz/fuzz_tlv.ml
+160
fuzz/fuzz_tlv.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Crowbar-based fuzz testing for Matter TLV roundtripping *)
7
+
8
+
open Crowbar
9
+
module Tlv = Matter.Tlv
10
+
11
+
(* Compare TLV values for equality, handling floats by bit pattern *)
12
+
let rec value_equal (a : Tlv.value) (b : Tlv.value) =
13
+
match (a, b) with
14
+
| Tlv.Int x, Tlv.Int y -> x = y
15
+
| Tlv.Uint x, Tlv.Uint y -> x = y
16
+
| Tlv.Bool x, Tlv.Bool y -> x = y
17
+
| Tlv.Float32 x, Tlv.Float32 y ->
18
+
(* Compare bit patterns to handle -0.0, NaN variants *)
19
+
Int32.bits_of_float x = Int32.bits_of_float y
20
+
| Tlv.Float64 x, Tlv.Float64 y ->
21
+
(* Compare bit patterns to handle -0.0, NaN variants *)
22
+
Int64.bits_of_float x = Int64.bits_of_float y
23
+
| Tlv.String x, Tlv.String y -> String.equal x y
24
+
| Tlv.Bytes x, Tlv.Bytes y -> String.equal x y
25
+
| Tlv.Null, Tlv.Null -> true
26
+
| Tlv.Structure xs, Tlv.Structure ys -> elements_equal xs ys
27
+
| Tlv.Array xs, Tlv.Array ys -> elements_equal xs ys
28
+
| Tlv.List xs, Tlv.List ys -> elements_equal xs ys
29
+
| _ -> false
30
+
31
+
and tag_equal (a : Tlv.tag_form) (b : Tlv.tag_form) =
32
+
match (a, b) with
33
+
| Tlv.Anonymous, Tlv.Anonymous -> true
34
+
| Tlv.Context_specific x, Tlv.Context_specific y -> x = y
35
+
| Tlv.Common_profile_2 x, Tlv.Common_profile_2 y -> x = y
36
+
| Tlv.Common_profile_4 x, Tlv.Common_profile_4 y -> x = y
37
+
| Tlv.Implicit_profile_2 x, Tlv.Implicit_profile_2 y -> x = y
38
+
| Tlv.Implicit_profile_4 x, Tlv.Implicit_profile_4 y -> x = y
39
+
| Tlv.Fully_qualified_6 (v1, t1), Tlv.Fully_qualified_6 (v2, t2) ->
40
+
v1 = v2 && t1 = t2
41
+
| Tlv.Fully_qualified_8 (v1, t1), Tlv.Fully_qualified_8 (v2, t2) ->
42
+
v1 = v2 && t1 = t2
43
+
| _ -> false
44
+
45
+
and element_equal (a : Tlv.element) (b : Tlv.element) =
46
+
tag_equal a.tag b.tag && value_equal a.value b.value
47
+
48
+
and elements_equal xs ys =
49
+
List.length xs = List.length ys && List.for_all2 element_equal xs ys
50
+
51
+
(* Generator for tag forms *)
52
+
let tag_form_gen =
53
+
choose
54
+
[
55
+
const Tlv.Anonymous;
56
+
map [ range 256 ] (fun t -> Tlv.Context_specific t);
57
+
map [ range 65536 ] (fun t -> Tlv.Common_profile_2 t);
58
+
map [ int32 ] (fun t -> Tlv.Common_profile_4 t);
59
+
map [ range 65536 ] (fun t -> Tlv.Implicit_profile_2 t);
60
+
map [ int32 ] (fun t -> Tlv.Implicit_profile_4 t);
61
+
map [ int32; range 65536 ] (fun v t -> Tlv.Fully_qualified_6 (v, t));
62
+
map [ int32; int32 ] (fun v t -> Tlv.Fully_qualified_8 (v, t));
63
+
]
64
+
65
+
(* Generator for TLV values using fix for recursive structures *)
66
+
let tlv_value_gen : Tlv.value gen =
67
+
fix (fun tlv_value_gen ->
68
+
let leaf_gen =
69
+
choose
70
+
[
71
+
map [ int64 ] (fun v -> Tlv.Int v);
72
+
(* Avoid Int64.min_int which causes abs overflow *)
73
+
map [ int64 ] (fun v ->
74
+
let v = if v = Int64.min_int then 0L else Int64.abs v in
75
+
Tlv.Uint v);
76
+
map [ Crowbar.bool ] (fun v -> Tlv.Bool v);
77
+
map [ float ] (fun f -> Tlv.Float32 f);
78
+
map [ float ] (fun f -> Tlv.Float64 f);
79
+
map [ bytes ] (fun s -> Tlv.String s);
80
+
map [ bytes ] (fun s -> Tlv.Bytes s);
81
+
const Tlv.Null;
82
+
]
83
+
in
84
+
let element_gen =
85
+
map [ tag_form_gen; tlv_value_gen ] (fun tag value ->
86
+
Tlv.{ tag; value })
87
+
in
88
+
let compound_gen =
89
+
choose
90
+
[
91
+
map [ list element_gen ] (fun elems -> Tlv.Structure elems);
92
+
map [ list element_gen ] (fun elems -> Tlv.Array elems);
93
+
map [ list element_gen ] (fun elems -> Tlv.List elems);
94
+
]
95
+
in
96
+
(* Bias heavily towards leaf nodes to avoid deeply nested structures *)
97
+
choose [ leaf_gen; leaf_gen; leaf_gen; leaf_gen; compound_gen ])
98
+
99
+
(* Generator for TLV elements *)
100
+
let tlv_element_gen : Tlv.element gen =
101
+
map [ tag_form_gen; tlv_value_gen ] (fun tag value -> Tlv.{ tag; value })
102
+
103
+
(* Test encode-decode roundtrip from generated values *)
104
+
let test_encode_decode_roundtrip elem =
105
+
let encoded = Tlv.encode_one elem in
106
+
match Tlv.decode encoded with
107
+
| Ok [ decoded ] -> check_eq ~eq:element_equal ~pp:Tlv.pp_element elem decoded
108
+
| Ok _ -> fail "Expected single element after decode"
109
+
| Error e -> fail ("Decode failed on encoded data: " ^ e)
110
+
111
+
(* Test decode-encode roundtrip from raw bytes *)
112
+
let test_decode_encode_roundtrip input =
113
+
match Tlv.decode input with
114
+
| Ok elements -> (
115
+
(* Encode back to bytes *)
116
+
let encoded = Tlv.encode elements in
117
+
(* Decode again *)
118
+
match Tlv.decode encoded with
119
+
| Ok elements2 ->
120
+
check_eq ~eq:elements_equal ~pp:Tlv.pp elements elements2
121
+
| Error e -> fail ("Re-decode failed: " ^ e))
122
+
| Error _ ->
123
+
(* Invalid TLV input is fine, just ensure no crash *)
124
+
()
125
+
126
+
(* Test that decode never crashes on arbitrary input *)
127
+
let test_decode_no_crash data =
128
+
let _ = Tlv.decode data in
129
+
()
130
+
131
+
(* Test that encode never crashes *)
132
+
let test_encode_no_crash elem =
133
+
let _ = Tlv.encode_one elem in
134
+
()
135
+
136
+
(* Test that pp functions never crash *)
137
+
let test_pp_no_crash elem =
138
+
let _ = Format.asprintf "%a" Tlv.pp_element elem in
139
+
()
140
+
141
+
(* Test multiple elements roundtrip *)
142
+
let test_multiple_roundtrip elems =
143
+
let encoded = Tlv.encode elems in
144
+
match Tlv.decode encoded with
145
+
| Ok decoded ->
146
+
let re_encoded = Tlv.encode decoded in
147
+
check_eq ~pp:(fun ppf s -> Fmt.pf ppf "%S" s) encoded re_encoded
148
+
| Error e -> fail ("Decode failed: " ^ e)
149
+
150
+
let () =
151
+
add_test ~name:"tlv: encode-decode roundtrip" [ tlv_element_gen ]
152
+
test_encode_decode_roundtrip;
153
+
add_test ~name:"tlv: decode-encode roundtrip" [ bytes ]
154
+
test_decode_encode_roundtrip;
155
+
add_test ~name:"tlv: decode no crash" [ bytes ] test_decode_no_crash;
156
+
add_test ~name:"tlv: encode no crash" [ tlv_element_gen ] test_encode_no_crash;
157
+
add_test ~name:"tlv: pp no crash" [ tlv_element_gen ] test_pp_no_crash;
158
+
add_test ~name:"tlv: multiple roundtrip"
159
+
[ list tlv_element_gen ]
160
+
test_multiple_roundtrip
+225
lib/discovery.ml
+225
lib/discovery.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter protocol support - mDNS discovery *)
7
+
8
+
(** {1 Types} *)
9
+
10
+
type vendor_product = { vendor_id : int; product_id : int }
11
+
12
+
type commissionable_device = {
13
+
instance_name : string;
14
+
hostname : string;
15
+
port : int;
16
+
ip : string option;
17
+
vendor_product : vendor_product option;
18
+
discriminator : int option;
19
+
commissioning_mode : int option;
20
+
device_type : int option;
21
+
pairing_hint : int option;
22
+
pairing_instruction : string option;
23
+
}
24
+
25
+
type operational_device = {
26
+
instance_name : string;
27
+
fabric_id : string;
28
+
node_id : string;
29
+
hostname : string;
30
+
port : int;
31
+
ip : string option;
32
+
vendor_product : vendor_product option;
33
+
compressed_fabric_id : string option;
34
+
}
35
+
36
+
type device =
37
+
| Commissionable of commissionable_device
38
+
| Operational of operational_device
39
+
40
+
(** {1 TXT Record Parsing} *)
41
+
42
+
let parse_txt_records txt =
43
+
List.filter_map
44
+
(fun s ->
45
+
match String.split_on_char '=' s with
46
+
| [ k; v ] -> Some (String.trim k, String.trim v)
47
+
| [ k ] -> Some (String.trim k, "")
48
+
| _ -> None)
49
+
txt
50
+
51
+
let get_txt key txt = List.assoc_opt key txt
52
+
53
+
let get_txt_int key txt =
54
+
Option.bind (get_txt key txt) (fun v ->
55
+
try Some (int_of_string v) with Failure _ -> None)
56
+
57
+
let parse_vendor_product txt =
58
+
Option.bind (get_txt "VP" txt) (fun vp ->
59
+
match String.split_on_char '+' vp with
60
+
| [ vid; pid ] -> (
61
+
try
62
+
Some
63
+
{ vendor_id = int_of_string vid; product_id = int_of_string pid }
64
+
with Failure _ -> None)
65
+
| _ -> None)
66
+
67
+
let parse_instance_name name =
68
+
match String.split_on_char '-' name with
69
+
| [ fabric; node ] when String.length fabric = 16 -> Some (fabric, node)
70
+
| _ -> None
71
+
72
+
(** {1 Discovery Functions} *)
73
+
74
+
let discover_matter ~sw ~net ~clock ~timeout service_type =
75
+
let service_name = Domain_name.of_string_exn (service_type ^ ".local") in
76
+
let r = Mdns.merge (Mdns.query ~sw ~net ~clock ~timeout service_name) in
77
+
let devices = ref [] in
78
+
(* Process PTR records *)
79
+
List.iter
80
+
(fun (_, instance) ->
81
+
let instance_str = Domain_name.to_string instance in
82
+
let name =
83
+
match Domain_name.get_label instance 0 with
84
+
| Ok n -> n
85
+
| Error _ -> instance_str
86
+
in
87
+
(* Find SRV record *)
88
+
let hostname, port =
89
+
match
90
+
List.find_opt
91
+
(fun (n, _, _) -> Domain_name.equal n instance)
92
+
r.Mdns.srvs
93
+
with
94
+
| Some (_, p, t) -> (Domain_name.to_string t, p)
95
+
| None -> ("", 5540)
96
+
in
97
+
(* Find TXT record *)
98
+
let txt =
99
+
match
100
+
List.find_map
101
+
(fun (n, t) ->
102
+
if Domain_name.equal n instance then Some t else None)
103
+
r.Mdns.txts
104
+
with
105
+
| Some t -> parse_txt_records t
106
+
| None -> []
107
+
in
108
+
(* Find IP address *)
109
+
let ip =
110
+
List.find_map
111
+
(fun (n, addr) ->
112
+
if Domain_name.to_string n = hostname then
113
+
Some (Ipaddr.V4.to_string addr)
114
+
else None)
115
+
r.Mdns.addrs
116
+
in
117
+
let vp = parse_vendor_product txt in
118
+
let device =
119
+
if service_type = "_matterc._udp" then
120
+
Commissionable
121
+
{
122
+
instance_name = name;
123
+
hostname;
124
+
port;
125
+
ip;
126
+
vendor_product = vp;
127
+
discriminator = get_txt_int "D" txt;
128
+
commissioning_mode = get_txt_int "CM" txt;
129
+
device_type = get_txt_int "DT" txt;
130
+
pairing_hint = get_txt_int "PH" txt;
131
+
pairing_instruction = get_txt "PI" txt;
132
+
}
133
+
else
134
+
let fabric_id, node_id =
135
+
match parse_instance_name name with
136
+
| Some (f, n) -> (f, n)
137
+
| None -> ("", name)
138
+
in
139
+
Operational
140
+
{
141
+
instance_name = name;
142
+
fabric_id;
143
+
node_id;
144
+
hostname;
145
+
port;
146
+
ip;
147
+
vendor_product = vp;
148
+
compressed_fabric_id = get_txt "ICD" txt;
149
+
}
150
+
in
151
+
if
152
+
not
153
+
(List.exists
154
+
(fun d ->
155
+
match (d, device) with
156
+
| Commissionable a, Commissionable b ->
157
+
a.instance_name = b.instance_name
158
+
| Operational a, Operational b ->
159
+
a.instance_name = b.instance_name
160
+
| _ -> false)
161
+
!devices)
162
+
then devices := device :: !devices)
163
+
r.Mdns.ptrs;
164
+
!devices
165
+
166
+
let discover_commissionable ~sw ~net ~clock ?(timeout = 3.0) () =
167
+
discover_matter ~sw ~net ~clock ~timeout "_matterc._udp"
168
+
169
+
let discover_operational ~sw ~net ~clock ?(timeout = 3.0) () =
170
+
discover_matter ~sw ~net ~clock ~timeout "_matter._tcp"
171
+
172
+
let discover_all ~sw ~net ~clock ?(timeout = 3.0) () =
173
+
let comm = discover_commissionable ~sw ~net ~clock ~timeout () in
174
+
let oper = discover_operational ~sw ~net ~clock ~timeout () in
175
+
comm @ oper
176
+
177
+
(** {1 Pretty Printing} *)
178
+
179
+
let pp_vendor ppf vp =
180
+
let vendor_name =
181
+
match vp.vendor_id with
182
+
| 4933 -> "Meross"
183
+
| 4996 -> "Apple"
184
+
| 4937 -> "Google"
185
+
| 4939 -> "Amazon"
186
+
| _ -> Printf.sprintf "Vendor(%d)" vp.vendor_id
187
+
in
188
+
Fmt.pf ppf "%s (VID=%d, PID=%d)" vendor_name vp.vendor_id vp.product_id
189
+
190
+
let pp_device ppf = function
191
+
| Commissionable d ->
192
+
Fmt.pf ppf "Commissionable: %s@." d.instance_name;
193
+
Fmt.pf ppf " Address: %s:%d@." (Option.value ~default:"?" d.ip) d.port;
194
+
Option.iter
195
+
(fun vp -> Fmt.pf ppf " Vendor: %a@." pp_vendor vp)
196
+
d.vendor_product;
197
+
Option.iter
198
+
(fun disc -> Fmt.pf ppf " Discriminator: %d@." disc)
199
+
d.discriminator;
200
+
Option.iter
201
+
(fun cm ->
202
+
let mode =
203
+
match cm with
204
+
| 0 -> "not commissioning"
205
+
| 1 -> "basic"
206
+
| 2 -> "enhanced"
207
+
| _ -> "unknown"
208
+
in
209
+
Fmt.pf ppf " Commission Mode: %s@." mode)
210
+
d.commissioning_mode
211
+
| Operational d ->
212
+
Fmt.pf ppf "Operational: %s@." d.instance_name;
213
+
Fmt.pf ppf " Address: %s:%d@." (Option.value ~default:"?" d.ip) d.port;
214
+
Fmt.pf ppf " Fabric: %s@." d.fabric_id;
215
+
Fmt.pf ppf " Node: %s@." d.node_id;
216
+
Option.iter
217
+
(fun vp -> Fmt.pf ppf " Vendor: %a@." pp_vendor vp)
218
+
d.vendor_product
219
+
220
+
let pp ppf devices =
221
+
if devices = [] then Fmt.pf ppf "No Matter devices found@."
222
+
else begin
223
+
Fmt.pf ppf "Found %d Matter device(s):@.@." (List.length devices);
224
+
List.iter (fun d -> Fmt.pf ppf "%a@." pp_device d) devices
225
+
end
+80
lib/discovery.mli
+80
lib/discovery.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter device discovery using mDNS/DNS-SD.
7
+
8
+
Discovers Matter devices on the local network using mDNS service discovery
9
+
as specified in RFC 6762/6763 and the Matter specification. *)
10
+
11
+
(** {1:types Types} *)
12
+
13
+
type vendor_product = { vendor_id : int; product_id : int }
14
+
15
+
type commissionable_device = {
16
+
instance_name : string;
17
+
hostname : string;
18
+
port : int;
19
+
ip : string option;
20
+
vendor_product : vendor_product option;
21
+
discriminator : int option;
22
+
commissioning_mode : int option;
23
+
device_type : int option;
24
+
pairing_hint : int option;
25
+
pairing_instruction : string option;
26
+
}
27
+
28
+
type operational_device = {
29
+
instance_name : string;
30
+
fabric_id : string;
31
+
node_id : string;
32
+
hostname : string;
33
+
port : int;
34
+
ip : string option;
35
+
vendor_product : vendor_product option;
36
+
compressed_fabric_id : string option;
37
+
}
38
+
39
+
type device =
40
+
| Commissionable of commissionable_device
41
+
| Operational of operational_device
42
+
43
+
(** {1:discovery Discovery functions} *)
44
+
45
+
val discover_commissionable :
46
+
sw:Eio.Switch.t ->
47
+
net:_ Eio.Net.t ->
48
+
clock:_ Eio.Time.clock ->
49
+
?timeout:float ->
50
+
unit ->
51
+
device list
52
+
(** [discover_commissionable ~sw ~net ~clock ?timeout ()] discovers
53
+
commissionable Matter devices (those in pairing mode). Default timeout is 3
54
+
seconds. *)
55
+
56
+
val discover_operational :
57
+
sw:Eio.Switch.t ->
58
+
net:_ Eio.Net.t ->
59
+
clock:_ Eio.Time.clock ->
60
+
?timeout:float ->
61
+
unit ->
62
+
device list
63
+
(** [discover_operational ~sw ~net ~clock ?timeout ()] discovers operational
64
+
Matter devices (already commissioned). *)
65
+
66
+
val discover_all :
67
+
sw:Eio.Switch.t ->
68
+
net:_ Eio.Net.t ->
69
+
clock:_ Eio.Time.clock ->
70
+
?timeout:float ->
71
+
unit ->
72
+
device list
73
+
(** [discover_all ~sw ~net ~clock ?timeout ()] discovers all Matter devices
74
+
(both commissionable and operational). *)
75
+
76
+
(** {1:pp Pretty printing} *)
77
+
78
+
val pp_vendor : vendor_product Fmt.t
79
+
val pp_device : device Fmt.t
80
+
val pp : device list Fmt.t
+16
lib/dune
+16
lib/dune
+13
lib/matter.ml
+13
lib/matter.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter protocol implementation for OCaml. *)
7
+
8
+
module Tlv = Tlv
9
+
module Msg = Msg
10
+
module Crypto = Crypto
11
+
module Pase = Pase
12
+
module Discovery = Discovery
13
+
module Session = Session
+29
lib/matter.mli
+29
lib/matter.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter protocol implementation for OCaml.
7
+
8
+
This library provides an implementation of the Matter smart home protocol as
9
+
specified in the
10
+
{{:https://csa-iot.org/developer-resource/specifications-download-request/}
11
+
Matter Core Specification}. *)
12
+
13
+
module Tlv = Tlv
14
+
(** TLV (Tag-Length-Value) encoding and decoding. *)
15
+
16
+
module Msg = Msg
17
+
(** Message framing and protocol headers. *)
18
+
19
+
module Crypto = Crypto
20
+
(** Cryptographic primitives (AES-CCM, key derivation). *)
21
+
22
+
module Pase = Pase
23
+
(** PASE (Passcode-Authenticated Session Establishment). *)
24
+
25
+
module Discovery = Discovery
26
+
(** mDNS-based device discovery. *)
27
+
28
+
module Session = Session
29
+
(** Session management and transport. *)
+92
lib/matter_crypto.ml
+92
lib/matter_crypto.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter cryptographic primitives.
7
+
8
+
This module provides:
9
+
- AES-128-CCM for message encryption
10
+
- Key derivation functions specific to Matter *)
11
+
12
+
let log_src = Logs.Src.create "matter.crypto"
13
+
14
+
module Log = (val Logs.src_log log_src : Logs.LOG)
15
+
16
+
(** {1 AES-128-CCM}
17
+
18
+
Matter uses AES-128-CCM with:
19
+
- 128-bit key
20
+
- 128-bit (16 byte) MAC tag
21
+
- 13-byte nonce for messages, 12-byte for CASE *)
22
+
23
+
module Aes_ccm = struct
24
+
module AES_CCM = Crypto.AES.CCM16
25
+
26
+
(** Encrypt with AES-128-CCM-128 (16-byte tag) *)
27
+
let encrypt ~key ~nonce ~adata plaintext =
28
+
let key = AES_CCM.of_secret key in
29
+
AES_CCM.authenticate_encrypt ~key ~nonce ~adata plaintext
30
+
31
+
(** Decrypt with AES-128-CCM-128 (16-byte tag) *)
32
+
let decrypt ~key ~nonce ~adata ciphertext =
33
+
let key = AES_CCM.of_secret key in
34
+
AES_CCM.authenticate_decrypt ~key ~nonce ~adata ciphertext
35
+
end
36
+
37
+
(** {1 Key Derivation} *)
38
+
39
+
let hkdf ~salt ~ikm ~info ~length =
40
+
let prk = Hkdf.extract ~hash:`SHA256 ~salt ikm in
41
+
Hkdf.expand ~hash:`SHA256 ~prk ~info length
42
+
43
+
let sha256 s = Digestif.SHA256.(digest_string s |> to_raw_string)
44
+
45
+
let hmac_sha256 ~key data =
46
+
Digestif.SHA256.(hmac_string ~key data |> to_raw_string)
47
+
48
+
let derive_case_session_keys ~shared_secret ~salt ~info =
49
+
let keys = hkdf ~salt ~ikm:shared_secret ~info ~length:48 in
50
+
let i2r_key = String.sub keys 0 16 in
51
+
let r2i_key = String.sub keys 16 16 in
52
+
let attestation_challenge = String.sub keys 32 16 in
53
+
(i2r_key, r2i_key, attestation_challenge)
54
+
55
+
let compute_destination_id ~ipk ~root_public_key ~fabric_id ~node_id ~random =
56
+
let data = root_public_key ^ fabric_id ^ node_id ^ random in
57
+
hmac_sha256 ~key:ipk data
58
+
59
+
(** {1 Message Encryption} *)
60
+
61
+
let build_message_nonce ~session_id ~message_counter ~source_node_id =
62
+
let buf = Buffer.create 13 in
63
+
Buffer.add_char buf '\x00';
64
+
Buffer.add_char buf (Char.chr (Int32.to_int message_counter land 0xff));
65
+
Buffer.add_char buf
66
+
(Char.chr
67
+
(Int32.to_int (Int32.shift_right_logical message_counter 8) land 0xff));
68
+
Buffer.add_char buf
69
+
(Char.chr
70
+
(Int32.to_int (Int32.shift_right_logical message_counter 16) land 0xff));
71
+
Buffer.add_char buf
72
+
(Char.chr
73
+
(Int32.to_int (Int32.shift_right_logical message_counter 24) land 0xff));
74
+
(match source_node_id with
75
+
| Some id ->
76
+
for i = 0 to 7 do
77
+
Buffer.add_char buf
78
+
(Char.chr
79
+
(Int64.to_int (Int64.shift_right_logical id (i * 8)) land 0xff))
80
+
done
81
+
| None ->
82
+
for _ = 0 to 7 do
83
+
Buffer.add_char buf '\x00'
84
+
done);
85
+
let _ = session_id in
86
+
Buffer.contents buf
87
+
88
+
let encrypt_message ~key ~nonce ~header ~plaintext =
89
+
Aes_ccm.encrypt ~key ~nonce ~adata:header plaintext
90
+
91
+
let decrypt_message ~key ~nonce ~header ~ciphertext =
92
+
Aes_ccm.decrypt ~key ~nonce ~adata:header ciphertext
+70
lib/matter_crypto.mli
+70
lib/matter_crypto.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter cryptographic primitives.
7
+
8
+
AES-128-CCM encryption and key derivation functions for Matter protocol. *)
9
+
10
+
(** {1:aes AES-128-CCM Encryption} *)
11
+
12
+
module Aes_ccm : sig
13
+
val encrypt : key:string -> nonce:string -> adata:string -> string -> string
14
+
(** [encrypt ~key ~nonce ~adata plaintext] encrypts with AES-128-CCM-128. *)
15
+
16
+
val decrypt :
17
+
key:string -> nonce:string -> adata:string -> string -> string option
18
+
(** [decrypt ~key ~nonce ~adata ciphertext] decrypts with AES-128-CCM-128.
19
+
Returns [None] if authentication fails. *)
20
+
end
21
+
22
+
(** {1:kdf Key Derivation} *)
23
+
24
+
val hkdf : salt:string -> ikm:string -> info:string -> length:int -> string
25
+
(** [hkdf ~salt ~ikm ~info ~length] derives a key using HKDF-SHA256. *)
26
+
27
+
val sha256 : string -> string
28
+
(** [sha256 data] computes SHA-256 hash. *)
29
+
30
+
val hmac_sha256 : key:string -> string -> string
31
+
(** [hmac_sha256 ~key data] computes HMAC-SHA256. *)
32
+
33
+
val derive_case_session_keys :
34
+
shared_secret:string -> salt:string -> info:string -> string * string * string
35
+
(** [derive_case_session_keys ~shared_secret ~salt ~info] derives CASE session
36
+
keys. Returns [(i2r_key, r2i_key, attestation_challenge)]. *)
37
+
38
+
val compute_destination_id :
39
+
ipk:string ->
40
+
root_public_key:string ->
41
+
fabric_id:string ->
42
+
node_id:string ->
43
+
random:string ->
44
+
string
45
+
(** [compute_destination_id ~ipk ~root_public_key ~fabric_id ~node_id ~random]
46
+
computes the destination identifier for CASE. *)
47
+
48
+
(** {1:message Message Encryption} *)
49
+
50
+
val build_message_nonce :
51
+
session_id:int ->
52
+
message_counter:int32 ->
53
+
source_node_id:int64 option ->
54
+
string
55
+
(** [build_message_nonce ~session_id ~message_counter ~source_node_id] builds
56
+
the nonce for message encryption. *)
57
+
58
+
val encrypt_message :
59
+
key:string -> nonce:string -> header:string -> plaintext:string -> string
60
+
(** [encrypt_message ~key ~nonce ~header ~plaintext] encrypts a Matter message.
61
+
*)
62
+
63
+
val decrypt_message :
64
+
key:string ->
65
+
nonce:string ->
66
+
header:string ->
67
+
ciphertext:string ->
68
+
string option
69
+
(** [decrypt_message ~key ~nonce ~header ~ciphertext] decrypts a Matter message.
70
+
Returns [None] if authentication fails. *)
+525
lib/msg.ml
+525
lib/msg.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter message framing and session handling *)
7
+
8
+
let log_src = Logs.Src.create "matter.msg"
9
+
10
+
module Log = (val Logs.src_log log_src : Logs.LOG)
11
+
12
+
let ( let* ) = Result.bind
13
+
14
+
(** {1 Message Header} *)
15
+
16
+
type message_flags = {
17
+
version : int; (* bits 0-3: protocol version, must be 0 *)
18
+
source_present : bool; (* bit 4: source node ID present *)
19
+
dsiz : int; (* bits 5-6: destination encoding *)
20
+
reserved : bool; (* bit 7 *)
21
+
}
22
+
(** Message flags (first byte of message header) *)
23
+
24
+
(** Destination encoding *)
25
+
type destination =
26
+
| No_destination (* DSIZ = 0 *)
27
+
| Node_id of int64 (* DSIZ = 1 *)
28
+
| Group_id of int (* DSIZ = 2 *)
29
+
30
+
type security_flags = {
31
+
privacy : bool; (* bit 0: privacy enhancement *)
32
+
control : bool; (* bit 1: control message *)
33
+
message_extensions : bool; (* bit 2: extensions present *)
34
+
session_type : int; (* bits 3-4: session type *)
35
+
reserved2 : int; (* bits 5-7 *)
36
+
}
37
+
(** Security flags (byte after message flags) *)
38
+
39
+
type message_header = {
40
+
flags : message_flags;
41
+
session_id : int;
42
+
security_flags : security_flags;
43
+
message_counter : int32;
44
+
source_node_id : int64 option;
45
+
destination : destination;
46
+
}
47
+
(** Unencrypted message header *)
48
+
49
+
(** {1 Protocol Header} *)
50
+
51
+
type exchange_flags = {
52
+
initiator : bool; (* bit 0: message sent by initiator *)
53
+
ack_requested : bool; (* bit 1: acknowledgement requested *)
54
+
reliability : bool; (* bit 2: reliable messaging enabled *)
55
+
secured_extensions : bool; (* bit 3: has secured extensions *)
56
+
vendor_present : bool; (* bit 4: vendor ID present *)
57
+
}
58
+
(** Exchange flags *)
59
+
60
+
type protocol_header = {
61
+
exchange_flags : exchange_flags;
62
+
protocol_opcode : int;
63
+
exchange_id : int;
64
+
protocol_id : int;
65
+
vendor_id : int option;
66
+
ack_counter : int32 option;
67
+
}
68
+
(** Protocol header (in payload, after decryption) *)
69
+
70
+
(** Protocol IDs *)
71
+
module Protocol = struct
72
+
let secure_channel = 0x0000
73
+
let interaction_model = 0x0001
74
+
let bdx = 0x0002 (* Bulk Data Exchange *)
75
+
let user_directed_commissioning = 0x0003
76
+
end
77
+
78
+
(** Secure Channel opcodes *)
79
+
module Secure_channel = struct
80
+
let msg_counter_sync_req = 0x00
81
+
let msg_counter_sync_rsp = 0x01
82
+
let mrp_standalone_ack = 0x10
83
+
let pbkdf_param_request = 0x20
84
+
let pbkdf_param_response = 0x21
85
+
let pase_pake1 = 0x22
86
+
let pase_pake2 = 0x23
87
+
let pase_pake3 = 0x24
88
+
let case_sigma1 = 0x30
89
+
let case_sigma2 = 0x31
90
+
let case_sigma3 = 0x32
91
+
let case_sigma2_resume = 0x33
92
+
let status_report = 0x40
93
+
end
94
+
95
+
(** Interaction Model opcodes *)
96
+
module Interaction = struct
97
+
let status_response = 0x01
98
+
let read_request = 0x02
99
+
let subscribe_request = 0x03
100
+
let subscribe_response = 0x04
101
+
let report_data = 0x05
102
+
let write_request = 0x06
103
+
let write_response = 0x07
104
+
let invoke_request = 0x08
105
+
let invoke_response = 0x09
106
+
let timed_request = 0x0a
107
+
end
108
+
109
+
(** {1 Encoding} *)
110
+
111
+
let put_byte buf b = Buffer.add_char buf (Char.chr (b land 0xff))
112
+
113
+
let put_uint16_le buf v =
114
+
put_byte buf v;
115
+
put_byte buf (v lsr 8)
116
+
117
+
let put_uint32_le buf v =
118
+
put_byte buf (Int32.to_int v);
119
+
put_byte buf (Int32.to_int (Int32.shift_right_logical v 8));
120
+
put_byte buf (Int32.to_int (Int32.shift_right_logical v 16));
121
+
put_byte buf (Int32.to_int (Int32.shift_right_logical v 24))
122
+
123
+
let put_uint64_le buf v =
124
+
for i = 0 to 7 do
125
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v (i * 8)))
126
+
done
127
+
128
+
let encode_message_header buf hdr =
129
+
(* Message flags byte *)
130
+
let flags_byte =
131
+
hdr.flags.version land 0x0f
132
+
lor (if hdr.flags.source_present then 0x10 else 0)
133
+
lor ((hdr.flags.dsiz land 0x03) lsl 5)
134
+
lor if hdr.flags.reserved then 0x80 else 0
135
+
in
136
+
put_byte buf flags_byte;
137
+
138
+
(* Session ID (16 bits) *)
139
+
put_uint16_le buf hdr.session_id;
140
+
141
+
(* Security flags byte *)
142
+
let sec_flags_byte =
143
+
(if hdr.security_flags.privacy then 0x01 else 0)
144
+
lor (if hdr.security_flags.control then 0x02 else 0)
145
+
lor (if hdr.security_flags.message_extensions then 0x04 else 0)
146
+
lor ((hdr.security_flags.session_type land 0x03) lsl 3)
147
+
lor ((hdr.security_flags.reserved2 land 0x07) lsl 5)
148
+
in
149
+
put_byte buf sec_flags_byte;
150
+
151
+
(* Message counter (32 bits) *)
152
+
put_uint32_le buf hdr.message_counter;
153
+
154
+
(* Source node ID if present *)
155
+
(match hdr.source_node_id with
156
+
| Some id when hdr.flags.source_present -> put_uint64_le buf id
157
+
| _ -> ());
158
+
159
+
(* Destination if present *)
160
+
match hdr.destination with
161
+
| No_destination -> ()
162
+
| Node_id id -> put_uint64_le buf id
163
+
| Group_id id -> put_uint16_le buf id
164
+
165
+
let encode_protocol_header buf phdr =
166
+
(* Exchange flags *)
167
+
let flags_byte =
168
+
(if phdr.exchange_flags.initiator then 0x01 else 0)
169
+
lor (if phdr.exchange_flags.ack_requested then 0x02 else 0)
170
+
lor (if phdr.exchange_flags.reliability then 0x04 else 0)
171
+
lor (if phdr.exchange_flags.secured_extensions then 0x08 else 0)
172
+
lor (if phdr.exchange_flags.vendor_present then 0x10 else 0)
173
+
lor match phdr.ack_counter with Some _ -> 0x20 | None -> 0
174
+
in
175
+
put_byte buf flags_byte;
176
+
177
+
(* Protocol opcode *)
178
+
put_byte buf phdr.protocol_opcode;
179
+
180
+
(* Exchange ID (16 bits) *)
181
+
put_uint16_le buf phdr.exchange_id;
182
+
183
+
(* Protocol ID (16 bits) *)
184
+
put_uint16_le buf phdr.protocol_id;
185
+
186
+
(* Vendor ID if present *)
187
+
(match phdr.vendor_id with
188
+
| Some v -> put_uint16_le buf v
189
+
| None -> ());
190
+
191
+
(* Ack counter if present *)
192
+
match phdr.ack_counter with
193
+
| Some c -> put_uint32_le buf c
194
+
| None -> ()
195
+
196
+
(** {1 Decoding} *)
197
+
198
+
let get_byte data offset =
199
+
if offset >= String.length data then Error "Unexpected end of data"
200
+
else Ok (Char.code data.[offset], offset + 1)
201
+
202
+
let get_uint16_le data offset =
203
+
if offset + 2 > String.length data then Error "Unexpected end of data"
204
+
else
205
+
let b0 = Char.code data.[offset] in
206
+
let b1 = Char.code data.[offset + 1] in
207
+
Ok (b0 lor (b1 lsl 8), offset + 2)
208
+
209
+
let get_uint32_le data offset =
210
+
if offset + 4 > String.length data then Error "Unexpected end of data"
211
+
else
212
+
let b0 = Int32.of_int (Char.code data.[offset]) in
213
+
let b1 = Int32.of_int (Char.code data.[offset + 1]) in
214
+
let b2 = Int32.of_int (Char.code data.[offset + 2]) in
215
+
let b3 = Int32.of_int (Char.code data.[offset + 3]) in
216
+
Ok
217
+
( Int32.(
218
+
add
219
+
(add b0 (shift_left b1 8))
220
+
(add (shift_left b2 16) (shift_left b3 24))),
221
+
offset + 4 )
222
+
223
+
let get_uint64_le data offset =
224
+
if offset + 8 > String.length data then Error "Unexpected end of data"
225
+
else
226
+
let v = ref 0L in
227
+
for i = 7 downto 0 do
228
+
v :=
229
+
Int64.add (Int64.shift_left !v 8)
230
+
(Int64.of_int (Char.code data.[offset + i]))
231
+
done;
232
+
Ok (!v, offset + 8)
233
+
234
+
let decode_message_header data =
235
+
let* flags_byte, offset = get_byte data 0 in
236
+
let flags =
237
+
{
238
+
version = flags_byte land 0x0f;
239
+
source_present = flags_byte land 0x10 <> 0;
240
+
dsiz = (flags_byte lsr 5) land 0x03;
241
+
reserved = flags_byte land 0x80 <> 0;
242
+
}
243
+
in
244
+
245
+
let* session_id, offset = get_uint16_le data offset in
246
+
247
+
let* sec_flags_byte, offset = get_byte data offset in
248
+
let security_flags =
249
+
{
250
+
privacy = sec_flags_byte land 0x01 <> 0;
251
+
control = sec_flags_byte land 0x02 <> 0;
252
+
message_extensions = sec_flags_byte land 0x04 <> 0;
253
+
session_type = (sec_flags_byte lsr 3) land 0x03;
254
+
reserved2 = (sec_flags_byte lsr 5) land 0x07;
255
+
}
256
+
in
257
+
258
+
let* message_counter, offset = get_uint32_le data offset in
259
+
260
+
let* source_node_id, offset =
261
+
if flags.source_present then
262
+
let* id, off = get_uint64_le data offset in
263
+
Ok (Some id, off)
264
+
else Ok (None, offset)
265
+
in
266
+
267
+
let* destination, offset =
268
+
match flags.dsiz with
269
+
| 0 -> Ok (No_destination, offset)
270
+
| 1 ->
271
+
let* id, off = get_uint64_le data offset in
272
+
Ok (Node_id id, off)
273
+
| 2 ->
274
+
let* id, off = get_uint16_le data offset in
275
+
Ok (Group_id id, off)
276
+
| _ -> Error "Invalid DSIZ value"
277
+
in
278
+
279
+
Ok
280
+
( {
281
+
flags;
282
+
session_id;
283
+
security_flags;
284
+
message_counter;
285
+
source_node_id;
286
+
destination;
287
+
},
288
+
offset )
289
+
290
+
let decode_protocol_header data offset =
291
+
let* flags_byte, offset = get_byte data offset in
292
+
let exchange_flags =
293
+
{
294
+
initiator = flags_byte land 0x01 <> 0;
295
+
ack_requested = flags_byte land 0x02 <> 0;
296
+
reliability = flags_byte land 0x04 <> 0;
297
+
secured_extensions = flags_byte land 0x08 <> 0;
298
+
vendor_present = flags_byte land 0x10 <> 0;
299
+
}
300
+
in
301
+
let has_ack = flags_byte land 0x20 <> 0 in
302
+
303
+
let* protocol_opcode, offset = get_byte data offset in
304
+
let* exchange_id, offset = get_uint16_le data offset in
305
+
let* protocol_id, offset = get_uint16_le data offset in
306
+
307
+
let* vendor_id, offset =
308
+
if exchange_flags.vendor_present then
309
+
let* v, off = get_uint16_le data offset in
310
+
Ok (Some v, off)
311
+
else Ok (None, offset)
312
+
in
313
+
314
+
let* ack_counter, offset =
315
+
if has_ack then
316
+
let* c, off = get_uint32_le data offset in
317
+
Ok (Some c, off)
318
+
else Ok (None, offset)
319
+
in
320
+
321
+
Ok
322
+
( {
323
+
exchange_flags;
324
+
protocol_opcode;
325
+
exchange_id;
326
+
protocol_id;
327
+
vendor_id;
328
+
ack_counter;
329
+
},
330
+
offset )
331
+
332
+
(** {1 Message Construction Helpers} *)
333
+
334
+
let default_message_flags =
335
+
{ version = 0; source_present = false; dsiz = 0; reserved = false }
336
+
337
+
let default_security_flags =
338
+
{
339
+
privacy = false;
340
+
control = false;
341
+
message_extensions = false;
342
+
session_type = 0;
343
+
reserved2 = 0;
344
+
}
345
+
346
+
let make_unsecured_header ~message_counter =
347
+
{
348
+
flags = default_message_flags;
349
+
session_id = 0;
350
+
(* Unsecured session *)
351
+
security_flags = default_security_flags;
352
+
message_counter;
353
+
source_node_id = None;
354
+
destination = No_destination;
355
+
}
356
+
357
+
let make_exchange_flags ?(initiator = true) ?(ack_requested = true)
358
+
?(reliability = true) () =
359
+
{
360
+
initiator;
361
+
ack_requested;
362
+
reliability;
363
+
secured_extensions = false;
364
+
vendor_present = false;
365
+
}
366
+
367
+
let make_protocol_header ~exchange_id ~protocol_id ~opcode
368
+
?(exchange_flags = make_exchange_flags ()) () =
369
+
{
370
+
exchange_flags;
371
+
protocol_opcode = opcode;
372
+
exchange_id;
373
+
protocol_id;
374
+
vendor_id = None;
375
+
ack_counter = None;
376
+
}
377
+
378
+
(** Encode a complete unsecured message *)
379
+
let encode_unsecured_message ~message_counter ~exchange_id ~protocol_id ~opcode
380
+
~payload =
381
+
let msg_hdr = make_unsecured_header ~message_counter in
382
+
let proto_hdr = make_protocol_header ~exchange_id ~protocol_id ~opcode () in
383
+
let buf = Buffer.create 256 in
384
+
encode_message_header buf msg_hdr;
385
+
encode_protocol_header buf proto_hdr;
386
+
Buffer.add_string buf payload;
387
+
Buffer.contents buf
388
+
389
+
(** {1 PASE Messages} *)
390
+
391
+
(** Build PBKDFParamRequest message for PASE *)
392
+
let make_pbkdf_param_request ~initiator_random ~initiator_session_id
393
+
~passcode_id ~has_pbkdf_params =
394
+
let open Tlv in
395
+
encode_one
396
+
(structure
397
+
[
398
+
ctx_bytes 1 initiator_random;
399
+
(* 32 bytes random *)
400
+
ctx_uint 2 initiator_session_id;
401
+
ctx_uint 3 passcode_id;
402
+
ctx_bool 4 has_pbkdf_params;
403
+
])
404
+
405
+
(** Build PAKE1 message *)
406
+
let make_pase_pake1 ~pa =
407
+
let open Tlv in
408
+
encode_one (structure [ ctx_bytes 1 pa (* pA = X coordinate of PAKE key *) ])
409
+
410
+
(** Build PAKE3 message *)
411
+
let make_pase_pake3 ~ca =
412
+
let open Tlv in
413
+
encode_one (structure [ ctx_bytes 1 ca (* cA = HMAC proof *) ])
414
+
415
+
(** {1 Interaction Model Messages} *)
416
+
417
+
(** Build InvokeRequest for a cluster command *)
418
+
let make_invoke_request ~endpoint_id ~cluster_id ~command_id ~command_data =
419
+
let open Tlv in
420
+
let invoke_request =
421
+
structure
422
+
[
423
+
ctx_bool 0 false;
424
+
(* SuppressResponse *)
425
+
ctx_bool 1 false;
426
+
(* TimedRequest *)
427
+
ctx_array 2
428
+
[
429
+
(* InvokeRequests *)
430
+
structure
431
+
[
432
+
ctx_struct 0
433
+
[
434
+
(* CommandPath *)
435
+
ctx_uint 0 endpoint_id;
436
+
ctx_uint 1 cluster_id;
437
+
ctx_uint 2 command_id;
438
+
];
439
+
ctx_struct 1 command_data;
440
+
(* CommandFields *)
441
+
];
442
+
];
443
+
]
444
+
in
445
+
encode_one invoke_request
446
+
447
+
(** On/Off cluster commands *)
448
+
module OnOff = struct
449
+
let cluster_id = 0x0006
450
+
let off_command = 0x00
451
+
let on_command = 0x01
452
+
let toggle_command = 0x02
453
+
454
+
let make_off ~endpoint_id =
455
+
make_invoke_request ~endpoint_id ~cluster_id ~command_id:off_command
456
+
~command_data:[]
457
+
458
+
let make_on ~endpoint_id =
459
+
make_invoke_request ~endpoint_id ~cluster_id ~command_id:on_command
460
+
~command_data:[]
461
+
462
+
let make_toggle ~endpoint_id =
463
+
make_invoke_request ~endpoint_id ~cluster_id ~command_id:toggle_command
464
+
~command_data:[]
465
+
end
466
+
467
+
(** AdministratorCommissioning cluster - for opening commissioning windows *)
468
+
module AdministratorCommissioning = struct
469
+
let cluster_id = 0x003C
470
+
let endpoint_id = 0 (* Root endpoint *)
471
+
472
+
(* Commands *)
473
+
let open_commissioning_window =
474
+
0x00 (* Enhanced, requires PAKEPasscodeVerifier *)
475
+
476
+
let open_basic_commissioning_window =
477
+
0x01 (* Uses device's default passcode *)
478
+
479
+
let revoke_commissioning = 0x02
480
+
481
+
(** Open a basic commissioning window using the device's default passcode.
482
+
timeout is in seconds (valid range: 180-900) *)
483
+
let make_open_basic ~timeout =
484
+
let open Tlv in
485
+
make_invoke_request ~endpoint_id ~cluster_id
486
+
~command_id:open_basic_commissioning_window
487
+
~command_data:[ ctx_uint 0 timeout (* CommissioningTimeout *) ]
488
+
489
+
(** Open an enhanced commissioning window with custom verifier. This is used
490
+
when you want to specify your own passcode. *)
491
+
let make_open_enhanced ~timeout ~verifier ~discriminator ~iterations ~salt =
492
+
let open Tlv in
493
+
make_invoke_request ~endpoint_id ~cluster_id
494
+
~command_id:open_commissioning_window
495
+
~command_data:
496
+
[
497
+
ctx_uint 0 timeout;
498
+
ctx_bytes 1 verifier;
499
+
(* PAKEPasscodeVerifier *)
500
+
ctx_uint 2 discriminator;
501
+
ctx_uint 3 iterations;
502
+
ctx_bytes 4 salt;
503
+
]
504
+
505
+
let make_revoke () =
506
+
make_invoke_request ~endpoint_id ~cluster_id
507
+
~command_id:revoke_commissioning ~command_data:[]
508
+
end
509
+
510
+
(** {1 Pretty Printing} *)
511
+
512
+
let pp_message_header ppf hdr =
513
+
Fmt.pf ppf "Message{session=%d, counter=%ld, src=%s, dst=%s}" hdr.session_id
514
+
hdr.message_counter
515
+
(match hdr.source_node_id with
516
+
| Some id -> Printf.sprintf "%016Lx" id
517
+
| None -> "-")
518
+
(match hdr.destination with
519
+
| No_destination -> "-"
520
+
| Node_id id -> Printf.sprintf "node:%016Lx" id
521
+
| Group_id id -> Printf.sprintf "group:%d" id)
522
+
523
+
let pp_protocol_header ppf phdr =
524
+
Fmt.pf ppf "Protocol{proto=%04x, opcode=%02x, exchange=%d}" phdr.protocol_id
525
+
phdr.protocol_opcode phdr.exchange_id
+168
lib/msg.mli
+168
lib/msg.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter message framing.
7
+
8
+
Message header encoding/decoding and protocol message construction for
9
+
Matter secure channel and interaction model. *)
10
+
11
+
(** {1:header Message header types} *)
12
+
13
+
type message_flags = {
14
+
version : int;
15
+
source_present : bool;
16
+
dsiz : int;
17
+
reserved : bool;
18
+
}
19
+
20
+
type destination = No_destination | Node_id of int64 | Group_id of int
21
+
22
+
type security_flags = {
23
+
privacy : bool;
24
+
control : bool;
25
+
message_extensions : bool;
26
+
session_type : int;
27
+
reserved2 : int;
28
+
}
29
+
30
+
type message_header = {
31
+
flags : message_flags;
32
+
session_id : int;
33
+
security_flags : security_flags;
34
+
message_counter : int32;
35
+
source_node_id : int64 option;
36
+
destination : destination;
37
+
}
38
+
39
+
(** {1:protocol Protocol header types} *)
40
+
41
+
type exchange_flags = {
42
+
initiator : bool;
43
+
ack_requested : bool;
44
+
reliability : bool;
45
+
secured_extensions : bool;
46
+
vendor_present : bool;
47
+
}
48
+
49
+
type protocol_header = {
50
+
exchange_flags : exchange_flags;
51
+
protocol_opcode : int;
52
+
exchange_id : int;
53
+
protocol_id : int;
54
+
vendor_id : int option;
55
+
ack_counter : int32 option;
56
+
}
57
+
58
+
(** {1:protocol_ids Protocol IDs} *)
59
+
60
+
module Protocol : sig
61
+
val secure_channel : int
62
+
val interaction_model : int
63
+
val bdx : int
64
+
val user_directed_commissioning : int
65
+
end
66
+
67
+
(** {1:secure_channel Secure Channel opcodes} *)
68
+
69
+
module Secure_channel : sig
70
+
val msg_counter_sync_req : int
71
+
val msg_counter_sync_rsp : int
72
+
val mrp_standalone_ack : int
73
+
val pbkdf_param_request : int
74
+
val pbkdf_param_response : int
75
+
val pase_pake1 : int
76
+
val pase_pake2 : int
77
+
val pase_pake3 : int
78
+
val case_sigma1 : int
79
+
val case_sigma2 : int
80
+
val case_sigma3 : int
81
+
val case_sigma2_resume : int
82
+
val status_report : int
83
+
end
84
+
85
+
(** {1:interaction Interaction Model opcodes} *)
86
+
87
+
module Interaction : sig
88
+
val status_response : int
89
+
val read_request : int
90
+
val subscribe_request : int
91
+
val subscribe_response : int
92
+
val report_data : int
93
+
val write_request : int
94
+
val write_response : int
95
+
val invoke_request : int
96
+
val invoke_response : int
97
+
val timed_request : int
98
+
end
99
+
100
+
(** {1:encoding Encoding and Decoding} *)
101
+
102
+
val encode_message_header : Buffer.t -> message_header -> unit
103
+
val encode_protocol_header : Buffer.t -> protocol_header -> unit
104
+
val decode_message_header : string -> (message_header * int, string) result
105
+
106
+
val decode_protocol_header :
107
+
string -> int -> (protocol_header * int, string) result
108
+
109
+
val encode_unsecured_message :
110
+
message_counter:int32 ->
111
+
exchange_id:int ->
112
+
protocol_id:int ->
113
+
opcode:int ->
114
+
payload:string ->
115
+
string
116
+
117
+
(** {1:pase PASE message builders} *)
118
+
119
+
val make_pbkdf_param_request :
120
+
initiator_random:string ->
121
+
initiator_session_id:int ->
122
+
passcode_id:int ->
123
+
has_pbkdf_params:bool ->
124
+
string
125
+
126
+
val make_pase_pake1 : pa:string -> string
127
+
val make_pase_pake3 : ca:string -> string
128
+
129
+
(** {1:im Interaction Model builders} *)
130
+
131
+
val make_invoke_request :
132
+
endpoint_id:int ->
133
+
cluster_id:int ->
134
+
command_id:int ->
135
+
command_data:Tlv.element list ->
136
+
string
137
+
138
+
(** {1:clusters Cluster helpers} *)
139
+
140
+
module OnOff : sig
141
+
val cluster_id : int
142
+
val off_command : int
143
+
val on_command : int
144
+
val toggle_command : int
145
+
val make_on : endpoint_id:int -> string
146
+
val make_off : endpoint_id:int -> string
147
+
val make_toggle : endpoint_id:int -> string
148
+
end
149
+
150
+
module AdministratorCommissioning : sig
151
+
val cluster_id : int
152
+
val make_open_basic : timeout:int -> string
153
+
154
+
val make_open_enhanced :
155
+
timeout:int ->
156
+
verifier:string ->
157
+
discriminator:int ->
158
+
iterations:int ->
159
+
salt:string ->
160
+
string
161
+
162
+
val make_revoke : unit -> string
163
+
end
164
+
165
+
(** {1:pp Pretty printing} *)
166
+
167
+
val pp_message_header : message_header Fmt.t
168
+
val pp_protocol_header : protocol_header Fmt.t
+118
lib/pase.ml
+118
lib/pase.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter PASE (Passcode-Authenticated Session Establishment) helpers.
7
+
8
+
This module provides Matter-specific PASE helpers that build on the generic
9
+
SPAKE2+ implementation from the spake2 library. *)
10
+
11
+
let log_src = Logs.Src.create "matter.pase"
12
+
13
+
module Log = (val Logs.src_log log_src : Logs.LOG)
14
+
15
+
let ( let* ) = Result.bind
16
+
17
+
(** {1 PASE Context} *)
18
+
19
+
(** Build PASE context from session parameters *)
20
+
let make_context ~initiator_random ~responder_random ~pbkdf_params_responder =
21
+
(* Context includes the session establishment exchange information *)
22
+
initiator_random ^ responder_random ^ pbkdf_params_responder
23
+
24
+
(** {1 Prover (Commissioner) Operations} *)
25
+
26
+
(** Initialize PASE as prover (commissioner side). Returns (state, pA) where pA
27
+
is sent to device. *)
28
+
let prover_init ~passcode ~salt ~iterations ~context =
29
+
let w0, w1 =
30
+
Spake2.Plus.derive_w ~password:(string_of_int passcode) ~salt ~iterations
31
+
in
32
+
Spake2.Plus.prover_init ~w0 ~w1 ~context
33
+
34
+
(** Complete PASE as prover. Returns (shared_key, confirmation_a,
35
+
expected_confirmation_b). *)
36
+
let prover_finish = Spake2.Plus.prover_finish
37
+
38
+
(** {1 Verifier (Device) Operations} *)
39
+
40
+
(** Initialize PASE as verifier (device side). The device stores w0 and L (not
41
+
the passcode). *)
42
+
let verifier_init = Spake2.Plus.verifier_init
43
+
44
+
(** Complete PASE as verifier. *)
45
+
let verifier_finish = Spake2.Plus.verifier_finish
46
+
47
+
(** {1 Device Setup} *)
48
+
49
+
(** Compute L = w1*G for device storage. Call this during device setup to
50
+
generate the verification data that the device stores (along with w0). *)
51
+
let compute_l = Spake2.Plus.compute_l
52
+
53
+
(** Derive w0 and w1 from passcode for device setup. *)
54
+
let derive_w ~passcode ~salt ~iterations =
55
+
Spake2.Plus.derive_w ~password:(string_of_int passcode) ~salt ~iterations
56
+
57
+
(** Generate random salt for PBKDF2. *)
58
+
let generate_salt = Spake2.Plus.generate_salt
59
+
60
+
(** Default PBKDF2 iterations. *)
61
+
let default_iterations = Spake2.Plus.default_iterations
62
+
63
+
(** {1 TLV Message Parsing} *)
64
+
65
+
(** Parse PBKDFParamResponse TLV *)
66
+
let parse_pbkdf_response tlv_data =
67
+
let* elems = Tlv.decode tlv_data in
68
+
(* Extract fields from structure:
69
+
1: responderRandom (bytes)
70
+
2: responderSessionId (uint)
71
+
3: pbkdf_parameters (structure with iterations, salt) *)
72
+
let find_ctx tag =
73
+
List.find_opt
74
+
(fun e ->
75
+
match e.Tlv.tag with Tlv.Context_specific t -> t = tag | _ -> false)
76
+
elems
77
+
in
78
+
match (find_ctx 1, find_ctx 2, find_ctx 3) with
79
+
| ( Some { value = Bytes random; _ },
80
+
Some { value = Uint session_id; _ },
81
+
Some { value = Structure params; _ } ) -> (
82
+
let find_param tag =
83
+
List.find_opt
84
+
(fun e ->
85
+
match e.Tlv.tag with
86
+
| Tlv.Context_specific t -> t = tag
87
+
| _ -> false)
88
+
params
89
+
in
90
+
match (find_param 1, find_param 2) with
91
+
| Some { value = Uint iterations; _ }, Some { value = Bytes salt; _ } ->
92
+
Ok (random, Int64.to_int session_id, Int64.to_int iterations, salt)
93
+
| _ -> Error "Missing PBKDF parameters")
94
+
| _ -> Error "Invalid PBKDFParamResponse structure"
95
+
96
+
(** Parse PAKE2 TLV (verifier's pB and cB) *)
97
+
let parse_pake2 tlv_data =
98
+
let* elems = Tlv.decode tlv_data in
99
+
let find_ctx tag =
100
+
List.find_opt
101
+
(fun e ->
102
+
match e.Tlv.tag with Tlv.Context_specific t -> t = tag | _ -> false)
103
+
elems
104
+
in
105
+
match (find_ctx 1, find_ctx 2) with
106
+
| Some { value = Bytes pb; _ }, Some { value = Bytes cb; _ } -> Ok (pb, cb)
107
+
| _ -> Error "Invalid PAKE2 structure"
108
+
109
+
(** {1 Cryptographic Helpers}
110
+
111
+
These are re-exports from {!Crypto} for convenience. *)
112
+
113
+
let sha256 = Matter_crypto.sha256
114
+
let hmac_sha256 = Matter_crypto.hmac_sha256
115
+
116
+
let hkdf ~salt ~ikm ~info ~length =
117
+
let prk = Hkdf.extract ~hash:`SHA256 ~salt ikm in
118
+
Hkdf.expand ~hash:`SHA256 ~prk ~info length
+96
lib/pase.mli
+96
lib/pase.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter PASE (Passcode-Authenticated Session Establishment).
7
+
8
+
PASE is used to establish secure sessions between a commissioner and a
9
+
Matter device using a shared passcode. It uses SPAKE2+ as the underlying
10
+
password-authenticated key exchange protocol. *)
11
+
12
+
(** {1:context Context} *)
13
+
14
+
val make_context :
15
+
initiator_random:string ->
16
+
responder_random:string ->
17
+
pbkdf_params_responder:string ->
18
+
string
19
+
(** [make_context ~initiator_random ~responder_random ~pbkdf_params_responder]
20
+
builds the PASE context for SPAKE2+ transcript. *)
21
+
22
+
(** {1:prover Prover (Commissioner) Operations} *)
23
+
24
+
val prover_init :
25
+
passcode:int ->
26
+
salt:string ->
27
+
iterations:int ->
28
+
context:string ->
29
+
Spake2.Plus.prover_state * string
30
+
(** [prover_init ~passcode ~salt ~iterations ~context] initiates PASE as the
31
+
prover (commissioner).
32
+
33
+
@param passcode The device passcode (typically 8 digits like 20202021)
34
+
@param salt The salt from PBKDF params response
35
+
@param iterations The iteration count from PBKDF params response
36
+
@param context The PASE context from {!make_context}
37
+
@return [(state, pA)] where pA is sent to the device *)
38
+
39
+
val prover_finish :
40
+
Spake2.Plus.prover_state ->
41
+
string ->
42
+
(string * string * string, string) result
43
+
(** [prover_finish state pB] processes the device's pB message.
44
+
45
+
@return [Ok (shared_key, confirmation_a, expected_confirmation_b)] or error
46
+
*)
47
+
48
+
(** {1:verifier Verifier (Device) Operations} *)
49
+
50
+
val verifier_init :
51
+
w0:string -> l:string -> context:string -> Spake2.Plus.verifier_state * string
52
+
(** [verifier_init ~w0 ~l ~context] initiates PASE as the verifier (device).
53
+
54
+
@param w0 The stored w0 value
55
+
@param l The stored L = w1*G value
56
+
@return [(state, pB)] where pB is sent to the commissioner *)
57
+
58
+
val verifier_finish :
59
+
Spake2.Plus.verifier_state ->
60
+
string ->
61
+
(string * string * string, string) result
62
+
(** [verifier_finish state pA] processes the commissioner's pA message.
63
+
64
+
@return [Ok (shared_key, confirmation_b, expected_confirmation_a)] or error
65
+
*)
66
+
67
+
(** {1:setup Device Setup} *)
68
+
69
+
val derive_w : passcode:int -> salt:string -> iterations:int -> string * string
70
+
(** [derive_w ~passcode ~salt ~iterations] derives w0 and w1 from passcode. Used
71
+
during device provisioning. *)
72
+
73
+
val compute_l : w1:string -> string
74
+
(** [compute_l ~w1] computes L = w1*G for device storage. *)
75
+
76
+
val generate_salt : unit -> string
77
+
(** [generate_salt ()] generates a random 32-byte salt. *)
78
+
79
+
val default_iterations : int
80
+
(** Default PBKDF2 iteration count (1000). *)
81
+
82
+
(** {1:parsing TLV Message Parsing} *)
83
+
84
+
val parse_pbkdf_response :
85
+
string -> (string * int * int * string, string) result
86
+
(** [parse_pbkdf_response data] parses a PBKDFParamResponse TLV message. Returns
87
+
[(responder_random, session_id, iterations, salt)]. *)
88
+
89
+
val parse_pake2 : string -> (string * string, string) result
90
+
(** [parse_pake2 data] parses a PAKE2 TLV message. Returns [(pB, cB)]. *)
91
+
92
+
(** {1:crypto Cryptographic Helpers} *)
93
+
94
+
val sha256 : string -> string
95
+
val hmac_sha256 : key:string -> string -> string
96
+
val hkdf : salt:string -> ikm:string -> info:string -> length:int -> string
+313
lib/session.ml
+313
lib/session.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter session management and transport *)
7
+
8
+
let log_src = Logs.Src.create "matter.session"
9
+
10
+
module Log = (val Logs.src_log log_src : Logs.LOG)
11
+
12
+
let ( let* ) = Result.bind
13
+
14
+
(** {1 Types} *)
15
+
16
+
type session_state =
17
+
| Unauthenticated
18
+
| Pase_pending
19
+
| Case_pending
20
+
| Authenticated
21
+
22
+
type session = {
23
+
mutable state : session_state;
24
+
mutable session_id : int;
25
+
mutable peer_session_id : int;
26
+
mutable message_counter : int32;
27
+
mutable peer_node_id : int64 option;
28
+
mutable i2r_key : string option;
29
+
mutable r2i_key : string option;
30
+
mutable attestation_challenge : string option;
31
+
ip : string;
32
+
port : int;
33
+
}
34
+
35
+
type 'a connection = {
36
+
session : session;
37
+
sock : 'a Eio.Net.datagram_socket;
38
+
remote_addr : Eio.Net.Sockaddr.datagram;
39
+
}
40
+
41
+
(** {1 Session Management} *)
42
+
43
+
let create_session ~ip ~port =
44
+
{
45
+
state = Unauthenticated;
46
+
session_id = 0;
47
+
peer_session_id = 0;
48
+
message_counter = 0l;
49
+
peer_node_id = None;
50
+
i2r_key = None;
51
+
r2i_key = None;
52
+
attestation_challenge = None;
53
+
ip;
54
+
port;
55
+
}
56
+
57
+
let next_message_counter session =
58
+
let counter = session.message_counter in
59
+
session.message_counter <- Int32.add session.message_counter 1l;
60
+
counter
61
+
62
+
let next_exchange_id =
63
+
let counter = ref 0 in
64
+
fun () ->
65
+
let id = !counter in
66
+
counter := (!counter + 1) land 0xffff;
67
+
id
68
+
69
+
(** {1 UDP Transport} *)
70
+
71
+
let connect ~net ~sw ~ip ~port =
72
+
let sock = Eio.Net.datagram_socket ~sw net `UdpV4 in
73
+
let eio_ip =
74
+
Eio.Net.Ipaddr.of_raw (Ipaddr.V4.to_octets (Ipaddr.V4.of_string_exn ip))
75
+
in
76
+
let remote_addr = `Udp (eio_ip, port) in
77
+
let session = create_session ~ip ~port in
78
+
{ session; sock; remote_addr }
79
+
80
+
let send_message conn data =
81
+
Log.debug (fun m ->
82
+
m "Sending %d bytes to %s:%d" (String.length data) conn.session.ip
83
+
conn.session.port);
84
+
Eio.Net.send conn.sock ~dst:conn.remote_addr [ Cstruct.of_string data ]
85
+
86
+
let receive_message ~clock conn ~timeout =
87
+
let buf = Cstruct.create 4096 in
88
+
match
89
+
Eio.Time.with_timeout clock timeout (fun () ->
90
+
let _src, len = Eio.Net.recv conn.sock buf in
91
+
Ok (Cstruct.to_string (Cstruct.sub buf 0 len)))
92
+
with
93
+
| Ok data ->
94
+
Log.debug (fun m ->
95
+
m "Received %d bytes from %s:%d" (String.length data) conn.session.ip
96
+
conn.session.port);
97
+
Ok data
98
+
| Error `Timeout ->
99
+
Log.debug (fun m ->
100
+
m "Receive timeout from %s:%d" conn.session.ip conn.session.port);
101
+
Error `Timeout
102
+
103
+
(** {1 Message Construction} *)
104
+
105
+
let build_unsecured_message ~session ~exchange_id ~protocol_id ~opcode ~payload
106
+
=
107
+
let counter = next_message_counter session in
108
+
Msg.encode_unsecured_message ~message_counter:counter ~exchange_id
109
+
~protocol_id ~opcode ~payload
110
+
111
+
(** {1 PASE Flow} *)
112
+
113
+
let pase_pbkdf_exchange ~clock conn ~initiator_random ~session_id =
114
+
let exchange_id = next_exchange_id () in
115
+
116
+
let payload =
117
+
Msg.make_pbkdf_param_request ~initiator_random
118
+
~initiator_session_id:session_id ~passcode_id:0 ~has_pbkdf_params:false
119
+
in
120
+
121
+
let msg =
122
+
build_unsecured_message ~session:conn.session ~exchange_id
123
+
~protocol_id:Msg.Protocol.secure_channel
124
+
~opcode:Msg.Secure_channel.pbkdf_param_request ~payload
125
+
in
126
+
127
+
send_message conn msg;
128
+
match receive_message ~clock conn ~timeout:5.0 with
129
+
| Error `Timeout -> Error (`Msg "Timeout waiting for PBKDFParamResponse")
130
+
| Ok response -> (
131
+
match Msg.decode_message_header response with
132
+
| Error e -> Error (`Msg e)
133
+
| Ok (_msg_hdr, payload_offset) -> (
134
+
match Msg.decode_protocol_header response payload_offset with
135
+
| Error e -> Error (`Msg e)
136
+
| Ok (proto_hdr, data_offset) -> (
137
+
if proto_hdr.protocol_id <> Msg.Protocol.secure_channel then
138
+
Error (`Msg "Unexpected protocol in response")
139
+
else if
140
+
proto_hdr.protocol_opcode
141
+
<> Msg.Secure_channel.pbkdf_param_response
142
+
then Error (`Msg "Unexpected opcode in response")
143
+
else
144
+
let payload =
145
+
String.sub response data_offset
146
+
(String.length response - data_offset)
147
+
in
148
+
match Pase.parse_pbkdf_response payload with
149
+
| Error e -> Error (`Msg e)
150
+
| Ok v -> Ok v)))
151
+
152
+
let pase_pake1_exchange ~clock conn ~exchange_id ~pa =
153
+
let payload = Msg.make_pase_pake1 ~pa in
154
+
let msg =
155
+
build_unsecured_message ~session:conn.session ~exchange_id
156
+
~protocol_id:Msg.Protocol.secure_channel
157
+
~opcode:Msg.Secure_channel.pase_pake1 ~payload
158
+
in
159
+
send_message conn msg;
160
+
match receive_message ~clock conn ~timeout:5.0 with
161
+
| Error `Timeout -> Error (`Msg "Timeout waiting for PAKE2")
162
+
| Ok response -> (
163
+
match Msg.decode_message_header response with
164
+
| Error e -> Error (`Msg e)
165
+
| Ok (_msg_hdr, payload_offset) -> (
166
+
match Msg.decode_protocol_header response payload_offset with
167
+
| Error e -> Error (`Msg e)
168
+
| Ok (proto_hdr, data_offset) -> (
169
+
if proto_hdr.protocol_opcode <> Msg.Secure_channel.pase_pake2 then
170
+
Error
171
+
(`Msg
172
+
(Printf.sprintf "Expected PAKE2, got opcode %d"
173
+
proto_hdr.protocol_opcode))
174
+
else
175
+
let payload =
176
+
String.sub response data_offset
177
+
(String.length response - data_offset)
178
+
in
179
+
match Pase.parse_pake2 payload with
180
+
| Error e -> Error (`Msg e)
181
+
| Ok (pb, cb) -> Ok (pb, cb))))
182
+
183
+
let pase_pake3_exchange ~clock conn ~exchange_id ~ca =
184
+
let payload = Msg.make_pase_pake3 ~ca in
185
+
let msg =
186
+
build_unsecured_message ~session:conn.session ~exchange_id
187
+
~protocol_id:Msg.Protocol.secure_channel
188
+
~opcode:Msg.Secure_channel.pase_pake3 ~payload
189
+
in
190
+
send_message conn msg;
191
+
match receive_message ~clock conn ~timeout:5.0 with
192
+
| Error `Timeout -> Error (`Msg "Timeout waiting for StatusReport")
193
+
| Ok response -> (
194
+
match Msg.decode_message_header response with
195
+
| Error e -> Error (`Msg e)
196
+
| Ok (_msg_hdr, payload_offset) -> (
197
+
match Msg.decode_protocol_header response payload_offset with
198
+
| Error e -> Error (`Msg e)
199
+
| Ok (proto_hdr, _data_offset) ->
200
+
if proto_hdr.protocol_opcode = Msg.Secure_channel.status_report
201
+
then Ok ()
202
+
else
203
+
Error
204
+
(`Msg
205
+
(Printf.sprintf "Expected StatusReport, got opcode %d"
206
+
proto_hdr.protocol_opcode))))
207
+
208
+
let establish_pase ~net ~sw ~clock ~ip ~port ~passcode =
209
+
let conn = connect ~net ~sw ~ip ~port in
210
+
211
+
let initiator_random = Crypto_rng.generate 32 in
212
+
(* Use secure random for session ID *)
213
+
let session_id_bytes = Crypto_rng.generate 2 in
214
+
let session_id =
215
+
(Char.code session_id_bytes.[0] lsl 8) lor Char.code session_id_bytes.[1]
216
+
in
217
+
let exchange_id = next_exchange_id () in
218
+
219
+
Log.info (fun m ->
220
+
m "Starting PASE with %s:%d, session_id=%d" ip port session_id);
221
+
222
+
let* responder_random, peer_session_id, iterations, salt =
223
+
pase_pbkdf_exchange ~clock conn ~initiator_random ~session_id
224
+
in
225
+
Log.info (fun m ->
226
+
m "Got PBKDF params: iterations=%d, salt_len=%d, peer_session=%d"
227
+
iterations (String.length salt) peer_session_id);
228
+
229
+
conn.session.peer_session_id <- peer_session_id;
230
+
231
+
let context =
232
+
Pase.make_context ~initiator_random ~responder_random
233
+
~pbkdf_params_responder:salt
234
+
in
235
+
236
+
let state, pa = Pase.prover_init ~passcode ~salt ~iterations ~context in
237
+
Log.debug (fun m -> m "Sending PAKE1 with pA (%d bytes)" (String.length pa));
238
+
239
+
let* pb, cb = pase_pake1_exchange ~clock conn ~exchange_id ~pa in
240
+
Log.debug (fun m ->
241
+
m "Received PAKE2: pB=%d bytes, cB=%d bytes" (String.length pb)
242
+
(String.length cb));
243
+
244
+
let* ke, ca, expected_cb =
245
+
Pase.prover_finish state pb |> Result.map_error (fun e -> `Msg e)
246
+
in
247
+
if cb <> expected_cb then
248
+
Error (`Msg "PAKE2 confirmation failed - wrong passcode?")
249
+
else begin
250
+
Log.debug (fun m -> m "Device confirmation verified");
251
+
252
+
let* () = pase_pake3_exchange ~clock conn ~exchange_id ~ca in
253
+
Log.info (fun m -> m "PASE completed successfully!");
254
+
255
+
let session_keys =
256
+
Pase.hkdf ~salt:"" ~ikm:ke ~info:"SessionKeys" ~length:48
257
+
in
258
+
let i2r_key = String.sub session_keys 0 16 in
259
+
let r2i_key = String.sub session_keys 16 16 in
260
+
let attestation_challenge = String.sub session_keys 32 16 in
261
+
262
+
conn.session.state <- Authenticated;
263
+
conn.session.i2r_key <- Some i2r_key;
264
+
conn.session.r2i_key <- Some r2i_key;
265
+
conn.session.attestation_challenge <- Some attestation_challenge;
266
+
267
+
Ok conn
268
+
end
269
+
270
+
(** {1 Interaction Model} *)
271
+
272
+
let invoke_command ~clock conn ~endpoint_id ~cluster_id ~command_id
273
+
~command_data =
274
+
let exchange_id = next_exchange_id () in
275
+
276
+
let payload =
277
+
Msg.make_invoke_request ~endpoint_id ~cluster_id ~command_id ~command_data
278
+
in
279
+
280
+
let msg =
281
+
build_unsecured_message ~session:conn.session ~exchange_id
282
+
~protocol_id:Msg.Protocol.interaction_model
283
+
~opcode:Msg.Interaction.invoke_request ~payload
284
+
in
285
+
286
+
send_message conn msg;
287
+
receive_message ~clock conn ~timeout:5.0
288
+
289
+
(** {1 On/Off Commands} *)
290
+
291
+
let turn_on ~clock conn ~endpoint_id =
292
+
invoke_command ~clock conn ~endpoint_id ~cluster_id:Msg.OnOff.cluster_id
293
+
~command_id:Msg.OnOff.on_command ~command_data:[]
294
+
295
+
let turn_off ~clock conn ~endpoint_id =
296
+
invoke_command ~clock conn ~endpoint_id ~cluster_id:Msg.OnOff.cluster_id
297
+
~command_id:Msg.OnOff.off_command ~command_data:[]
298
+
299
+
let toggle ~clock conn ~endpoint_id =
300
+
invoke_command ~clock conn ~endpoint_id ~cluster_id:Msg.OnOff.cluster_id
301
+
~command_id:Msg.OnOff.toggle_command ~command_data:[]
302
+
303
+
(** {1 Pretty Printing} *)
304
+
305
+
let pp_session_state ppf = function
306
+
| Unauthenticated -> Fmt.pf ppf "unauthenticated"
307
+
| Pase_pending -> Fmt.pf ppf "pase_pending"
308
+
| Case_pending -> Fmt.pf ppf "case_pending"
309
+
| Authenticated -> Fmt.pf ppf "authenticated"
310
+
311
+
let pp_session ppf s =
312
+
Fmt.pf ppf "Session{%s:%d, state=%a, id=%d, peer=%d}" s.ip s.port
313
+
pp_session_state s.state s.session_id s.peer_session_id
+99
lib/session.mli
+99
lib/session.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter session management and transport.
7
+
8
+
UDP-based transport and session state for Matter device communication.
9
+
Supports PASE (passcode) authentication. *)
10
+
11
+
(** {1:types Types} *)
12
+
13
+
type session_state =
14
+
| Unauthenticated
15
+
| Pase_pending
16
+
| Case_pending
17
+
| Authenticated
18
+
19
+
type session = {
20
+
mutable state : session_state;
21
+
mutable session_id : int;
22
+
mutable peer_session_id : int;
23
+
mutable message_counter : int32;
24
+
mutable peer_node_id : int64 option;
25
+
mutable i2r_key : string option;
26
+
mutable r2i_key : string option;
27
+
mutable attestation_challenge : string option;
28
+
ip : string;
29
+
port : int;
30
+
}
31
+
32
+
type 'a connection = {
33
+
session : session;
34
+
sock : 'a Eio.Net.datagram_socket;
35
+
remote_addr : Eio.Net.Sockaddr.datagram;
36
+
}
37
+
38
+
(** {1:session Session management} *)
39
+
40
+
val create_session : ip:string -> port:int -> session
41
+
val next_message_counter : session -> int32
42
+
val next_exchange_id : unit -> int
43
+
44
+
(** {1:transport UDP transport} *)
45
+
46
+
val connect :
47
+
net:([> `Generic ] as 'a) Eio.Net.ty Eio.Resource.t ->
48
+
sw:Eio.Switch.t ->
49
+
ip:string ->
50
+
port:int ->
51
+
'a Eio.Net.datagram_socket_ty connection
52
+
53
+
val send_message : _ connection -> string -> unit
54
+
55
+
val receive_message :
56
+
clock:_ Eio.Time.clock ->
57
+
_ connection ->
58
+
timeout:float ->
59
+
(string, [> `Timeout ]) result
60
+
61
+
(** {1:pase PASE authentication} *)
62
+
63
+
val establish_pase :
64
+
net:([> `Generic ] as 'a) Eio.Net.ty Eio.Resource.t ->
65
+
sw:Eio.Switch.t ->
66
+
clock:_ Eio.Time.clock ->
67
+
ip:string ->
68
+
port:int ->
69
+
passcode:int ->
70
+
('a Eio.Net.datagram_socket_ty connection, [> `Msg of string ]) result
71
+
(** [establish_pase ~net ~sw ~clock ~ip ~port ~passcode] establishes
72
+
authenticated session using device passcode.
73
+
74
+
The passcode is typically 8 digits (e.g., 20202021). *)
75
+
76
+
(** {1:commands Device commands} *)
77
+
78
+
val turn_on :
79
+
clock:_ Eio.Time.clock ->
80
+
_ connection ->
81
+
endpoint_id:int ->
82
+
(string, [> `Timeout ]) result
83
+
84
+
val turn_off :
85
+
clock:_ Eio.Time.clock ->
86
+
_ connection ->
87
+
endpoint_id:int ->
88
+
(string, [> `Timeout ]) result
89
+
90
+
val toggle :
91
+
clock:_ Eio.Time.clock ->
92
+
_ connection ->
93
+
endpoint_id:int ->
94
+
(string, [> `Timeout ]) result
95
+
96
+
(** {1:pp Pretty printing} *)
97
+
98
+
val pp_session_state : session_state Fmt.t
99
+
val pp_session : session Fmt.t
+418
lib/tlv.ml
+418
lib/tlv.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter TLV (Tag-Length-Value) encoding and decoding *)
7
+
8
+
(* Result monad operators *)
9
+
let ( let* ) = Result.bind
10
+
11
+
(** {1 TLV Types} *)
12
+
13
+
(** Tag forms (bits 5-6 of control byte) *)
14
+
type tag_form =
15
+
| Anonymous (* 0 *)
16
+
| Context_specific of int (* 1: 1 byte tag *)
17
+
| Common_profile_2 of int (* 2: 2 byte tag *)
18
+
| Common_profile_4 of int32 (* 3: 4 byte tag *)
19
+
| Implicit_profile_2 of int (* 4: 2 byte tag *)
20
+
| Implicit_profile_4 of int32 (* 5: 4 byte tag *)
21
+
| Fully_qualified_6 of int32 * int (* 6: 4 byte vendor + 2 byte tag *)
22
+
| Fully_qualified_8 of int32 * int32 (* 7: 4 byte vendor + 4 byte tag *)
23
+
24
+
(** TLV value *)
25
+
type value =
26
+
| Int of int64
27
+
| Uint of int64
28
+
| Bool of bool
29
+
| Float32 of float
30
+
| Float64 of float
31
+
| String of string
32
+
| Bytes of string
33
+
| Null
34
+
| Structure of element list
35
+
| Array of element list
36
+
| List of element list
37
+
38
+
and element = { tag : tag_form; value : value }
39
+
40
+
(** {1 Encoding} *)
41
+
42
+
let put_byte buf b = Buffer.add_char buf (Char.chr (b land 0xff))
43
+
44
+
let put_uint16_le buf v =
45
+
put_byte buf v;
46
+
put_byte buf (v lsr 8)
47
+
48
+
let put_uint32_le buf v =
49
+
put_byte buf (Int32.to_int v);
50
+
put_byte buf (Int32.to_int (Int32.shift_right_logical v 8));
51
+
put_byte buf (Int32.to_int (Int32.shift_right_logical v 16));
52
+
put_byte buf (Int32.to_int (Int32.shift_right_logical v 24))
53
+
54
+
let put_uint64_le buf v =
55
+
put_byte buf (Int64.to_int v);
56
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v 8));
57
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v 16));
58
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v 24));
59
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v 32));
60
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v 40));
61
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v 48));
62
+
put_byte buf (Int64.to_int (Int64.shift_right_logical v 56))
63
+
64
+
let tag_form_code = function
65
+
| Anonymous -> 0
66
+
| Context_specific _ -> 1
67
+
| Common_profile_2 _ -> 2
68
+
| Common_profile_4 _ -> 3
69
+
| Implicit_profile_2 _ -> 4
70
+
| Implicit_profile_4 _ -> 5
71
+
| Fully_qualified_6 _ -> 6
72
+
| Fully_qualified_8 _ -> 7
73
+
74
+
let encode_tag buf = function
75
+
| Anonymous -> ()
76
+
| Context_specific t -> put_byte buf t
77
+
| Common_profile_2 t -> put_uint16_le buf t
78
+
| Common_profile_4 t -> put_uint32_le buf t
79
+
| Implicit_profile_2 t -> put_uint16_le buf t
80
+
| Implicit_profile_4 t -> put_uint32_le buf t
81
+
| Fully_qualified_6 (v, t) ->
82
+
put_uint32_le buf v;
83
+
put_uint16_le buf t
84
+
| Fully_qualified_8 (v, t) ->
85
+
put_uint32_le buf v;
86
+
put_uint32_le buf t
87
+
88
+
(* Determine integer size code (0-3) based on value *)
89
+
let int_size_code v =
90
+
if v >= -128L && v <= 127L then 0
91
+
else if v >= -32768L && v <= 32767L then 1
92
+
else if v >= -2147483648L && v <= 2147483647L then 2
93
+
else 3
94
+
95
+
let uint_size_code v =
96
+
(* Use unsigned comparison - negative int64 values are large unsigned values *)
97
+
if Int64.unsigned_compare v 0xFFL <= 0 then 0
98
+
else if Int64.unsigned_compare v 0xFFFFL <= 0 then 1
99
+
else if Int64.unsigned_compare v 0xFFFFFFFFL <= 0 then 2
100
+
else 3
101
+
102
+
let encode_int buf v size_code =
103
+
match size_code with
104
+
| 0 -> put_byte buf (Int64.to_int v)
105
+
| 1 -> put_uint16_le buf (Int64.to_int v)
106
+
| 2 -> put_uint32_le buf (Int64.of_int32 (Int64.to_int32 v) |> Int64.to_int32)
107
+
| 3 -> put_uint64_le buf v
108
+
| _ -> failwith "Invalid size code"
109
+
110
+
let rec encode_element buf elem =
111
+
let encode_control tag_form type_code =
112
+
let tag_code = tag_form_code tag_form in
113
+
put_byte buf ((tag_code lsl 5) lor type_code)
114
+
in
115
+
match elem.value with
116
+
| Int v ->
117
+
let size_code = int_size_code v in
118
+
encode_control elem.tag size_code;
119
+
encode_tag buf elem.tag;
120
+
encode_int buf v size_code
121
+
| Uint v ->
122
+
let size_code = uint_size_code v in
123
+
encode_control elem.tag (4 + size_code);
124
+
encode_tag buf elem.tag;
125
+
encode_int buf v size_code
126
+
| Bool false ->
127
+
encode_control elem.tag 8;
128
+
encode_tag buf elem.tag
129
+
| Bool true ->
130
+
encode_control elem.tag 9;
131
+
encode_tag buf elem.tag
132
+
| Float32 f ->
133
+
encode_control elem.tag 10;
134
+
encode_tag buf elem.tag;
135
+
put_uint32_le buf (Int32.bits_of_float f)
136
+
| Float64 f ->
137
+
encode_control elem.tag 11;
138
+
encode_tag buf elem.tag;
139
+
put_uint64_le buf (Int64.bits_of_float f)
140
+
| String s ->
141
+
let len = String.length s in
142
+
let size_code = uint_size_code (Int64.of_int len) in
143
+
encode_control elem.tag (12 + size_code);
144
+
encode_tag buf elem.tag;
145
+
encode_int buf (Int64.of_int len) size_code;
146
+
Buffer.add_string buf s
147
+
| Bytes s ->
148
+
let len = String.length s in
149
+
let size_code = uint_size_code (Int64.of_int len) in
150
+
encode_control elem.tag (16 + size_code);
151
+
encode_tag buf elem.tag;
152
+
encode_int buf (Int64.of_int len) size_code;
153
+
Buffer.add_string buf s
154
+
| Null ->
155
+
encode_control elem.tag 20;
156
+
encode_tag buf elem.tag
157
+
| Structure elems ->
158
+
encode_control elem.tag 21;
159
+
encode_tag buf elem.tag;
160
+
List.iter (encode_element buf) elems;
161
+
put_byte buf 0x18 (* End of container *)
162
+
| Array elems ->
163
+
encode_control elem.tag 22;
164
+
encode_tag buf elem.tag;
165
+
List.iter (encode_element buf) elems;
166
+
put_byte buf 0x18
167
+
| List elems ->
168
+
encode_control elem.tag 23;
169
+
encode_tag buf elem.tag;
170
+
List.iter (encode_element buf) elems;
171
+
put_byte buf 0x18
172
+
173
+
let encode elems =
174
+
let buf = Buffer.create 256 in
175
+
List.iter (encode_element buf) elems;
176
+
Buffer.contents buf
177
+
178
+
let encode_one elem = encode [ elem ]
179
+
180
+
(** {1 Decoding} *)
181
+
182
+
let get_byte data offset =
183
+
if offset >= String.length data then Error "Unexpected end of data"
184
+
else Ok (Char.code data.[offset], offset + 1)
185
+
186
+
let get_uint16_le data offset =
187
+
if offset + 2 > String.length data then Error "Unexpected end of data"
188
+
else
189
+
let b0 = Char.code data.[offset] in
190
+
let b1 = Char.code data.[offset + 1] in
191
+
Ok (b0 lor (b1 lsl 8), offset + 2)
192
+
193
+
let get_uint32_le data offset =
194
+
if offset + 4 > String.length data then Error "Unexpected end of data"
195
+
else
196
+
let b0 = Int32.of_int (Char.code data.[offset]) in
197
+
let b1 = Int32.of_int (Char.code data.[offset + 1]) in
198
+
let b2 = Int32.of_int (Char.code data.[offset + 2]) in
199
+
let b3 = Int32.of_int (Char.code data.[offset + 3]) in
200
+
Ok
201
+
( Int32.(
202
+
add
203
+
(add b0 (shift_left b1 8))
204
+
(add (shift_left b2 16) (shift_left b3 24))),
205
+
offset + 4 )
206
+
207
+
let get_uint64_le data offset =
208
+
if offset + 8 > String.length data then Error "Unexpected end of data"
209
+
else
210
+
let get_byte i = Int64.of_int (Char.code data.[offset + i]) in
211
+
let v = ref 0L in
212
+
for i = 7 downto 0 do
213
+
v := Int64.add (Int64.shift_left !v 8) (get_byte i)
214
+
done;
215
+
Ok (!v, offset + 8)
216
+
217
+
let get_int data offset size_code =
218
+
match size_code with
219
+
| 0 ->
220
+
let* b, off = get_byte data offset in
221
+
let v = if b >= 128 then b - 256 else b in
222
+
Ok (Int64.of_int v, off)
223
+
| 1 ->
224
+
let* v, off = get_uint16_le data offset in
225
+
let v = if v >= 32768 then v - 65536 else v in
226
+
Ok (Int64.of_int v, off)
227
+
| 2 ->
228
+
let* v, off = get_uint32_le data offset in
229
+
Ok (Int64.of_int32 v, off)
230
+
| 3 -> get_uint64_le data offset
231
+
| _ -> Error "Invalid size code"
232
+
233
+
let get_uint data offset size_code =
234
+
match size_code with
235
+
| 0 ->
236
+
let* b, off = get_byte data offset in
237
+
Ok (Int64.of_int b, off)
238
+
| 1 ->
239
+
let* v, off = get_uint16_le data offset in
240
+
Ok (Int64.of_int v, off)
241
+
| 2 ->
242
+
let* v, off = get_uint32_le data offset in
243
+
Ok (Int64.of_int32 v |> Int64.logand 0xFFFFFFFFL, off)
244
+
| 3 -> get_uint64_le data offset
245
+
| _ -> Error "Invalid size code"
246
+
247
+
let get_bytes data offset len =
248
+
if len < 0 || offset < 0 || offset + len > String.length data then
249
+
Error "Unexpected end of data"
250
+
else Ok (String.sub data offset len, offset + len)
251
+
252
+
let decode_tag data offset tag_form_code =
253
+
match tag_form_code with
254
+
| 0 -> Ok (Anonymous, offset)
255
+
| 1 ->
256
+
let* t, off = get_byte data offset in
257
+
Ok (Context_specific t, off)
258
+
| 2 ->
259
+
let* t, off = get_uint16_le data offset in
260
+
Ok (Common_profile_2 t, off)
261
+
| 3 ->
262
+
let* t, off = get_uint32_le data offset in
263
+
Ok (Common_profile_4 t, off)
264
+
| 4 ->
265
+
let* t, off = get_uint16_le data offset in
266
+
Ok (Implicit_profile_2 t, off)
267
+
| 5 ->
268
+
let* t, off = get_uint32_le data offset in
269
+
Ok (Implicit_profile_4 t, off)
270
+
| 6 ->
271
+
let* v, off = get_uint32_le data offset in
272
+
let* t, off = get_uint16_le data off in
273
+
Ok (Fully_qualified_6 (v, t), off)
274
+
| 7 ->
275
+
let* v, off = get_uint32_le data offset in
276
+
let* t, off = get_uint32_le data off in
277
+
Ok (Fully_qualified_8 (v, t), off)
278
+
| _ -> Error "Invalid tag form"
279
+
280
+
let rec decode_element data offset =
281
+
let* control, offset = get_byte data offset in
282
+
let type_code = control land 0x1f in
283
+
let tag_form_code = (control lsr 5) land 0x7 in
284
+
if type_code = 24 then (* End of container *)
285
+
Ok (None, offset)
286
+
else
287
+
let* tag, offset = decode_tag data offset tag_form_code in
288
+
let* value, offset = decode_value data offset type_code in
289
+
Ok (Some { tag; value }, offset)
290
+
291
+
and decode_value data offset type_code =
292
+
match type_code with
293
+
| 0 | 1 | 2 | 3 ->
294
+
(* Signed int *)
295
+
let size_code = type_code in
296
+
let* v, off = get_int data offset size_code in
297
+
Ok (Int v, off)
298
+
| 4 | 5 | 6 | 7 ->
299
+
(* Unsigned int *)
300
+
let size_code = type_code - 4 in
301
+
let* v, off = get_uint data offset size_code in
302
+
Ok (Uint v, off)
303
+
| 8 -> Ok (Bool false, offset)
304
+
| 9 -> Ok (Bool true, offset)
305
+
| 10 ->
306
+
(* Float32 *)
307
+
let* bits, off = get_uint32_le data offset in
308
+
Ok (Float32 (Int32.float_of_bits bits), off)
309
+
| 11 ->
310
+
(* Float64 *)
311
+
let* bits, off = get_uint64_le data offset in
312
+
Ok (Float64 (Int64.float_of_bits bits), off)
313
+
| 12 | 13 | 14 | 15 ->
314
+
(* UTF8 string *)
315
+
let size_code = type_code - 12 in
316
+
let* len, off = get_uint data offset size_code in
317
+
let* s, off = get_bytes data off (Int64.to_int len) in
318
+
Ok (String s, off)
319
+
| 16 | 17 | 18 | 19 ->
320
+
(* Byte string *)
321
+
let size_code = type_code - 16 in
322
+
let* len, off = get_uint data offset size_code in
323
+
let* s, off = get_bytes data off (Int64.to_int len) in
324
+
Ok (Bytes s, off)
325
+
| 20 -> Ok (Null, offset)
326
+
| 21 ->
327
+
(* Structure *)
328
+
let* elems, off = decode_container data offset in
329
+
Ok (Structure elems, off)
330
+
| 22 ->
331
+
(* Array *)
332
+
let* elems, off = decode_container data offset in
333
+
Ok (Array elems, off)
334
+
| 23 ->
335
+
(* List *)
336
+
let* elems, off = decode_container data offset in
337
+
Ok (List elems, off)
338
+
| _ -> Error (Printf.sprintf "Unknown type code: %d" type_code)
339
+
340
+
and decode_container data offset =
341
+
let rec loop acc offset =
342
+
let* elem_opt, offset = decode_element data offset in
343
+
match elem_opt with
344
+
| None -> Ok (List.rev acc, offset)
345
+
| Some elem -> loop (elem :: acc) offset
346
+
in
347
+
loop [] offset
348
+
349
+
let decode data =
350
+
let rec loop acc offset =
351
+
if offset >= String.length data then Ok (List.rev acc)
352
+
else
353
+
let* elem_opt, offset = decode_element data offset in
354
+
match elem_opt with
355
+
| None -> Ok (List.rev acc)
356
+
| Some elem -> loop (elem :: acc) offset
357
+
in
358
+
loop [] 0
359
+
360
+
(** {1 Helper constructors} *)
361
+
362
+
let int ?(tag = Anonymous) v = { tag; value = Int v }
363
+
let uint ?(tag = Anonymous) v = { tag; value = Uint v }
364
+
let bool ?(tag = Anonymous) v = { tag; value = Bool v }
365
+
let string ?(tag = Anonymous) v = { tag; value = String v }
366
+
let bytes ?(tag = Anonymous) v = { tag; value = Bytes v }
367
+
let null ?(tag = Anonymous) () = { tag; value = Null }
368
+
let structure ?(tag = Anonymous) elems = { tag; value = Structure elems }
369
+
let array ?(tag = Anonymous) elems = { tag; value = Array elems }
370
+
let list ?(tag = Anonymous) elems = { tag; value = List elems }
371
+
372
+
(* Context-tagged helpers *)
373
+
let ctx_int tag v = { tag = Context_specific tag; value = Int (Int64.of_int v) }
374
+
375
+
let ctx_uint tag v =
376
+
{ tag = Context_specific tag; value = Uint (Int64.of_int v) }
377
+
378
+
let ctx_bool tag v = { tag = Context_specific tag; value = Bool v }
379
+
let ctx_string tag v = { tag = Context_specific tag; value = String v }
380
+
let ctx_bytes tag v = { tag = Context_specific tag; value = Bytes v }
381
+
382
+
let ctx_struct tag elems =
383
+
{ tag = Context_specific tag; value = Structure elems }
384
+
385
+
let ctx_array tag elems = { tag = Context_specific tag; value = Array elems }
386
+
387
+
(** {1 Pretty printing} *)
388
+
389
+
let rec pp_value ppf = function
390
+
| Int v -> Fmt.pf ppf "%Ld" v
391
+
| Uint v -> Fmt.pf ppf "%Lu" v
392
+
| Bool b -> Fmt.pf ppf "%b" b
393
+
| Float32 f -> Fmt.pf ppf "%f" f
394
+
| Float64 f -> Fmt.pf ppf "%f" f
395
+
| String s -> Fmt.pf ppf "%S" s
396
+
| Bytes s -> Fmt.pf ppf "<bytes:%d>" (String.length s)
397
+
| Null -> Fmt.pf ppf "null"
398
+
| Structure elems -> Fmt.pf ppf "{%a}" pp_elements elems
399
+
| Array elems -> Fmt.pf ppf "[%a]" pp_elements elems
400
+
| List elems -> Fmt.pf ppf "(%a)" pp_elements elems
401
+
402
+
and pp_tag ppf = function
403
+
| Anonymous -> ()
404
+
| Context_specific t -> Fmt.pf ppf "%d: " t
405
+
| Common_profile_2 t -> Fmt.pf ppf "CP2(%d): " t
406
+
| Common_profile_4 t -> Fmt.pf ppf "CP4(%ld): " t
407
+
| Implicit_profile_2 t -> Fmt.pf ppf "IP2(%d): " t
408
+
| Implicit_profile_4 t -> Fmt.pf ppf "IP4(%ld): " t
409
+
| Fully_qualified_6 (v, t) -> Fmt.pf ppf "FQ6(%ld,%d): " v t
410
+
| Fully_qualified_8 (v, t) -> Fmt.pf ppf "FQ8(%ld,%ld): " v t
411
+
412
+
and pp_element ppf elem = Fmt.pf ppf "%a%a" pp_tag elem.tag pp_value elem.value
413
+
414
+
and pp_elements ppf elems =
415
+
Fmt.pf ppf "%a" (Fmt.list ~sep:(Fmt.any ", ") pp_element) elems
416
+
417
+
let pp ppf elems =
418
+
Fmt.pf ppf "%a" (Fmt.list ~sep:(Fmt.any "; ") pp_element) elems
+124
lib/tlv.mli
+124
lib/tlv.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Matter TLV (Tag-Length-Value) encoding and decoding.
7
+
8
+
Binary serialization format used by Matter for protocol messages. Supports
9
+
integers, booleans, strings, bytes, floats, and nested containers
10
+
(structures, arrays, lists).
11
+
12
+
See
13
+
{{:https://csa-iot.org/developer-resource/specifications-download-request/}
14
+
Matter Core Specification} Appendix A for the full TLV format
15
+
specification. *)
16
+
17
+
(** {1:types Types} *)
18
+
19
+
(** Tag forms for element identification. *)
20
+
type tag_form =
21
+
| Anonymous
22
+
| Context_specific of int
23
+
| Common_profile_2 of int
24
+
| Common_profile_4 of int32
25
+
| Implicit_profile_2 of int
26
+
| Implicit_profile_4 of int32
27
+
| Fully_qualified_6 of int32 * int
28
+
| Fully_qualified_8 of int32 * int32
29
+
30
+
(** TLV value. *)
31
+
type value =
32
+
| Int of int64
33
+
| Uint of int64
34
+
| Bool of bool
35
+
| Float32 of float
36
+
| Float64 of float
37
+
| String of string
38
+
| Bytes of string
39
+
| Null
40
+
| Structure of element list
41
+
| Array of element list
42
+
| List of element list
43
+
44
+
and element = { tag : tag_form; value : value }
45
+
(** TLV element (tagged value). *)
46
+
47
+
(** {1:encoding Encoding} *)
48
+
49
+
val encode : element list -> string
50
+
(** [encode elems] encodes elements to binary TLV format. *)
51
+
52
+
val encode_one : element -> string
53
+
(** [encode_one elem] encodes a single element to binary TLV format. *)
54
+
55
+
(** {1:decoding Decoding} *)
56
+
57
+
val decode : string -> (element list, string) result
58
+
(** [decode data] decodes binary TLV data to elements. *)
59
+
60
+
(** {1:constructors Element constructors} *)
61
+
62
+
val int : ?tag:tag_form -> int64 -> element
63
+
(** [int ?tag v] creates a signed integer element. *)
64
+
65
+
val uint : ?tag:tag_form -> int64 -> element
66
+
(** [uint ?tag v] creates an unsigned integer element. *)
67
+
68
+
val bool : ?tag:tag_form -> bool -> element
69
+
(** [bool ?tag v] creates a boolean element. *)
70
+
71
+
val string : ?tag:tag_form -> string -> element
72
+
(** [string ?tag v] creates a UTF-8 string element. *)
73
+
74
+
val bytes : ?tag:tag_form -> string -> element
75
+
(** [bytes ?tag v] creates a byte string element. *)
76
+
77
+
val null : ?tag:tag_form -> unit -> element
78
+
(** [null ?tag ()] creates a null element. *)
79
+
80
+
val structure : ?tag:tag_form -> element list -> element
81
+
(** [structure ?tag elems] creates a structure container. *)
82
+
83
+
val array : ?tag:tag_form -> element list -> element
84
+
(** [array ?tag elems] creates an array container. *)
85
+
86
+
val list : ?tag:tag_form -> element list -> element
87
+
(** [list ?tag elems] creates a list container. *)
88
+
89
+
(** {2:context Context-tagged constructors} *)
90
+
91
+
val ctx_int : int -> int -> element
92
+
(** [ctx_int tag v] creates a context-tagged signed integer. *)
93
+
94
+
val ctx_uint : int -> int -> element
95
+
(** [ctx_uint tag v] creates a context-tagged unsigned integer. *)
96
+
97
+
val ctx_bool : int -> bool -> element
98
+
(** [ctx_bool tag v] creates a context-tagged boolean. *)
99
+
100
+
val ctx_string : int -> string -> element
101
+
(** [ctx_string tag v] creates a context-tagged UTF-8 string. *)
102
+
103
+
val ctx_bytes : int -> string -> element
104
+
(** [ctx_bytes tag v] creates a context-tagged byte string. *)
105
+
106
+
val ctx_struct : int -> element list -> element
107
+
(** [ctx_struct tag elems] creates a context-tagged structure. *)
108
+
109
+
val ctx_array : int -> element list -> element
110
+
(** [ctx_array tag elems] creates a context-tagged array. *)
111
+
112
+
(** {1:pp Pretty printing} *)
113
+
114
+
val pp_value : value Fmt.t
115
+
(** [pp_value] pretty-prints a TLV value. *)
116
+
117
+
val pp_tag : tag_form Fmt.t
118
+
(** [pp_tag] pretty-prints a tag form. *)
119
+
120
+
val pp_element : element Fmt.t
121
+
(** [pp_element] pretty-prints an element. *)
122
+
123
+
val pp : element list Fmt.t
124
+
(** [pp] pretty-prints a list of elements. *)
+47
matter.opam
+47
matter.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Matter protocol implementation for OCaml"
4
+
description: """
5
+
Implementation of the Matter smart home protocol for OCaml.
6
+
Includes TLV encoding/decoding, PASE authentication using SPAKE2+,
7
+
message framing, mDNS device discovery, and AES-CCM encryption
8
+
as specified in the Matter Core Specification."""
9
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
10
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
11
+
license: "MIT"
12
+
homepage: "https://github.com/samoht/ocaml-matter"
13
+
bug-reports: "https://github.com/samoht/ocaml-matter/issues"
14
+
depends: [
15
+
"dune" {>= "3.0"}
16
+
"ocaml" {>= "4.14"}
17
+
"dune-configurator" {< "3.21"}
18
+
"digestif" {>= "1.0"}
19
+
"eio" {>= "1.0"}
20
+
"kdf" {>= "0.1"}
21
+
"mdns" {>= "0.1"}
22
+
"spake2" {>= "0.1"}
23
+
"crypto" {>= "1.0"}
24
+
"crypto-rng" {>= "1.0"}
25
+
"cstruct" {>= "6.0"}
26
+
"ipaddr" {>= "5.0"}
27
+
"domain-name" {>= "0.4"}
28
+
"logs" {>= "0.7"}
29
+
"fmt" {>= "0.9"}
30
+
"alcotest" {with-test}
31
+
"crowbar" {with-test}
32
+
"odoc" {with-doc}
33
+
]
34
+
build: [
35
+
["dune" "subst"] {dev}
36
+
[
37
+
"dune"
38
+
"build"
39
+
"-p"
40
+
name
41
+
"-j"
42
+
jobs
43
+
"@install"
44
+
"@runtest" {with-test}
45
+
"@doc" {with-doc}
46
+
]
47
+
]
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "matter" Test_tlv.suite
+258
test/test_tlv.ml
+258
test/test_tlv.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Matter.Tlv
7
+
8
+
let element =
9
+
Alcotest.testable pp_element (fun a b ->
10
+
Matter.Tlv.encode_one a = Matter.Tlv.encode_one b)
11
+
12
+
let elements = Alcotest.list element
13
+
14
+
(* Test vectors from Matter Core Specification Appendix A *)
15
+
16
+
let test_encode_signed_int_1byte () =
17
+
let elem = int 42L in
18
+
let encoded = encode_one elem in
19
+
Alcotest.(check string) "1-byte signed int" "002a" (Ohex.encode encoded)
20
+
21
+
let test_encode_signed_int_negative () =
22
+
let elem = int (-1L) in
23
+
let encoded = encode_one elem in
24
+
Alcotest.(check string) "negative signed int" "00ff" (Ohex.encode encoded)
25
+
26
+
let test_encode_unsigned_int_1byte () =
27
+
let elem = uint 42L in
28
+
let encoded = encode_one elem in
29
+
Alcotest.(check string) "1-byte unsigned int" "042a" (Ohex.encode encoded)
30
+
31
+
let test_encode_unsigned_int_2byte () =
32
+
let elem = uint 1000L in
33
+
let encoded = encode_one elem in
34
+
Alcotest.(check string) "2-byte unsigned int" "05e803" (Ohex.encode encoded)
35
+
36
+
let test_encode_bool_false () =
37
+
let elem = bool false in
38
+
let encoded = encode_one elem in
39
+
Alcotest.(check string) "bool false" "08" (Ohex.encode encoded)
40
+
41
+
let test_encode_bool_true () =
42
+
let elem = bool true in
43
+
let encoded = encode_one elem in
44
+
Alcotest.(check string) "bool true" "09" (Ohex.encode encoded)
45
+
46
+
let test_encode_null () =
47
+
let elem = null () in
48
+
let encoded = encode_one elem in
49
+
Alcotest.(check string) "null" "14" (Ohex.encode encoded)
50
+
51
+
let test_encode_string () =
52
+
let elem = string "Hello" in
53
+
let encoded = encode_one elem in
54
+
Alcotest.(check string) "string" "0c0548656c6c6f" (Ohex.encode encoded)
55
+
56
+
let test_encode_bytes () =
57
+
let elem = bytes "\x01\x02\x03" in
58
+
let encoded = encode_one elem in
59
+
Alcotest.(check string) "bytes" "1003010203" (Ohex.encode encoded)
60
+
61
+
let test_encode_context_tag () =
62
+
let elem = ctx_int 1 42 in
63
+
let encoded = encode_one elem in
64
+
(* ctx_int creates signed int: control=0x20 (tag_form=1, type=0), tag=0x01, value=0x2a *)
65
+
Alcotest.(check string) "context-tagged int" "20012a" (Ohex.encode encoded)
66
+
67
+
let test_encode_structure () =
68
+
let elem = structure [ ctx_int 1 42; ctx_bool 2 true ] in
69
+
let encoded = encode_one elem in
70
+
(* struct start=0x15, ctx_int(signed)=0x20 0x01 0x2a, ctx_bool_true=0x29 0x02, end=0x18 *)
71
+
Alcotest.(check string) "structure" "1520012a290218" (Ohex.encode encoded)
72
+
73
+
let test_encode_array () =
74
+
let elem = array [ int 1L; int 2L; int 3L ] in
75
+
let encoded = encode_one elem in
76
+
(* array start=0x16, int 1=0x00 0x01, int 2=0x00 0x02, int 3=0x00 0x03, end=0x18 *)
77
+
Alcotest.(check string) "array" "1600010002000318" (Ohex.encode encoded)
78
+
79
+
let test_decode_signed_int () =
80
+
let data = Ohex.decode "002a" in
81
+
match decode data with
82
+
| Ok [ elem ] -> Alcotest.(check element) "decoded int" (int 42L) elem
83
+
| Ok _ -> Alcotest.fail "Expected single element"
84
+
| Error e -> Alcotest.fail e
85
+
86
+
let test_decode_unsigned_int () =
87
+
let data = Ohex.decode "042a" in
88
+
match decode data with
89
+
| Ok [ elem ] -> Alcotest.(check element) "decoded uint" (uint 42L) elem
90
+
| Ok _ -> Alcotest.fail "Expected single element"
91
+
| Error e -> Alcotest.fail e
92
+
93
+
let test_decode_bool () =
94
+
let data = Ohex.decode "09" in
95
+
match decode data with
96
+
| Ok [ elem ] -> Alcotest.(check element) "decoded bool" (bool true) elem
97
+
| Ok _ -> Alcotest.fail "Expected single element"
98
+
| Error e -> Alcotest.fail e
99
+
100
+
let test_decode_string () =
101
+
let data = Ohex.decode "0c0548656c6c6f" in
102
+
match decode data with
103
+
| Ok [ elem ] ->
104
+
Alcotest.(check element) "decoded string" (string "Hello") elem
105
+
| Ok _ -> Alcotest.fail "Expected single element"
106
+
| Error e -> Alcotest.fail e
107
+
108
+
let test_decode_structure () =
109
+
let data = Ohex.decode "1520012a290218" in
110
+
match decode data with
111
+
| Ok [ elem ] ->
112
+
let expected = structure [ ctx_int 1 42; ctx_bool 2 true ] in
113
+
Alcotest.(check element) "decoded structure" expected elem
114
+
| Ok _ -> Alcotest.fail "Expected single element"
115
+
| Error e -> Alcotest.fail e
116
+
117
+
let test_roundtrip_int () =
118
+
let values =
119
+
[ 0L; 1L; -1L; 127L; -128L; 32767L; -32768L; 2147483647L; -2147483648L ]
120
+
in
121
+
List.iter
122
+
(fun v ->
123
+
let elem = int v in
124
+
let encoded = encode_one elem in
125
+
match decode encoded with
126
+
| Ok [ decoded ] ->
127
+
Alcotest.(check element)
128
+
(Printf.sprintf "roundtrip %Ld" v)
129
+
elem decoded
130
+
| Ok _ -> Alcotest.fail "Expected single element"
131
+
| Error e -> Alcotest.fail e)
132
+
values
133
+
134
+
let test_roundtrip_uint () =
135
+
let values = [ 0L; 1L; 255L; 256L; 65535L; 65536L; 0xFFFFFFFFL ] in
136
+
List.iter
137
+
(fun v ->
138
+
let elem = uint v in
139
+
let encoded = encode_one elem in
140
+
match decode encoded with
141
+
| Ok [ decoded ] ->
142
+
Alcotest.(check element)
143
+
(Printf.sprintf "roundtrip %Lu" v)
144
+
elem decoded
145
+
| Ok _ -> Alcotest.fail "Expected single element"
146
+
| Error e -> Alcotest.fail e)
147
+
values
148
+
149
+
let test_roundtrip_string () =
150
+
let values = [ ""; "a"; "Hello, World!"; String.make 300 'x' ] in
151
+
List.iter
152
+
(fun v ->
153
+
let elem = string v in
154
+
let encoded = encode_one elem in
155
+
match decode encoded with
156
+
| Ok [ decoded ] ->
157
+
Alcotest.(check element) "roundtrip string" elem decoded
158
+
| Ok _ -> Alcotest.fail "Expected single element"
159
+
| Error e -> Alcotest.fail e)
160
+
values
161
+
162
+
let test_roundtrip_nested () =
163
+
let elem =
164
+
structure
165
+
[
166
+
ctx_int 1 100;
167
+
ctx_struct 2
168
+
[ ctx_string 1 "nested"; ctx_array 2 [ int 1L; int 2L; int 3L ] ];
169
+
ctx_bool 3 false;
170
+
]
171
+
in
172
+
let encoded = encode_one elem in
173
+
match decode encoded with
174
+
| Ok [ decoded ] -> Alcotest.(check element) "roundtrip nested" elem decoded
175
+
| Ok _ -> Alcotest.fail "Expected single element"
176
+
| Error e -> Alcotest.fail e
177
+
178
+
let test_decode_truncated () =
179
+
let data = Ohex.decode "05" in
180
+
(* 2-byte uint missing data *)
181
+
match decode data with
182
+
| Ok _ -> Alcotest.fail "Should fail on truncated data"
183
+
| Error _ -> ()
184
+
185
+
let test_decode_invalid_type () =
186
+
let data = Ohex.decode "1f" in
187
+
(* Invalid type code 31 *)
188
+
match decode data with
189
+
| Ok _ -> Alcotest.fail "Should fail on invalid type"
190
+
| Error _ -> ()
191
+
192
+
let test_float32 () =
193
+
let elem = { tag = Anonymous; value = Float32 3.14 } in
194
+
let encoded = encode_one elem in
195
+
match decode encoded with
196
+
| Ok [ decoded ] -> (
197
+
match decoded.value with
198
+
| Float32 f -> Alcotest.(check (float 0.001)) "float32" 3.14 f
199
+
| _ -> Alcotest.fail "Expected Float32")
200
+
| Ok _ -> Alcotest.fail "Expected single element"
201
+
| Error e -> Alcotest.fail e
202
+
203
+
let test_float64 () =
204
+
let elem = { tag = Anonymous; value = Float64 3.141592653589793 } in
205
+
let encoded = encode_one elem in
206
+
match decode encoded with
207
+
| Ok [ decoded ] -> (
208
+
match decoded.value with
209
+
| Float64 f ->
210
+
Alcotest.(check (float 1e-15)) "float64" 3.141592653589793 f
211
+
| _ -> Alcotest.fail "Expected Float64")
212
+
| Ok _ -> Alcotest.fail "Expected single element"
213
+
| Error e -> Alcotest.fail e
214
+
215
+
let suite =
216
+
[
217
+
( "encoding",
218
+
[
219
+
Alcotest.test_case "signed int 1-byte" `Quick
220
+
test_encode_signed_int_1byte;
221
+
Alcotest.test_case "signed int negative" `Quick
222
+
test_encode_signed_int_negative;
223
+
Alcotest.test_case "unsigned int 1-byte" `Quick
224
+
test_encode_unsigned_int_1byte;
225
+
Alcotest.test_case "unsigned int 2-byte" `Quick
226
+
test_encode_unsigned_int_2byte;
227
+
Alcotest.test_case "bool false" `Quick test_encode_bool_false;
228
+
Alcotest.test_case "bool true" `Quick test_encode_bool_true;
229
+
Alcotest.test_case "null" `Quick test_encode_null;
230
+
Alcotest.test_case "string" `Quick test_encode_string;
231
+
Alcotest.test_case "bytes" `Quick test_encode_bytes;
232
+
Alcotest.test_case "context tag" `Quick test_encode_context_tag;
233
+
Alcotest.test_case "structure" `Quick test_encode_structure;
234
+
Alcotest.test_case "array" `Quick test_encode_array;
235
+
] );
236
+
( "decoding",
237
+
[
238
+
Alcotest.test_case "signed int" `Quick test_decode_signed_int;
239
+
Alcotest.test_case "unsigned int" `Quick test_decode_unsigned_int;
240
+
Alcotest.test_case "bool" `Quick test_decode_bool;
241
+
Alcotest.test_case "string" `Quick test_decode_string;
242
+
Alcotest.test_case "structure" `Quick test_decode_structure;
243
+
Alcotest.test_case "truncated data" `Quick test_decode_truncated;
244
+
Alcotest.test_case "invalid type" `Quick test_decode_invalid_type;
245
+
] );
246
+
( "roundtrip",
247
+
[
248
+
Alcotest.test_case "integers" `Quick test_roundtrip_int;
249
+
Alcotest.test_case "unsigned integers" `Quick test_roundtrip_uint;
250
+
Alcotest.test_case "strings" `Quick test_roundtrip_string;
251
+
Alcotest.test_case "nested structures" `Quick test_roundtrip_nested;
252
+
] );
253
+
( "floats",
254
+
[
255
+
Alcotest.test_case "float32" `Quick test_float32;
256
+
Alcotest.test_case "float64" `Quick test_float64;
257
+
] );
258
+
]