HomeKit Accessory Protocol (HAP) for OCaml
Squashed 'ocaml-hap/' content from commit f1d21dc git-subtree-split: f1d21dc1e4b9aa9493282654083cc1c3ee941e8a
+1609
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.28.1
+40
dune-project
+40
dune-project
···
1
+
(lang dune 3.0)
2
+
3
+
(name hap)
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-hap")
11
+
(bug_reports "https://github.com/samoht/ocaml-hap/issues")
12
+
13
+
(package
14
+
(name hap)
15
+
(synopsis "HomeKit Accessory Protocol (HAP) for OCaml")
16
+
(description
17
+
"Implementation of the HomeKit Accessory Protocol for controlling HomeKit
18
+
accessories. Includes mDNS discovery, SRP-6a pair setup, Curve25519 pair
19
+
verify, and ChaCha20-Poly1305 encrypted sessions.")
20
+
(depends
21
+
(ocaml (>= 4.14))
22
+
(srp (>= 0.1))
23
+
(mdns (>= 0.1))
24
+
(kdf (>= 0.1))
25
+
(crypto (>= 1.0.0))
26
+
(crypto-ec (>= 1.0.0))
27
+
(crypto-rng (>= 1.0.0))
28
+
(digestif (>= 1.2.0))
29
+
(eio (>= 1.0))
30
+
(eio_main (>= 1.0))
31
+
(re (>= 1.10))
32
+
(jsont (>= 0.1))
33
+
(bytesrw (>= 0.1))
34
+
(base64 (>= 3.5))
35
+
(logs (>= 0.7))
36
+
(fmt (>= 0.9))
37
+
(ipaddr (>= 5.0))
38
+
(domain-name (>= 0.4))
39
+
(alcotest :with-test)
40
+
(crowbar :with-test)))
+15
fuzz/dune
+15
fuzz/dune
···
1
+
; Crowbar fuzz testing for hap
2
+
;
3
+
; To run: dune exec fuzz/fuzz_hap.exe
4
+
; With AFL: afl-fuzz -i fuzz/corpus -o fuzz/findings -- ./_build/default/fuzz/fuzz_hap.exe @@
5
+
6
+
(executable
7
+
(name fuzz_hap)
8
+
(modules fuzz_hap)
9
+
(libraries hap crowbar))
10
+
11
+
(rule
12
+
(alias fuzz)
13
+
(deps fuzz_hap.exe)
14
+
(action
15
+
(run %{exe:fuzz_hap.exe})))
+52
fuzz/fuzz_hap.ml
+52
fuzz/fuzz_hap.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Crowbar
7
+
8
+
(* TLV roundtrip: encode(decode(x)) should produce valid TLV *)
9
+
let test_tlv_decode_encode input =
10
+
(* Decoding arbitrary bytes should not crash *)
11
+
let decoded = Hap.Tlv.decode input in
12
+
(* Re-encoding should produce valid TLV *)
13
+
let _ = Hap.Tlv.encode decoded in
14
+
check true
15
+
16
+
(* TLV encode/decode roundtrip for valid TLV *)
17
+
let test_tlv_roundtrip typ value =
18
+
let tlv = Hap.Tlv.(add typ value empty) in
19
+
let encoded = Hap.Tlv.encode tlv in
20
+
let decoded = Hap.Tlv.decode encoded in
21
+
let retrieved = Hap.Tlv.get typ decoded in
22
+
check_eq ~pp:Format.pp_print_bool (retrieved = Some value) true
23
+
24
+
(* Multiple TLV entries roundtrip *)
25
+
let test_tlv_multi_roundtrip entries =
26
+
let tlv =
27
+
List.fold_left
28
+
(fun acc (typ, value) -> Hap.Tlv.add typ value acc)
29
+
Hap.Tlv.empty entries
30
+
in
31
+
let encoded = Hap.Tlv.encode tlv in
32
+
let decoded = Hap.Tlv.decode encoded in
33
+
(* Check that all entries can be retrieved *)
34
+
List.iter
35
+
(fun (typ, value) ->
36
+
let retrieved = Hap.Tlv.get typ decoded in
37
+
check_eq ~pp:Format.pp_print_bool (retrieved = Some value) true)
38
+
entries
39
+
40
+
(* Category name should never crash *)
41
+
let test_category_name code =
42
+
let _ = Hap.category_name code in
43
+
check true
44
+
45
+
let () =
46
+
add_test ~name:"hap: TLV decode/encode no crash" [ bytes ]
47
+
test_tlv_decode_encode;
48
+
add_test ~name:"hap: TLV roundtrip" [ range 256; bytes ] test_tlv_roundtrip;
49
+
add_test ~name:"hap: TLV multi roundtrip"
50
+
[ list (pair (range 256) bytes) ]
51
+
test_tlv_multi_roundtrip;
52
+
add_test ~name:"hap: category_name no crash" [ int ] test_category_name
+50
hap.opam
+50
hap.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "HomeKit Accessory Protocol (HAP) for OCaml"
4
+
description: """
5
+
Implementation of the HomeKit Accessory Protocol for controlling HomeKit
6
+
accessories. Includes mDNS discovery, SRP-6a pair setup, Curve25519 pair
7
+
verify, and ChaCha20-Poly1305 encrypted sessions."""
8
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
9
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
10
+
license: "MIT"
11
+
homepage: "https://github.com/samoht/ocaml-hap"
12
+
bug-reports: "https://github.com/samoht/ocaml-hap/issues"
13
+
depends: [
14
+
"dune" {>= "3.0"}
15
+
"ocaml" {>= "4.14"}
16
+
"srp" {>= "0.1"}
17
+
"mdns" {>= "0.1"}
18
+
"kdf" {>= "0.1"}
19
+
"crypto" {>= "1.0.0"}
20
+
"crypto-ec" {>= "1.0.0"}
21
+
"crypto-rng" {>= "1.0.0"}
22
+
"digestif" {>= "1.2.0"}
23
+
"eio" {>= "1.0"}
24
+
"eio_main" {>= "1.0"}
25
+
"re" {>= "1.10"}
26
+
"jsont" {>= "0.1"}
27
+
"bytesrw" {>= "0.1"}
28
+
"base64" {>= "3.5"}
29
+
"logs" {>= "0.7"}
30
+
"fmt" {>= "0.9"}
31
+
"ipaddr" {>= "5.0"}
32
+
"domain-name" {>= "0.4"}
33
+
"alcotest" {with-test}
34
+
"crowbar" {with-test}
35
+
"odoc" {with-doc}
36
+
]
37
+
build: [
38
+
["dune" "subst"] {dev}
39
+
[
40
+
"dune"
41
+
"build"
42
+
"-p"
43
+
name
44
+
"-j"
45
+
jobs
46
+
"@install"
47
+
"@runtest" {with-test}
48
+
"@doc" {with-doc}
49
+
]
50
+
]
+20
lib/dune
+20
lib/dune
+1113
lib/hap.ml
+1113
lib/hap.ml
···
1
+
(** HomeKit Accessory Protocol (HAP) implementation.
2
+
3
+
This module implements the HAP protocol for controlling HomeKit accessories:
4
+
- Discovery via mDNS (_hap._tcp)
5
+
- Pair Setup using SRP-6a
6
+
- Pair Verify using Curve25519
7
+
- Encrypted sessions using ChaCha20-Poly1305 *)
8
+
9
+
let log_src = Logs.Src.create "hap"
10
+
11
+
module Log = (val Logs.src_log log_src : Logs.LOG)
12
+
open Result.Syntax
13
+
14
+
(* Helper to convert IP string to Eio address *)
15
+
let ipv4_of_string ip =
16
+
Eio.Net.Ipaddr.of_raw (Ipaddr.V4.to_octets (Ipaddr.V4.of_string_exn ip))
17
+
18
+
(* TLV encoding for HAP *)
19
+
module Tlv = struct
20
+
type t = (int * string) list
21
+
22
+
let empty = []
23
+
let add typ value tlv = (typ, value) :: tlv
24
+
25
+
let get typ tlv =
26
+
List.find_map (fun (t, v) -> if t = typ then Some v else None) tlv
27
+
28
+
let get_exn typ tlv =
29
+
match get typ tlv with
30
+
| Some v -> v
31
+
| None -> failwith (Printf.sprintf "TLV type %d not found" typ)
32
+
33
+
(* Encode TLV to bytes - values > 255 bytes are split *)
34
+
let encode tlv =
35
+
let buf = Buffer.create 256 in
36
+
List.iter
37
+
(fun (typ, value) ->
38
+
let len = String.length value in
39
+
let rec write_chunks offset =
40
+
if offset >= len then ()
41
+
else begin
42
+
let chunk_len = min 255 (len - offset) in
43
+
Buffer.add_char buf (Char.chr typ);
44
+
Buffer.add_char buf (Char.chr chunk_len);
45
+
Buffer.add_substring buf value offset chunk_len;
46
+
write_chunks (offset + chunk_len)
47
+
end
48
+
in
49
+
if len = 0 then begin
50
+
Buffer.add_char buf (Char.chr typ);
51
+
Buffer.add_char buf '\x00'
52
+
end
53
+
else write_chunks 0)
54
+
(List.rev tlv);
55
+
Buffer.contents buf
56
+
57
+
(* Decode TLV from bytes - concatenate split values *)
58
+
let decode data =
59
+
let len = String.length data in
60
+
let rec parse offset acc =
61
+
if offset >= len then List.rev acc
62
+
else if offset + 2 > len then failwith "Invalid TLV: truncated"
63
+
else begin
64
+
let typ = Char.code data.[offset] in
65
+
let vlen = Char.code data.[offset + 1] in
66
+
if offset + 2 + vlen > len then failwith "Invalid TLV: value truncated"
67
+
else begin
68
+
let value = String.sub data (offset + 2) vlen in
69
+
(* Concatenate with previous if same type *)
70
+
let acc =
71
+
match acc with
72
+
| (prev_typ, prev_val) :: rest when prev_typ = typ ->
73
+
(typ, prev_val ^ value) :: rest
74
+
| _ -> (typ, value) :: acc
75
+
in
76
+
parse (offset + 2 + vlen) acc
77
+
end
78
+
end
79
+
in
80
+
parse 0 []
81
+
end
82
+
83
+
(* TLV types for HAP *)
84
+
module TlvType = struct
85
+
let method_ = 0x00
86
+
let identifier = 0x01
87
+
let salt = 0x02
88
+
let public_key = 0x03
89
+
let proof = 0x04
90
+
let encrypted_data = 0x05
91
+
let state = 0x06
92
+
let error = 0x07
93
+
let retry_delay = 0x08
94
+
let certificate = 0x09
95
+
let signature = 0x0a
96
+
let permissions = 0x0b
97
+
let fragment_data = 0x0c
98
+
let fragment_last = 0x0d
99
+
let separator = 0xff
100
+
end
101
+
102
+
(* HAP errors *)
103
+
module HapError = struct
104
+
let unknown = 0x01
105
+
let authentication = 0x02
106
+
let backoff = 0x03
107
+
let max_peers = 0x04
108
+
let max_tries = 0x05
109
+
let unavailable = 0x06
110
+
let busy = 0x07
111
+
end
112
+
113
+
(* ChaCha20-Poly1305 encryption *)
114
+
let chacha20_poly1305_encrypt ~key ~nonce ~aad data =
115
+
let key = Crypto.Chacha20.of_secret key in
116
+
let encrypted =
117
+
Crypto.Chacha20.authenticate_encrypt ~key ~nonce ~adata:aad data
118
+
in
119
+
encrypted
120
+
121
+
let chacha20_poly1305_decrypt ~key ~nonce ~aad data =
122
+
let key = Crypto.Chacha20.of_secret key in
123
+
match Crypto.Chacha20.authenticate_decrypt ~key ~nonce ~adata:aad data with
124
+
| Some decrypted -> Ok decrypted
125
+
| None -> Error (`Msg "Decryption failed")
126
+
127
+
(* HKDF-SHA512 key derivation *)
128
+
let hkdf_sha512 ~salt ~ikm ~info ~length =
129
+
let prk = Hkdf.extract ~hash:`SHA512 ~salt ikm in
130
+
Hkdf.expand ~hash:`SHA512 ~prk ~info length
131
+
132
+
(* Ed25519 key pair *)
133
+
module Ed25519 = struct
134
+
type keypair = { secret : string; public : string }
135
+
136
+
let generate () =
137
+
let priv, pub = Crypto_ec.Ed25519.generate () in
138
+
{
139
+
secret = Crypto_ec.Ed25519.priv_to_octets priv;
140
+
public = Crypto_ec.Ed25519.pub_to_octets pub;
141
+
}
142
+
143
+
let sign ~secret data =
144
+
match Crypto_ec.Ed25519.priv_of_octets secret with
145
+
| Ok priv -> Crypto_ec.Ed25519.sign ~key:priv data
146
+
| Error _ -> failwith "Invalid Ed25519 private key"
147
+
148
+
let verify ~public ~signature data =
149
+
match Crypto_ec.Ed25519.pub_of_octets public with
150
+
| Ok pub -> Crypto_ec.Ed25519.verify ~key:pub signature ~msg:data
151
+
| Error _ -> false
152
+
end
153
+
154
+
(* X25519 key exchange *)
155
+
module X25519 = struct
156
+
type keypair = { secret : string; public : string }
157
+
158
+
let generate () =
159
+
let secret, public = Crypto_ec.X25519.gen_key () in
160
+
{ secret = Crypto_ec.X25519.secret_to_octets secret; public }
161
+
162
+
let shared_secret ~secret ~public =
163
+
match Crypto_ec.X25519.secret_of_octets secret with
164
+
| Ok (secret, _) -> (
165
+
match Crypto_ec.X25519.key_exchange secret public with
166
+
| Ok s -> Ok s
167
+
| Error _ -> Error (`Msg "X25519 key exchange failed"))
168
+
| Error _ -> Error (`Msg "Invalid X25519 secret key")
169
+
end
170
+
171
+
(* Controller pairing data *)
172
+
type pairing = {
173
+
accessory_id : string;
174
+
accessory_ltpk : string; (* Long-term public key *)
175
+
controller_id : string;
176
+
controller_ltsk : string; (* Long-term secret key *)
177
+
controller_ltpk : string; (* Long-term public key *)
178
+
}
179
+
180
+
(* Accessory info from discovery *)
181
+
type accessory_info = {
182
+
name : string;
183
+
device_id : string;
184
+
ip : string;
185
+
port : int;
186
+
model : string option;
187
+
config_num : int;
188
+
state_num : int;
189
+
category : int;
190
+
paired : bool;
191
+
}
192
+
193
+
(* HAP session state *)
194
+
type session = {
195
+
pairing : pairing;
196
+
ip : string;
197
+
port : int;
198
+
encrypt_key : string;
199
+
decrypt_key : string;
200
+
mutable encrypt_count : int64;
201
+
mutable decrypt_count : int64;
202
+
}
203
+
204
+
(* Encrypted frame for HAP sessions *)
205
+
let encrypt_frame session data =
206
+
let nonce = Bytes.create 12 in
207
+
Bytes.set_int64_le nonce 4 session.encrypt_count;
208
+
session.encrypt_count <- Int64.succ session.encrypt_count;
209
+
let len = String.length data in
210
+
let len_bytes = Bytes.create 2 in
211
+
Bytes.set_uint16_le len_bytes 0 len;
212
+
let aad = Bytes.to_string len_bytes in
213
+
let encrypted =
214
+
chacha20_poly1305_encrypt ~key:session.encrypt_key
215
+
~nonce:(Bytes.to_string nonce) ~aad data
216
+
in
217
+
aad ^ encrypted
218
+
219
+
let decrypt_frame session data =
220
+
if String.length data < 18 then Error (`Msg "Frame too short")
221
+
else begin
222
+
let len = Char.code data.[0] lor (Char.code data.[1] lsl 8) in
223
+
let encrypted = String.sub data 2 (String.length data - 2) in
224
+
if String.length encrypted < len + 16 then Error (`Msg "Frame truncated")
225
+
else begin
226
+
let nonce = Bytes.create 12 in
227
+
Bytes.set_int64_le nonce 4 session.decrypt_count;
228
+
session.decrypt_count <- Int64.succ session.decrypt_count;
229
+
let aad = String.sub data 0 2 in
230
+
chacha20_poly1305_decrypt ~key:session.decrypt_key
231
+
~nonce:(Bytes.to_string nonce) ~aad encrypted
232
+
end
233
+
end
234
+
235
+
(* HTTP helpers *)
236
+
let http_post ~net ~clock ~sw ~ip ~port ~path ~content_type:ct ~body =
237
+
let url = Fmt.str "http://%s:%d%s" ip port path in
238
+
let headers = Requests.Headers.(empty |> set_string "Content-Type" ct) in
239
+
let body = Requests.Body.of_string Requests.Mime.octet_stream body in
240
+
let timeout = Requests.Timeout.create ~connect:10.0 ~read:10.0 () in
241
+
let response =
242
+
Requests.One.post ~sw ~clock ~net ~headers ~body ~timeout ~verify_tls:false
243
+
url
244
+
in
245
+
Ok (Requests.Response.text response)
246
+
247
+
(* Pair Setup - M1 through M6 *)
248
+
let pair_setup ~net ~sw ~clock ~ip ~port ~pin =
249
+
Log.info (fun f -> f "Starting pair setup with %s:%d" ip port);
250
+
251
+
(* M1: Controller -> Accessory: Start Request *)
252
+
let m1 =
253
+
Tlv.(
254
+
empty |> add TlvType.state "\x01" |> add TlvType.method_ "\x00" |> encode)
255
+
in
256
+
let* m2_body =
257
+
http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup"
258
+
~content_type:"application/pairing+tlv8" ~body:m1
259
+
in
260
+
let m2 = Tlv.decode m2_body in
261
+
262
+
(* Check for error *)
263
+
match Tlv.get TlvType.error m2 with
264
+
| Some e ->
265
+
Error (`Msg (Printf.sprintf "Pair setup error: %d" (Char.code e.[0])))
266
+
| None -> (
267
+
(* M2: Accessory -> Controller: SRP Start Response *)
268
+
let salt = Tlv.get_exn TlvType.salt m2 in
269
+
let big_b_bytes = Tlv.get_exn TlvType.public_key m2 in
270
+
let big_b = Srp.z_of_bytes big_b_bytes in
271
+
272
+
Log.info (fun f ->
273
+
f "Received M2, salt=%d bytes, B=%d bytes" (String.length salt)
274
+
(String.length big_b_bytes));
275
+
276
+
(* Create SRP client with PIN as password *)
277
+
let username = "Pair-Setup" in
278
+
let srp_client = Srp.Client.create ~username ~password:pin in
279
+
let big_a = Srp.Client.public_key srp_client in
280
+
281
+
(* Compute session key *)
282
+
let* session_key =
283
+
Srp.Client.compute_session_key srp_client ~salt ~big_b
284
+
in
285
+
let m1_proof =
286
+
Srp.Client.compute_proof srp_client ~salt ~big_b ~session_key
287
+
in
288
+
289
+
(* M3: Controller -> Accessory: SRP Verify Request *)
290
+
let n_len = (Z.numbits Srp.n + 7) / 8 in
291
+
let m3 =
292
+
Tlv.(
293
+
empty |> add TlvType.state "\x03"
294
+
|> add TlvType.public_key (Srp.bytes_of_z ~pad:n_len big_a)
295
+
|> add TlvType.proof m1_proof |> encode)
296
+
in
297
+
let* m4_body =
298
+
http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup"
299
+
~content_type:"application/pairing+tlv8" ~body:m3
300
+
in
301
+
let m4 = Tlv.decode m4_body in
302
+
303
+
(* Check for error *)
304
+
match Tlv.get TlvType.error m4 with
305
+
| Some e ->
306
+
Error
307
+
(`Msg (Printf.sprintf "Pair setup M4 error: %d" (Char.code e.[0])))
308
+
| None ->
309
+
(* M4: Accessory -> Controller: SRP Verify Response *)
310
+
let m2_proof = Tlv.get_exn TlvType.proof m4 in
311
+
if
312
+
not
313
+
(Srp.Client.verify_proof srp_client ~m1:m1_proof ~m2:m2_proof
314
+
~session_key)
315
+
then Error (`Msg "Server proof verification failed")
316
+
else begin
317
+
Log.info (fun f -> f "SRP verification successful");
318
+
319
+
(* Derive encryption key for M5/M6 *)
320
+
let enc_salt = "Pair-Setup-Encrypt-Salt" in
321
+
let enc_info = "Pair-Setup-Encrypt-Info" in
322
+
let session_key_bytes = session_key in
323
+
let enc_key =
324
+
hkdf_sha512 ~salt:enc_salt ~ikm:session_key_bytes ~info:enc_info
325
+
~length:32
326
+
in
327
+
328
+
(* Generate controller's long-term Ed25519 key pair *)
329
+
let controller_kp = Ed25519.generate () in
330
+
let controller_id = "maison-controller" in
331
+
(* UUID would be better *)
332
+
333
+
(* Derive controller key for signing *)
334
+
let controller_salt = "Pair-Setup-Controller-Sign-Salt" in
335
+
let controller_info = "Pair-Setup-Controller-Sign-Info" in
336
+
let controller_x =
337
+
hkdf_sha512 ~salt:controller_salt ~ikm:session_key_bytes
338
+
~info:controller_info ~length:32
339
+
in
340
+
341
+
(* Sign: iOSDeviceX || iOSDevicePairingID || iOSDeviceLTPK *)
342
+
let sign_data =
343
+
controller_x ^ controller_id ^ controller_kp.public
344
+
in
345
+
let signature =
346
+
Ed25519.sign ~secret:controller_kp.secret sign_data
347
+
in
348
+
349
+
(* Build sub-TLV *)
350
+
let sub_tlv =
351
+
Tlv.(
352
+
empty
353
+
|> add TlvType.identifier controller_id
354
+
|> add TlvType.public_key controller_kp.public
355
+
|> add TlvType.signature signature
356
+
|> encode)
357
+
in
358
+
359
+
(* Encrypt sub-TLV *)
360
+
let nonce = "\x00\x00\x00\x00PS-Msg05" in
361
+
let encrypted =
362
+
chacha20_poly1305_encrypt ~key:enc_key ~nonce ~aad:"" sub_tlv
363
+
in
364
+
365
+
(* M5: Controller -> Accessory: Exchange Request *)
366
+
let m5 =
367
+
Tlv.(
368
+
empty |> add TlvType.state "\x05"
369
+
|> add TlvType.encrypted_data encrypted
370
+
|> encode)
371
+
in
372
+
let* m6_body =
373
+
http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup"
374
+
~content_type:"application/pairing+tlv8" ~body:m5
375
+
in
376
+
let m6 = Tlv.decode m6_body in
377
+
378
+
(* Check for error *)
379
+
match Tlv.get TlvType.error m6 with
380
+
| Some e ->
381
+
Error
382
+
(`Msg
383
+
(Printf.sprintf "Pair setup M6 error: %d"
384
+
(Char.code e.[0])))
385
+
| None ->
386
+
(* M6: Accessory -> Controller: Exchange Response *)
387
+
let enc_data = Tlv.get_exn TlvType.encrypted_data m6 in
388
+
let nonce = "\x00\x00\x00\x00PS-Msg06" in
389
+
let* decrypted =
390
+
chacha20_poly1305_decrypt ~key:enc_key ~nonce ~aad:"" enc_data
391
+
in
392
+
let sub_tlv = Tlv.decode decrypted in
393
+
394
+
let accessory_id = Tlv.get_exn TlvType.identifier sub_tlv in
395
+
let accessory_ltpk = Tlv.get_exn TlvType.public_key sub_tlv in
396
+
let accessory_sig = Tlv.get_exn TlvType.signature sub_tlv in
397
+
398
+
(* Verify accessory signature *)
399
+
let accessory_salt = "Pair-Setup-Accessory-Sign-Salt" in
400
+
let accessory_info = "Pair-Setup-Accessory-Sign-Info" in
401
+
let accessory_x =
402
+
hkdf_sha512 ~salt:accessory_salt ~ikm:session_key_bytes
403
+
~info:accessory_info ~length:32
404
+
in
405
+
let verify_data = accessory_x ^ accessory_id ^ accessory_ltpk in
406
+
407
+
if
408
+
not
409
+
(Ed25519.verify ~public:accessory_ltpk
410
+
~signature:accessory_sig verify_data)
411
+
then Error (`Msg "Accessory signature verification failed")
412
+
else begin
413
+
Log.info (fun f ->
414
+
f "Pair setup complete! Accessory ID: %s" accessory_id);
415
+
Ok
416
+
{
417
+
accessory_id;
418
+
accessory_ltpk;
419
+
controller_id;
420
+
controller_ltsk = controller_kp.secret;
421
+
controller_ltpk = controller_kp.public;
422
+
}
423
+
end
424
+
end)
425
+
426
+
(* Pair Verify - establish encrypted session *)
427
+
let pair_verify ~net ~sw ~clock ~ip ~port ~pairing =
428
+
Log.info (fun f -> f "Starting pair verify with %s:%d" ip port);
429
+
430
+
(* Generate ephemeral X25519 key pair *)
431
+
let kp = X25519.generate () in
432
+
433
+
(* M1: Controller -> Accessory *)
434
+
let m1 =
435
+
Tlv.(
436
+
empty |> add TlvType.state "\x01"
437
+
|> add TlvType.public_key kp.public
438
+
|> encode)
439
+
in
440
+
let* m2_body =
441
+
http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-verify"
442
+
~content_type:"application/pairing+tlv8" ~body:m1
443
+
in
444
+
let m2 = Tlv.decode m2_body in
445
+
446
+
(* Check for error *)
447
+
match Tlv.get TlvType.error m2 with
448
+
| Some e ->
449
+
Error (`Msg (Printf.sprintf "Pair verify M2 error: %d" (Char.code e.[0])))
450
+
| None ->
451
+
(* M2: Accessory -> Controller *)
452
+
let accessory_pk = Tlv.get_exn TlvType.public_key m2 in
453
+
let enc_data = Tlv.get_exn TlvType.encrypted_data m2 in
454
+
455
+
(* Compute shared secret *)
456
+
let* shared =
457
+
X25519.shared_secret ~secret:kp.secret ~public:accessory_pk
458
+
in
459
+
460
+
(* Derive encryption key *)
461
+
let enc_key =
462
+
hkdf_sha512 ~salt:"Pair-Verify-Encrypt-Salt" ~ikm:shared
463
+
~info:"Pair-Verify-Encrypt-Info" ~length:32
464
+
in
465
+
466
+
(* Decrypt accessory's sub-TLV *)
467
+
let nonce = "\x00\x00\x00\x00PV-Msg02" in
468
+
let* decrypted =
469
+
chacha20_poly1305_decrypt ~key:enc_key ~nonce ~aad:"" enc_data
470
+
in
471
+
let sub_tlv = Tlv.decode decrypted in
472
+
473
+
let accessory_id = Tlv.get_exn TlvType.identifier sub_tlv in
474
+
let accessory_sig = Tlv.get_exn TlvType.signature sub_tlv in
475
+
476
+
(* Verify it's the accessory we paired with *)
477
+
if accessory_id <> pairing.accessory_id then
478
+
Error (`Msg "Accessory ID mismatch")
479
+
else begin
480
+
(* Verify accessory signature *)
481
+
let verify_data = accessory_pk ^ accessory_id ^ kp.public in
482
+
if
483
+
not
484
+
(Ed25519.verify ~public:pairing.accessory_ltpk
485
+
~signature:accessory_sig verify_data)
486
+
then Error (`Msg "Accessory signature verification failed")
487
+
else begin
488
+
(* Sign our response *)
489
+
let sign_data = kp.public ^ pairing.controller_id ^ accessory_pk in
490
+
let signature =
491
+
Ed25519.sign ~secret:pairing.controller_ltsk sign_data
492
+
in
493
+
494
+
(* Build and encrypt sub-TLV *)
495
+
let sub_tlv =
496
+
Tlv.(
497
+
empty
498
+
|> add TlvType.identifier pairing.controller_id
499
+
|> add TlvType.signature signature
500
+
|> encode)
501
+
in
502
+
let nonce = "\x00\x00\x00\x00PV-Msg03" in
503
+
let encrypted =
504
+
chacha20_poly1305_encrypt ~key:enc_key ~nonce ~aad:"" sub_tlv
505
+
in
506
+
507
+
(* M3: Controller -> Accessory *)
508
+
let m3 =
509
+
Tlv.(
510
+
empty |> add TlvType.state "\x03"
511
+
|> add TlvType.encrypted_data encrypted
512
+
|> encode)
513
+
in
514
+
let* m4_body =
515
+
http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-verify"
516
+
~content_type:"application/pairing+tlv8" ~body:m3
517
+
in
518
+
let m4 = Tlv.decode m4_body in
519
+
520
+
(* Check for error *)
521
+
match Tlv.get TlvType.error m4 with
522
+
| Some e ->
523
+
Error
524
+
(`Msg
525
+
(Printf.sprintf "Pair verify M4 error: %d" (Char.code e.[0])))
526
+
| None ->
527
+
(* Derive session keys *)
528
+
let enc_key =
529
+
hkdf_sha512 ~salt:"Control-Salt" ~ikm:shared
530
+
~info:"Control-Write-Encryption-Key" ~length:32
531
+
in
532
+
let dec_key =
533
+
hkdf_sha512 ~salt:"Control-Salt" ~ikm:shared
534
+
~info:"Control-Read-Encryption-Key" ~length:32
535
+
in
536
+
537
+
Log.info (fun f ->
538
+
f "Pair verify successful, session established");
539
+
Ok
540
+
{
541
+
pairing;
542
+
ip;
543
+
port;
544
+
encrypt_key = enc_key;
545
+
decrypt_key = dec_key;
546
+
encrypt_count = 0L;
547
+
decrypt_count = 0L;
548
+
}
549
+
end
550
+
end
551
+
552
+
(* Get accessories from a session *)
553
+
let get_accessories ~net ~sw session =
554
+
let path = "/accessories" in
555
+
let request =
556
+
Printf.sprintf "GET %s HTTP/1.1\r\nHost: %s:%d\r\n\r\n" path session.ip
557
+
session.port
558
+
in
559
+
let encrypted = encrypt_frame session request in
560
+
561
+
let addr = `Tcp (ipv4_of_string session.ip, session.port) in
562
+
let flow = Eio.Net.connect ~sw net addr in
563
+
Eio.Flow.copy_string encrypted flow;
564
+
565
+
let buf = Buffer.create 4096 in
566
+
let rec read () =
567
+
let chunk = Cstruct.create 1024 in
568
+
match Eio.Flow.single_read flow chunk with
569
+
| n ->
570
+
Buffer.add_string buf (Cstruct.to_string (Cstruct.sub chunk 0 n));
571
+
read ()
572
+
| exception End_of_file -> ()
573
+
in
574
+
read ();
575
+
Eio.Flow.close flow;
576
+
577
+
let* decrypted = decrypt_frame session (Buffer.contents buf) in
578
+
(* Parse HTTP response to get JSON body *)
579
+
match Re.(exec_opt (compile (str "\r\n\r\n")) decrypted) with
580
+
| None -> Error (`Msg "Invalid response")
581
+
| Some g -> (
582
+
let pos = Re.Group.stop g 0 in
583
+
let body = String.sub decrypted pos (String.length decrypted - pos) in
584
+
match Jsont_bytesrw.decode_string Jsont.json body with
585
+
| Ok json -> Ok json
586
+
| Error e -> Error (`Msg e))
587
+
588
+
(* Characteristic write request codec *)
589
+
type char_write = { cw_aid : int; cw_iid : int; cw_value : Jsont.json }
590
+
591
+
let char_write_codec =
592
+
Jsont.Object.map ~kind:"char_write" (fun aid iid value ->
593
+
{ cw_aid = aid; cw_iid = iid; cw_value = value })
594
+
|> Jsont.Object.mem "aid" Jsont.int ~enc:(fun c -> c.cw_aid)
595
+
|> Jsont.Object.mem "iid" Jsont.int ~enc:(fun c -> c.cw_iid)
596
+
|> Jsont.Object.mem "value" Jsont.json ~enc:(fun c -> c.cw_value)
597
+
|> Jsont.Object.finish
598
+
599
+
type char_write_request = { characteristics : char_write list }
600
+
601
+
let char_write_request_codec =
602
+
Jsont.Object.map ~kind:"char_write_request" (fun characteristics ->
603
+
{ characteristics })
604
+
|> Jsont.Object.mem "characteristics" (Jsont.list char_write_codec)
605
+
~enc:(fun r -> r.characteristics)
606
+
|> Jsont.Object.finish
607
+
608
+
(* Write a characteristic *)
609
+
let put_characteristic ~net ~sw session ~aid ~iid value =
610
+
let req =
611
+
{ characteristics = [ { cw_aid = aid; cw_iid = iid; cw_value = value } ] }
612
+
in
613
+
let body =
614
+
match Jsont_bytesrw.encode_string char_write_request_codec req with
615
+
| Ok s -> s
616
+
| Error _ -> "{}"
617
+
in
618
+
let path = "/characteristics" in
619
+
let request =
620
+
Printf.sprintf
621
+
"PUT %s HTTP/1.1\r\n\
622
+
Host: %s:%d\r\n\
623
+
Content-Type: application/hap+json\r\n\
624
+
Content-Length: %d\r\n\
625
+
\r\n\
626
+
%s"
627
+
path session.ip session.port (String.length body) body
628
+
in
629
+
let encrypted = encrypt_frame session request in
630
+
631
+
let addr = `Tcp (ipv4_of_string session.ip, session.port) in
632
+
let flow = Eio.Net.connect ~sw net addr in
633
+
Eio.Flow.copy_string encrypted flow;
634
+
635
+
let buf = Buffer.create 4096 in
636
+
let rec read () =
637
+
let chunk = Cstruct.create 1024 in
638
+
match Eio.Flow.single_read flow chunk with
639
+
| n ->
640
+
Buffer.add_string buf (Cstruct.to_string (Cstruct.sub chunk 0 n));
641
+
read ()
642
+
| exception End_of_file -> ()
643
+
in
644
+
read ();
645
+
Eio.Flow.close flow;
646
+
647
+
let* _decrypted = decrypt_frame session (Buffer.contents buf) in
648
+
Ok ()
649
+
650
+
(* Read characteristics *)
651
+
let get_characteristics ~net ~sw session ~ids =
652
+
let ids_str =
653
+
String.concat ","
654
+
(List.map (fun (aid, iid) -> Printf.sprintf "%d.%d" aid iid) ids)
655
+
in
656
+
let path = Printf.sprintf "/characteristics?id=%s" ids_str in
657
+
let request =
658
+
Printf.sprintf "GET %s HTTP/1.1\r\nHost: %s:%d\r\n\r\n" path session.ip
659
+
session.port
660
+
in
661
+
let encrypted = encrypt_frame session request in
662
+
663
+
let addr = `Tcp (ipv4_of_string session.ip, session.port) in
664
+
let flow = Eio.Net.connect ~sw net addr in
665
+
Eio.Flow.copy_string encrypted flow;
666
+
667
+
let buf = Buffer.create 4096 in
668
+
let rec read () =
669
+
let chunk = Cstruct.create 1024 in
670
+
match Eio.Flow.single_read flow chunk with
671
+
| n ->
672
+
Buffer.add_string buf (Cstruct.to_string (Cstruct.sub chunk 0 n));
673
+
read ()
674
+
| exception End_of_file -> ()
675
+
in
676
+
read ();
677
+
Eio.Flow.close flow;
678
+
679
+
let* decrypted = decrypt_frame session (Buffer.contents buf) in
680
+
match Re.(exec_opt (compile (str "\r\n\r\n")) decrypted) with
681
+
| None -> Error (`Msg "Invalid response")
682
+
| Some g -> (
683
+
let pos = Re.Group.stop g 0 in
684
+
let body = String.sub decrypted pos (String.length decrypted - pos) in
685
+
match Jsont_bytesrw.decode_string Jsont.json body with
686
+
| Ok json -> Ok json
687
+
| Error e -> Error (`Msg e))
688
+
689
+
(* Pairing storage directory *)
690
+
let pairings_dir = ".hap/pairings"
691
+
692
+
let ensure_pairings_dir ~fs =
693
+
let hap_path = Eio.Path.(fs / ".hap") in
694
+
let pairings_path = Eio.Path.(fs / pairings_dir) in
695
+
(try Eio.Path.mkdir ~perm:0o700 hap_path with Eio.Exn.Io _ -> ());
696
+
try Eio.Path.mkdir ~perm:0o700 pairings_path with Eio.Exn.Io _ -> ()
697
+
698
+
(* Sanitize device_id for filename (replace colons with dashes) *)
699
+
let sanitize_id id = String.map (fun c -> if c = ':' then '-' else c) id
700
+
701
+
let pairing_path_for_id device_id =
702
+
Fmt.str "%s/hap-%s.json" pairings_dir (sanitize_id device_id)
703
+
704
+
(** Jsont codec for pairing storage *)
705
+
module Pairing_json = struct
706
+
type stored = {
707
+
accessory_id : string;
708
+
accessory_ltpk : string; (* Base64-encoded *)
709
+
controller_id : string;
710
+
controller_ltsk : string; (* Base64-encoded *)
711
+
controller_ltpk : string; (* Base64-encoded *)
712
+
}
713
+
714
+
let stored =
715
+
Jsont.Object.map ~kind:"hap.pairing"
716
+
(fun
717
+
accessory_id
718
+
accessory_ltpk
719
+
controller_id
720
+
controller_ltsk
721
+
controller_ltpk
722
+
->
723
+
{
724
+
accessory_id;
725
+
accessory_ltpk;
726
+
controller_id;
727
+
controller_ltsk;
728
+
controller_ltpk;
729
+
})
730
+
|> Jsont.Object.mem "accessory_id" Jsont.string ~enc:(fun p ->
731
+
p.accessory_id)
732
+
|> Jsont.Object.mem "accessory_ltpk" Jsont.string ~enc:(fun p ->
733
+
p.accessory_ltpk)
734
+
|> Jsont.Object.mem "controller_id" Jsont.string ~enc:(fun p ->
735
+
p.controller_id)
736
+
|> Jsont.Object.mem "controller_ltsk" Jsont.string ~enc:(fun p ->
737
+
p.controller_ltsk)
738
+
|> Jsont.Object.mem "controller_ltpk" Jsont.string ~enc:(fun p ->
739
+
p.controller_ltpk)
740
+
|> Jsont.Object.finish
741
+
742
+
let of_pairing (p : pairing) : stored =
743
+
{
744
+
accessory_id = p.accessory_id;
745
+
accessory_ltpk = Base64.encode_string p.accessory_ltpk;
746
+
controller_id = p.controller_id;
747
+
controller_ltsk = Base64.encode_string p.controller_ltsk;
748
+
controller_ltpk = Base64.encode_string p.controller_ltpk;
749
+
}
750
+
751
+
let to_pairing (s : stored) : pairing =
752
+
{
753
+
accessory_id = s.accessory_id;
754
+
accessory_ltpk = Base64.decode_exn s.accessory_ltpk;
755
+
controller_id = s.controller_id;
756
+
controller_ltsk = Base64.decode_exn s.controller_ltsk;
757
+
controller_ltpk = Base64.decode_exn s.controller_ltpk;
758
+
}
759
+
end
760
+
761
+
(* Save/load pairing to file *)
762
+
let save_pairing ~fs ~path (pairing : pairing) =
763
+
let stored = Pairing_json.of_pairing pairing in
764
+
match
765
+
Jsont_bytesrw.encode_string ~format:Jsont.Indent Pairing_json.stored stored
766
+
with
767
+
| Ok json ->
768
+
Eio.Path.save ~create:(`Or_truncate 0o600) Eio.Path.(fs / path) json
769
+
| Error _ -> ()
770
+
771
+
let load_pairing ~fs ~path =
772
+
let full_path = Eio.Path.(fs / path) in
773
+
if not (Eio.Path.is_file full_path) then None
774
+
else begin
775
+
try
776
+
let content = Eio.Path.load full_path in
777
+
match Jsont_bytesrw.decode_string Pairing_json.stored content with
778
+
| Ok stored -> Some (Pairing_json.to_pairing stored)
779
+
| Error _ -> None
780
+
with _ -> None
781
+
end
782
+
783
+
(* Save pairing by device_id *)
784
+
let save_pairing_by_id ~fs pairing =
785
+
ensure_pairings_dir ~fs;
786
+
let path = pairing_path_for_id pairing.accessory_id in
787
+
save_pairing ~fs ~path pairing;
788
+
path
789
+
790
+
(* Find pairing for a device by its HAP device_id *)
791
+
let find_pairing_by_id ~fs device_id =
792
+
let path = pairing_path_for_id device_id in
793
+
load_pairing ~fs ~path
794
+
795
+
(* HAP category codes *)
796
+
let category_name = function
797
+
| 1 -> "Other"
798
+
| 2 -> "Bridge"
799
+
| 3 -> "Fan"
800
+
| 4 -> "Garage Door Opener"
801
+
| 5 -> "Lightbulb"
802
+
| 6 -> "Door Lock"
803
+
| 7 -> "Outlet"
804
+
| 8 -> "Switch"
805
+
| 9 -> "Thermostat"
806
+
| 10 -> "Sensor"
807
+
| 11 -> "Security System"
808
+
| 12 -> "Door"
809
+
| 13 -> "Window"
810
+
| 14 -> "Window Covering"
811
+
| 15 -> "Programmable Switch"
812
+
| 16 -> "Range Extender"
813
+
| 17 -> "IP Camera"
814
+
| 18 -> "Video Doorbell"
815
+
| 19 -> "Air Purifier"
816
+
| 20 -> "Heater"
817
+
| 21 -> "Air Conditioner"
818
+
| 22 -> "Humidifier"
819
+
| 23 -> "Dehumidifier"
820
+
| 24 -> "Apple TV"
821
+
| 25 -> "HomePod"
822
+
| 26 -> "Speaker"
823
+
| 27 -> "AirPort"
824
+
| 28 -> "Sprinkler"
825
+
| 29 -> "Faucet"
826
+
| 30 -> "Shower Head"
827
+
| 31 -> "Television"
828
+
| 32 -> "Target Controller"
829
+
| 33 -> "WiFi Router"
830
+
| 34 -> "Audio Receiver"
831
+
| 35 -> "TV Set Top Box"
832
+
| 36 -> "TV Streaming Stick"
833
+
| _ -> "Unknown"
834
+
835
+
(* Parse HAP TXT record *)
836
+
let parse_hap_txt txt =
837
+
(* TXT record contains key=value pairs *)
838
+
let pairs = String.split_on_char ' ' txt in
839
+
let find key =
840
+
List.find_map
841
+
(fun p ->
842
+
match String.split_on_char '=' p with
843
+
| [ k; v ] when k = key -> Some v
844
+
| _ -> None)
845
+
pairs
846
+
in
847
+
let device_id = find "id" in
848
+
let model = find "md" in
849
+
let config_num = Option.bind (find "c#") (fun s -> int_of_string_opt s) in
850
+
let state_num = Option.bind (find "s#") (fun s -> int_of_string_opt s) in
851
+
let category = Option.bind (find "ci") (fun s -> int_of_string_opt s) in
852
+
let status_flags = Option.bind (find "sf") (fun s -> int_of_string_opt s) in
853
+
let paired = match status_flags with Some 0 -> true | _ -> false in
854
+
(device_id, model, config_num, state_num, category, paired)
855
+
856
+
(* Discover HAP devices using mDNS *)
857
+
let discover ~sw ~net ~clock ?(timeout = 3.0) () =
858
+
let service_name = Domain_name.of_string_exn "_hap._tcp.local" in
859
+
let r = Mdns.merge (Mdns.query ~sw ~net ~clock ~timeout service_name) in
860
+
(* Get unique service instances from PTR records *)
861
+
let instances =
862
+
List.filter_map
863
+
(fun (service, instance) ->
864
+
if Domain_name.equal service service_name then Some instance else None)
865
+
r.ptrs
866
+
|> List.sort_uniq Domain_name.compare
867
+
in
868
+
(* Build device info for each instance *)
869
+
List.filter_map
870
+
(fun instance ->
871
+
match
872
+
List.find_opt (fun (n, _, _) -> Domain_name.equal n instance) r.srvs
873
+
with
874
+
| None -> None
875
+
| Some (_, port, target) ->
876
+
let txt =
877
+
List.find_map
878
+
(fun (n, t) ->
879
+
if Domain_name.equal n instance then Some t else None)
880
+
r.txts
881
+
|> Option.value ~default:[] |> String.concat " "
882
+
in
883
+
let ip =
884
+
List.find_map
885
+
(fun (n, ip) ->
886
+
if Domain_name.equal n target then Some (Ipaddr.V4.to_string ip)
887
+
else None)
888
+
r.addrs
889
+
|> Option.value ~default:(Domain_name.to_string target)
890
+
in
891
+
let device_id, model, config_num, state_num, category, paired =
892
+
parse_hap_txt txt
893
+
in
894
+
let name =
895
+
match Domain_name.get_label instance 0 with
896
+
| Ok label -> label
897
+
| Error _ -> Domain_name.to_string instance
898
+
in
899
+
Some
900
+
{
901
+
name;
902
+
device_id = Option.value ~default:"" device_id;
903
+
ip;
904
+
port;
905
+
model;
906
+
config_num = Option.value ~default:0 config_num;
907
+
state_num = Option.value ~default:0 state_num;
908
+
category = Option.value ~default:0 category;
909
+
paired;
910
+
})
911
+
instances
912
+
913
+
(* Find pairing for an IP by discovering the device first *)
914
+
let find_pairing_for_ip ~sw ~net ~clock ~fs ip =
915
+
let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
916
+
match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with
917
+
| None -> None
918
+
| Some info ->
919
+
if info.device_id = "" then None
920
+
else find_pairing_by_id ~fs info.device_id
921
+
922
+
(* Get accessory info for an IP *)
923
+
let get_accessory_info ~sw ~net ~clock ip =
924
+
let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
925
+
List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices
926
+
927
+
(* Pretty print accessory info *)
928
+
let pp_accessory_info ppf info =
929
+
let cat = category_name info.category in
930
+
let status = if info.paired then "paired" else "unpaired" in
931
+
Fmt.pf ppf "@[<v 0>%s@," info.name;
932
+
Fmt.pf ppf " Type: %s@," cat;
933
+
Fmt.pf ppf " Device ID: %s@," info.device_id;
934
+
Fmt.pf ppf " Address: %s:%d@," info.ip info.port;
935
+
Option.iter (fun m -> Fmt.pf ppf " Model: %s@," m) info.model;
936
+
Fmt.pf ppf " Status: %s@," status;
937
+
Fmt.pf ppf " Config: #%d, State: #%d@]" info.config_num info.state_num
938
+
939
+
(** {1 HAP JSON Codecs} *)
940
+
941
+
module Hap_json = struct
942
+
type characteristic = { iid : int; type_ : string; value : Jsont.json option }
943
+
(** HAP characteristic *)
944
+
945
+
let characteristic =
946
+
Jsont.Object.map ~kind:"hap.characteristic" (fun iid type_ value ->
947
+
{ iid; type_; value })
948
+
|> Jsont.Object.mem "iid" Jsont.int ~enc:(fun c -> c.iid)
949
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun c -> c.type_)
950
+
|> Jsont.Object.opt_mem "value" Jsont.json ~enc:(fun c -> c.value)
951
+
|> Jsont.Object.finish
952
+
953
+
type service = {
954
+
iid : int;
955
+
type_ : string;
956
+
characteristics : characteristic list;
957
+
}
958
+
(** HAP service *)
959
+
960
+
let service =
961
+
Jsont.Object.map ~kind:"hap.service" (fun iid type_ characteristics ->
962
+
{ iid; type_; characteristics })
963
+
|> Jsont.Object.mem "iid" Jsont.int ~enc:(fun s -> s.iid)
964
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun s -> s.type_)
965
+
|> Jsont.Object.mem "characteristics" (Jsont.list characteristic)
966
+
~enc:(fun s -> s.characteristics)
967
+
|> Jsont.Object.finish
968
+
969
+
type accessory = { aid : int; services : service list }
970
+
(** HAP accessory *)
971
+
972
+
let accessory =
973
+
Jsont.Object.map ~kind:"hap.accessory" (fun aid services ->
974
+
{ aid; services })
975
+
|> Jsont.Object.mem "aid" Jsont.int ~enc:(fun a -> a.aid)
976
+
|> Jsont.Object.mem "services" (Jsont.list service) ~enc:(fun a ->
977
+
a.services)
978
+
|> Jsont.Object.finish
979
+
980
+
type accessories_response = { accessories : accessory list }
981
+
(** HAP accessories response *)
982
+
983
+
let accessories_response =
984
+
Jsont.Object.map ~kind:"hap.accessories_response" (fun accessories ->
985
+
{ accessories })
986
+
|> Jsont.Object.mem "accessories" (Jsont.list accessory) ~enc:(fun r ->
987
+
r.accessories)
988
+
|> Jsont.Object.finish
989
+
990
+
type char_value = { aid : int; iid : int; value : Jsont.json option }
991
+
(** HAP characteristics value *)
992
+
993
+
let char_value =
994
+
Jsont.Object.map ~kind:"hap.char_value" (fun aid iid value ->
995
+
{ aid; iid; value })
996
+
|> Jsont.Object.mem "aid" Jsont.int ~enc:(fun c -> c.aid)
997
+
|> Jsont.Object.mem "iid" Jsont.int ~enc:(fun c -> c.iid)
998
+
|> Jsont.Object.opt_mem "value" Jsont.json ~enc:(fun c -> c.value)
999
+
|> Jsont.Object.finish
1000
+
1001
+
type characteristics_response = { characteristics : char_value list }
1002
+
1003
+
let characteristics_response =
1004
+
Jsont.Object.map ~kind:"hap.characteristics_response"
1005
+
(fun characteristics -> { characteristics })
1006
+
|> Jsont.Object.mem "characteristics" (Jsont.list char_value) ~enc:(fun r ->
1007
+
r.characteristics)
1008
+
|> Jsont.Object.finish
1009
+
end
1010
+
1011
+
(** {1 High-level control} *)
1012
+
1013
+
(* HAP characteristic type UUIDs (short form) *)
1014
+
module CharType = struct
1015
+
let on = "25" (* 00000025-0000-1000-8000-0026BB765291 *)
1016
+
end
1017
+
1018
+
(* Decode Jsont.json via codec *)
1019
+
let decode codec json =
1020
+
match Jsont_bytesrw.encode_string Jsont.json json with
1021
+
| Error e -> Error e
1022
+
| Ok str -> (
1023
+
match Jsont_bytesrw.decode_string codec str with
1024
+
| Ok v -> Ok v
1025
+
| Error e -> Error e)
1026
+
1027
+
(* Find the On characteristic IID from accessories JSON *)
1028
+
let find_on_characteristic_iid json =
1029
+
match decode Hap_json.accessories_response json with
1030
+
| Error _ -> None
1031
+
| Ok resp ->
1032
+
List.find_map
1033
+
(fun (acc : Hap_json.accessory) ->
1034
+
List.find_map
1035
+
(fun (svc : Hap_json.service) ->
1036
+
List.find_map
1037
+
(fun (chr : Hap_json.characteristic) ->
1038
+
if String.lowercase_ascii chr.type_ = CharType.on then
1039
+
Some (acc.aid, chr.iid)
1040
+
else None)
1041
+
svc.characteristics)
1042
+
acc.services)
1043
+
resp.accessories
1044
+
1045
+
(* Control an accessory by IP - establishes session, finds characteristic, sets value *)
1046
+
let control_outlet ~net ~sw ~clock ~fs ~ip ~value =
1047
+
(* 1. Discover to get device info *)
1048
+
let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
1049
+
match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with
1050
+
| None -> Error (`Msg "Device not found via HAP discovery")
1051
+
| Some info -> (
1052
+
if info.device_id = "" then Error (`Msg "Device has no device_id")
1053
+
else
1054
+
(* 2. Find pairing *)
1055
+
match find_pairing_by_id ~fs info.device_id with
1056
+
| None ->
1057
+
Error (`Msg "No pairing found for device - run 'plug pair' first")
1058
+
| Some pairing -> (
1059
+
(* 3. Establish session *)
1060
+
let* session =
1061
+
pair_verify ~net ~sw ~clock ~ip ~port:info.port ~pairing
1062
+
in
1063
+
(* 4. Get accessories to find On characteristic *)
1064
+
let* accessories_json = get_accessories ~net ~sw session in
1065
+
match find_on_characteristic_iid accessories_json with
1066
+
| None -> Error (`Msg "Could not find On characteristic")
1067
+
| Some (aid, iid) ->
1068
+
(* 5. Set value *)
1069
+
put_characteristic ~net ~sw session ~aid ~iid
1070
+
(Jsont.Bool (value, Jsont.Meta.none))))
1071
+
1072
+
let turn_on_outlet ~net ~sw ~clock ~fs ip =
1073
+
control_outlet ~net ~sw ~clock ~fs ~ip ~value:true
1074
+
1075
+
let turn_off_outlet ~net ~sw ~clock ~fs ip =
1076
+
control_outlet ~net ~sw ~clock ~fs ~ip ~value:false
1077
+
1078
+
(* Extract bool value from characteristics response *)
1079
+
let get_bool_value json =
1080
+
match decode Hap_json.characteristics_response json with
1081
+
| Error _ -> None
1082
+
| Ok (resp : Hap_json.characteristics_response) -> (
1083
+
match resp.characteristics with
1084
+
| [ (c : Hap_json.char_value) ] -> (
1085
+
match c.value with Some (Jsont.Bool (b, _)) -> Some b | _ -> None)
1086
+
| _ -> None)
1087
+
1088
+
let toggle_outlet ~net ~sw ~clock ~fs ip =
1089
+
(* For toggle, we need to read current state first *)
1090
+
let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
1091
+
match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with
1092
+
| None -> Error (`Msg "Device not found via HAP discovery")
1093
+
| Some info -> (
1094
+
if info.device_id = "" then Error (`Msg "Device has no device_id")
1095
+
else
1096
+
match find_pairing_by_id ~fs info.device_id with
1097
+
| None -> Error (`Msg "No pairing found for device")
1098
+
| Some pairing -> (
1099
+
let* session =
1100
+
pair_verify ~net ~sw ~clock ~ip ~port:info.port ~pairing
1101
+
in
1102
+
let* accessories_json = get_accessories ~net ~sw session in
1103
+
match find_on_characteristic_iid accessories_json with
1104
+
| None -> Error (`Msg "Could not find On characteristic")
1105
+
| Some (aid, iid) -> (
1106
+
let* chars_json =
1107
+
get_characteristics ~net ~sw session ~ids:[ (aid, iid) ]
1108
+
in
1109
+
match get_bool_value chars_json with
1110
+
| None -> Error (`Msg "Could not read current state")
1111
+
| Some v ->
1112
+
put_characteristic ~net ~sw session ~aid ~iid
1113
+
(Jsont.Bool (not v, Jsont.Meta.none)))))
+226
lib/hap.mli
+226
lib/hap.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HomeKit Accessory Protocol (HAP).
7
+
8
+
This module implements the HAP protocol for controlling HomeKit accessories:
9
+
- Discovery via mDNS ({!discover})
10
+
- Pair Setup using SRP-6a ({!pair_setup})
11
+
- Pair Verify using Curve25519 ({!pair_verify})
12
+
- Encrypted sessions using ChaCha20-Poly1305
13
+
14
+
{2 Protocol Overview}
15
+
16
+
1. {b Discovery}: Find HomeKit accessories via mDNS (_hap._tcp.local) 2.
17
+
{b Pair Setup}: One-time pairing using the accessory's PIN code 3.
18
+
{b Pair Verify}: Establish encrypted session using stored pairing 4.
19
+
{b Control}: Read/write characteristics over encrypted session
20
+
21
+
{2 References}
22
+
- {{:https://developer.apple.com/homekit/} Apple HomeKit}
23
+
- HAP Non-Commercial Specification *)
24
+
25
+
(** {1 Types} *)
26
+
27
+
type pairing = {
28
+
accessory_id : string; (** Accessory device ID *)
29
+
accessory_ltpk : string; (** Accessory long-term public key (Ed25519) *)
30
+
controller_id : string; (** Controller identifier *)
31
+
controller_ltsk : string; (** Controller long-term secret key (Ed25519) *)
32
+
controller_ltpk : string; (** Controller long-term public key (Ed25519) *)
33
+
}
34
+
(** Controller pairing data. Stored after successful pair setup. *)
35
+
36
+
type accessory_info = {
37
+
name : string; (** Display name *)
38
+
device_id : string; (** HAP device ID (MAC address format) *)
39
+
ip : string; (** IPv4 address *)
40
+
port : int; (** TCP port *)
41
+
model : string option; (** Model identifier *)
42
+
config_num : int; (** Configuration number *)
43
+
state_num : int; (** State number *)
44
+
category : int; (** HAP category code *)
45
+
paired : bool; (** Whether accessory is paired *)
46
+
}
47
+
(** Accessory info from mDNS discovery. *)
48
+
49
+
type session
50
+
(** Encrypted HAP session. *)
51
+
52
+
(** {1 Discovery} *)
53
+
54
+
val discover :
55
+
sw:Eio.Switch.t ->
56
+
net:_ Eio.Net.t ->
57
+
clock:_ Eio.Time.clock ->
58
+
?timeout:float ->
59
+
unit ->
60
+
accessory_info list
61
+
(** [discover ~sw ~net ~clock ?timeout ()] finds HomeKit accessories on the
62
+
local network using mDNS. Default timeout is 3 seconds. *)
63
+
64
+
val get_accessory_info :
65
+
sw:Eio.Switch.t ->
66
+
net:_ Eio.Net.t ->
67
+
clock:_ Eio.Time.clock ->
68
+
string ->
69
+
accessory_info option
70
+
(** [get_accessory_info ~sw ~net ~clock ip] returns info for a specific IP. *)
71
+
72
+
val category_name : int -> string
73
+
(** [category_name code] returns the human-readable name for a HAP category. *)
74
+
75
+
val pp_accessory_info : accessory_info Fmt.t
76
+
(** Pretty-printer for accessory info. *)
77
+
78
+
(** {1 Pairing} *)
79
+
80
+
val pair_setup :
81
+
net:_ Eio.Net.t ->
82
+
sw:Eio.Switch.t ->
83
+
clock:_ Eio.Time.clock ->
84
+
ip:string ->
85
+
port:int ->
86
+
pin:string ->
87
+
(pairing, [ `Msg of string ]) result
88
+
(** [pair_setup ~net ~sw ~clock ~ip ~port ~pin] performs HAP pair setup with an
89
+
accessory using its PIN code. The PIN is typically in the format
90
+
"XXX-XX-XXX".
91
+
92
+
This is a one-time operation. Save the resulting {!pairing} for future
93
+
connections. *)
94
+
95
+
val pair_verify :
96
+
net:_ Eio.Net.t ->
97
+
sw:Eio.Switch.t ->
98
+
clock:_ Eio.Time.clock ->
99
+
ip:string ->
100
+
port:int ->
101
+
pairing:pairing ->
102
+
(session, [ `Msg of string ]) result
103
+
(** [pair_verify ~net ~sw ~clock ~ip ~port ~pairing] establishes an encrypted
104
+
session with a previously paired accessory. *)
105
+
106
+
(** {1 Pairing Storage} *)
107
+
108
+
val save_pairing_by_id : fs:_ Eio.Path.t -> pairing -> string
109
+
(** [save_pairing_by_id ~fs pairing] saves the pairing to disk. Returns the file
110
+
path. Pairings are stored in [~/.hap/pairings/]. *)
111
+
112
+
val find_pairing_by_id : fs:_ Eio.Path.t -> string -> pairing option
113
+
(** [find_pairing_by_id ~fs device_id] loads a pairing for the given device. *)
114
+
115
+
val find_pairing_for_ip :
116
+
sw:Eio.Switch.t ->
117
+
net:_ Eio.Net.t ->
118
+
clock:_ Eio.Time.clock ->
119
+
fs:_ Eio.Path.t ->
120
+
string ->
121
+
pairing option
122
+
(** [find_pairing_for_ip ~sw ~net ~clock ~fs ip] discovers the device at [ip]
123
+
and returns its pairing if one exists. *)
124
+
125
+
(** {1 Session Operations} *)
126
+
127
+
val get_accessories :
128
+
net:_ Eio.Net.t ->
129
+
sw:Eio.Switch.t ->
130
+
session ->
131
+
(Jsont.json, [ `Msg of string ]) result
132
+
(** [get_accessories ~net ~sw session] returns the accessory database. *)
133
+
134
+
val get_characteristics :
135
+
net:_ Eio.Net.t ->
136
+
sw:Eio.Switch.t ->
137
+
session ->
138
+
ids:(int * int) list ->
139
+
(Jsont.json, [ `Msg of string ]) result
140
+
(** [get_characteristics ~net ~sw session ~ids] reads characteristics. Each ID
141
+
is [(aid, iid)]. *)
142
+
143
+
val put_characteristic :
144
+
net:_ Eio.Net.t ->
145
+
sw:Eio.Switch.t ->
146
+
session ->
147
+
aid:int ->
148
+
iid:int ->
149
+
Jsont.json ->
150
+
(unit, [ `Msg of string ]) result
151
+
(** [put_characteristic ~net ~sw session ~aid ~iid value] writes a
152
+
characteristic value. *)
153
+
154
+
(** {1 High-level Control} *)
155
+
156
+
val turn_on_outlet :
157
+
net:_ Eio.Net.t ->
158
+
sw:Eio.Switch.t ->
159
+
clock:_ Eio.Time.clock ->
160
+
fs:_ Eio.Path.t ->
161
+
string ->
162
+
(unit, [ `Msg of string ]) result
163
+
(** [turn_on_outlet ~net ~sw ~clock ~fs ip] turns on an outlet at [ip]. Requires
164
+
existing pairing. *)
165
+
166
+
val turn_off_outlet :
167
+
net:_ Eio.Net.t ->
168
+
sw:Eio.Switch.t ->
169
+
clock:_ Eio.Time.clock ->
170
+
fs:_ Eio.Path.t ->
171
+
string ->
172
+
(unit, [ `Msg of string ]) result
173
+
(** [turn_off_outlet ~net ~sw ~clock ~fs ip] turns off an outlet at [ip]. *)
174
+
175
+
val toggle_outlet :
176
+
net:_ Eio.Net.t ->
177
+
sw:Eio.Switch.t ->
178
+
clock:_ Eio.Time.clock ->
179
+
fs:_ Eio.Path.t ->
180
+
string ->
181
+
(unit, [ `Msg of string ]) result
182
+
(** [toggle_outlet ~net ~sw ~clock ~fs ip] toggles an outlet at [ip]. *)
183
+
184
+
(** {1 TLV Encoding} *)
185
+
186
+
(** HAP uses TLV8 encoding for pair setup/verify messages. *)
187
+
module Tlv : sig
188
+
type t = (int * string) list
189
+
190
+
val empty : t
191
+
val add : int -> string -> t -> t
192
+
val get : int -> t -> string option
193
+
val get_exn : int -> t -> string
194
+
val encode : t -> string
195
+
val decode : string -> t
196
+
end
197
+
198
+
(** TLV type codes. *)
199
+
module TlvType : sig
200
+
val method_ : int
201
+
val identifier : int
202
+
val salt : int
203
+
val public_key : int
204
+
val proof : int
205
+
val encrypted_data : int
206
+
val state : int
207
+
val error : int
208
+
val retry_delay : int
209
+
val certificate : int
210
+
val signature : int
211
+
val permissions : int
212
+
val fragment_data : int
213
+
val fragment_last : int
214
+
val separator : int
215
+
end
216
+
217
+
(** HAP error codes. *)
218
+
module HapError : sig
219
+
val unknown : int
220
+
val authentication : int
221
+
val backoff : int
222
+
val max_peers : int
223
+
val max_tries : int
224
+
val unavailable : int
225
+
val busy : int
226
+
end
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "hap" Test_hap.suite
+88
test/test_hap.ml
+88
test/test_hap.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* TLV encoding tests *)
7
+
8
+
let test_tlv_empty () =
9
+
let encoded = Hap.Tlv.encode Hap.Tlv.empty in
10
+
Alcotest.(check string) "empty TLV" "" encoded
11
+
12
+
let test_tlv_single () =
13
+
let tlv = Hap.Tlv.(add 0x01 "hello" empty) in
14
+
let encoded = Hap.Tlv.encode tlv in
15
+
(* Type 0x01, Length 5, "hello" *)
16
+
let expected = "\x01\x05hello" in
17
+
Alcotest.(check string) "single TLV" expected encoded
18
+
19
+
let test_tlv_roundtrip () =
20
+
let tlv = Hap.Tlv.(add 0x01 "hello" (add 0x02 "world" empty)) in
21
+
let encoded = Hap.Tlv.encode tlv in
22
+
let decoded = Hap.Tlv.decode encoded in
23
+
Alcotest.(check (option string))
24
+
"get type 1" (Some "hello") (Hap.Tlv.get 0x01 decoded);
25
+
Alcotest.(check (option string))
26
+
"get type 2" (Some "world") (Hap.Tlv.get 0x02 decoded)
27
+
28
+
let test_tlv_long_value () =
29
+
(* TLV8 fragments values longer than 255 bytes *)
30
+
let long_value = String.make 300 'x' in
31
+
let tlv = Hap.Tlv.(add 0x03 long_value empty) in
32
+
let encoded = Hap.Tlv.encode tlv in
33
+
let decoded = Hap.Tlv.decode encoded in
34
+
Alcotest.(check (option string))
35
+
"long value roundtrip" (Some long_value) (Hap.Tlv.get 0x03 decoded)
36
+
37
+
(* Category name tests *)
38
+
39
+
let test_category_names () =
40
+
Alcotest.(check string) "category 1" "Other" (Hap.category_name 1);
41
+
Alcotest.(check string) "category 2" "Bridge" (Hap.category_name 2);
42
+
Alcotest.(check string)
43
+
"category 4" "Garage Door Opener" (Hap.category_name 4);
44
+
Alcotest.(check string) "category 5" "Lightbulb" (Hap.category_name 5);
45
+
Alcotest.(check string) "category 7" "Outlet" (Hap.category_name 7);
46
+
Alcotest.(check string) "category 8" "Switch" (Hap.category_name 8);
47
+
Alcotest.(check string) "category 10" "Sensor" (Hap.category_name 10);
48
+
Alcotest.(check string) "category 999" "Unknown" (Hap.category_name 999)
49
+
50
+
(* TLV type constants tests *)
51
+
52
+
let test_tlv_type_constants () =
53
+
Alcotest.(check int) "method" 0x00 Hap.TlvType.method_;
54
+
Alcotest.(check int) "identifier" 0x01 Hap.TlvType.identifier;
55
+
Alcotest.(check int) "salt" 0x02 Hap.TlvType.salt;
56
+
Alcotest.(check int) "public_key" 0x03 Hap.TlvType.public_key;
57
+
Alcotest.(check int) "proof" 0x04 Hap.TlvType.proof;
58
+
Alcotest.(check int) "encrypted_data" 0x05 Hap.TlvType.encrypted_data;
59
+
Alcotest.(check int) "state" 0x06 Hap.TlvType.state;
60
+
Alcotest.(check int) "error" 0x07 Hap.TlvType.error;
61
+
Alcotest.(check int) "signature" 0x0a Hap.TlvType.signature
62
+
63
+
(* HAP error constants tests *)
64
+
65
+
let test_hap_error_constants () =
66
+
Alcotest.(check int) "unknown" 0x01 Hap.HapError.unknown;
67
+
Alcotest.(check int) "authentication" 0x02 Hap.HapError.authentication;
68
+
Alcotest.(check int) "backoff" 0x03 Hap.HapError.backoff;
69
+
Alcotest.(check int) "max_peers" 0x04 Hap.HapError.max_peers;
70
+
Alcotest.(check int) "max_tries" 0x05 Hap.HapError.max_tries;
71
+
Alcotest.(check int) "unavailable" 0x06 Hap.HapError.unavailable;
72
+
Alcotest.(check int) "busy" 0x07 Hap.HapError.busy
73
+
74
+
let suite =
75
+
[
76
+
( "TLV",
77
+
[
78
+
Alcotest.test_case "empty" `Quick test_tlv_empty;
79
+
Alcotest.test_case "single" `Quick test_tlv_single;
80
+
Alcotest.test_case "roundtrip" `Quick test_tlv_roundtrip;
81
+
Alcotest.test_case "long value" `Quick test_tlv_long_value;
82
+
] );
83
+
("Category", [ Alcotest.test_case "names" `Quick test_category_names ]);
84
+
( "TlvType",
85
+
[ Alcotest.test_case "constants" `Quick test_tlv_type_constants ] );
86
+
( "HapError",
87
+
[ Alcotest.test_case "constants" `Quick test_hap_error_constants ] );
88
+
]