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