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. Carries only what the encrypted transport needs —
212 the long-term [pairing] keys used to derive the per-session keys live
213 with the caller, not in the session. *)
214type session = {
215 ip : string;
216 port : int;
217 encrypt_key : string;
218 decrypt_key : string;
219 mutable encrypt_count : int64;
220 mutable decrypt_count : int64;
221}
222
223(* Encrypted frame for HAP sessions *)
224let encrypt_frame session data =
225 let nonce = Bytes.create 12 in
226 Bytes.set_int64_le nonce 4 session.encrypt_count;
227 session.encrypt_count <- Int64.succ session.encrypt_count;
228 let len = String.length data in
229 let len_bytes = Bytes.create 2 in
230 Bytes.set_uint16_le len_bytes 0 len;
231 let aad = Bytes.to_string len_bytes in
232 let encrypted =
233 chacha20_poly1305_encrypt ~key:session.encrypt_key
234 ~nonce:(Bytes.to_string nonce) ~aad data
235 in
236 aad ^ encrypted
237
238let decrypt_frame session data =
239 if String.length data < 18 then Error (`Msg "Frame too short")
240 else begin
241 let len = Char.code data.[0] lor (Char.code data.[1] lsl 8) in
242 let encrypted = String.sub data 2 (String.length data - 2) in
243 if String.length encrypted < len + 16 then Error (`Msg "Frame truncated")
244 else begin
245 let nonce = Bytes.create 12 in
246 Bytes.set_int64_le nonce 4 session.decrypt_count;
247 session.decrypt_count <- Int64.succ session.decrypt_count;
248 let aad = String.sub data 0 2 in
249 chacha20_poly1305_decrypt ~key:session.decrypt_key
250 ~nonce:(Bytes.to_string nonce) ~aad encrypted
251 end
252 end
253
254(* HTTP helpers *)
255let http_post ~net ~clock ~sw ~ip ~port ~path ~content_type:ct ~body =
256 let url = Fmt.str "http://%s:%d%s" ip port path in
257 let headers = Requests.Headers.(empty |> set_string "Content-Type" ct) in
258 let body = Requests.Body.of_string Requests.Mime.octet_stream body in
259 let timeout = Requests.Timeout.v ~connect:10.0 ~read:10.0 () in
260 let response =
261 Requests.One.post ~sw ~clock ~net ~headers ~body ~timeout ~verify_tls:false
262 url
263 in
264 Ok (Requests.Response.text response)
265
266(* Build encrypted M5 request with controller credentials *)
267let build_m5 ~session_key_bytes ~enc_key (controller_kp : Ed25519.keypair)
268 controller_id =
269 let controller_x =
270 hkdf_sha512 ~salt:"Pair-Setup-Controller-Sign-Salt" ~ikm:session_key_bytes
271 ~info:"Pair-Setup-Controller-Sign-Info" ~length:32
272 in
273 let sign_data = controller_x ^ controller_id ^ controller_kp.public in
274 let signature = Ed25519.sign ~secret:controller_kp.secret sign_data in
275 let sub_tlv =
276 Tlv.(
277 empty
278 |> add Tlv_type.identifier controller_id
279 |> add Tlv_type.public_key controller_kp.public
280 |> add Tlv_type.signature signature
281 |> encode)
282 in
283 let encrypted =
284 chacha20_poly1305_encrypt ~key:enc_key ~nonce:"\x00\x00\x00\x00PS-Msg05"
285 ~aad:"" sub_tlv
286 in
287 Tlv.(
288 empty |> add Tlv_type.state "\x05"
289 |> add Tlv_type.encrypted_data encrypted
290 |> encode)
291
292(* Verify M6 accessory response and return pairing info *)
293let verify_m6 ~session_key_bytes ~enc_key (controller_kp : Ed25519.keypair)
294 controller_id m6 =
295 let enc_data = Tlv.get_exn Tlv_type.encrypted_data m6 in
296 let* decrypted =
297 chacha20_poly1305_decrypt ~key:enc_key ~nonce:"\x00\x00\x00\x00PS-Msg06"
298 ~aad:"" enc_data
299 in
300 let sub_tlv = Tlv.decode decrypted in
301 let accessory_id = Tlv.get_exn Tlv_type.identifier sub_tlv in
302 let accessory_ltpk = Tlv.get_exn Tlv_type.public_key sub_tlv in
303 let accessory_sig = Tlv.get_exn Tlv_type.signature sub_tlv in
304 let accessory_x =
305 hkdf_sha512 ~salt:"Pair-Setup-Accessory-Sign-Salt" ~ikm:session_key_bytes
306 ~info:"Pair-Setup-Accessory-Sign-Info" ~length:32
307 in
308 let verify_data = accessory_x ^ accessory_id ^ accessory_ltpk in
309 if
310 not
311 (Ed25519.verify ~public:accessory_ltpk ~signature:accessory_sig
312 verify_data)
313 then Error (`Msg "Accessory signature verification failed")
314 else begin
315 Log.info (fun f -> f "Pair setup complete! Accessory ID: %s" accessory_id);
316 Ok
317 {
318 accessory_id;
319 accessory_ltpk;
320 controller_id;
321 controller_ltsk = controller_kp.secret;
322 controller_ltpk = controller_kp.public;
323 }
324 end
325
326(* Pair Setup M5/M6 exchange - derive keys, sign, encrypt, and verify *)
327let pair_setup_exchange ~net ~sw ~clock ~ip ~port ~session_key_bytes ~enc_key =
328 let controller_kp = Ed25519.generate () in
329 let controller_id = "maison-controller" in
330 let m5 = build_m5 ~session_key_bytes ~enc_key controller_kp controller_id in
331 let* m6_body =
332 http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup"
333 ~content_type:"application/pairing+tlv8" ~body:m5
334 in
335 let m6 = Tlv.decode m6_body in
336 match Tlv.get Tlv_type.error m6 with
337 | Some e -> err_pair_setup_m6 e
338 | None -> verify_m6 ~session_key_bytes ~enc_key controller_kp controller_id m6
339
340(* SRP M3/M4 verify exchange and derive encryption key for M5/M6 *)
341let srp_verify ~net ~sw ~clock ~ip ~port ~srp_client ~salt ~big_b ~session_key =
342 let big_a = Srp.Client.public_key srp_client in
343 let m1_proof =
344 Srp.Client.compute_proof srp_client ~salt ~big_b ~session_key
345 in
346 let n_len = (Z.numbits Srp.n + 7) / 8 in
347 let m3 =
348 Tlv.(
349 empty |> add Tlv_type.state "\x03"
350 |> add Tlv_type.public_key (Srp.bytes_of_z ~pad:n_len big_a)
351 |> add Tlv_type.proof m1_proof
352 |> encode)
353 in
354 let* m4_body =
355 http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup"
356 ~content_type:"application/pairing+tlv8" ~body:m3
357 in
358 let m4 = Tlv.decode m4_body in
359 match Tlv.get Tlv_type.error m4 with
360 | Some e -> err_pair_setup_m4 e
361 | None ->
362 let m2_proof = Tlv.get_exn Tlv_type.proof m4 in
363 if
364 not
365 (Srp.Client.verify_proof srp_client ~m1:m1_proof ~m2:m2_proof
366 ~session_key)
367 then Error (`Msg "Server proof verification failed")
368 else begin
369 Log.info (fun f -> f "SRP verification successful");
370 let enc_key =
371 hkdf_sha512 ~salt:"Pair-Setup-Encrypt-Salt" ~ikm:session_key
372 ~info:"Pair-Setup-Encrypt-Info" ~length:32
373 in
374 pair_setup_exchange ~net ~sw ~clock ~ip ~port
375 ~session_key_bytes:session_key ~enc_key
376 end
377
378(* Pair Setup - M1 through M6 *)
379let pair_setup ~net ~sw ~clock ~ip ~port ~pin =
380 Log.info (fun f -> f "Starting pair setup with %s:%d" ip port);
381 let m1 =
382 Tlv.(
383 empty |> add Tlv_type.state "\x01"
384 |> add Tlv_type.method_ "\x00"
385 |> encode)
386 in
387 let* m2_body =
388 http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup"
389 ~content_type:"application/pairing+tlv8" ~body:m1
390 in
391 let m2 = Tlv.decode m2_body in
392 match Tlv.get Tlv_type.error m2 with
393 | Some e -> err_pair_setup e
394 | None ->
395 let salt = Tlv.get_exn Tlv_type.salt m2 in
396 let big_b_bytes = Tlv.get_exn Tlv_type.public_key m2 in
397 let big_b = Srp.z_of_bytes big_b_bytes in
398 Log.info (fun f ->
399 f "Received M2, salt=%d bytes, B=%d bytes" (String.length salt)
400 (String.length big_b_bytes));
401 let srp_client = Srp.Client.create ~username:"Pair-Setup" ~password:pin in
402 let* session_key =
403 Srp.Client.compute_session_key srp_client ~salt ~big_b
404 in
405 srp_verify ~net ~sw ~clock ~ip ~port ~srp_client ~salt ~big_b ~session_key
406
407(* Build encrypted M3 verify request *)
408let build_verify_m3 ~enc_key ~pairing ~kp ~accessory_pk =
409 let sign_data = kp.X25519.public ^ pairing.controller_id ^ accessory_pk in
410 let signature = Ed25519.sign ~secret:pairing.controller_ltsk sign_data in
411 let sub_tlv =
412 Tlv.(
413 empty
414 |> add Tlv_type.identifier pairing.controller_id
415 |> add Tlv_type.signature signature
416 |> encode)
417 in
418 let encrypted =
419 chacha20_poly1305_encrypt ~key:enc_key ~nonce:"\x00\x00\x00\x00PV-Msg03"
420 ~aad:"" sub_tlv
421 in
422 Tlv.(
423 empty |> add Tlv_type.state "\x03"
424 |> add Tlv_type.encrypted_data encrypted
425 |> encode)
426
427(* Derive session keys from shared secret *)
428let derive_session_keys ~ip ~port ~shared =
429 let enc_key =
430 hkdf_sha512 ~salt:"Control-Salt" ~ikm:shared
431 ~info:"Control-Write-Encryption-Key" ~length:32
432 in
433 let dec_key =
434 hkdf_sha512 ~salt:"Control-Salt" ~ikm:shared
435 ~info:"Control-Read-Encryption-Key" ~length:32
436 in
437 Log.info (fun f -> f "Pair verify successful, session established");
438 Ok
439 {
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 ~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 (Json.Error.to_string e))
540 (Json.Value.of_string 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 : Json.t }
554
555let char_write_codec =
556 let open Json.Codec in
557 Object.map ~kind:"char_write" (fun aid iid value ->
558 { cw_aid = aid; cw_iid = iid; cw_value = value })
559 |> Object.member "aid" int ~enc:(fun c -> c.cw_aid)
560 |> Object.member "iid" int ~enc:(fun c -> c.cw_iid)
561 |> Object.member "value" Value.t ~enc:(fun c -> c.cw_value)
562 |> Object.seal
563
564type char_write_request = { characteristics : char_write list }
565
566let char_write_request_codec =
567 let open Json.Codec in
568 Object.map ~kind:"char_write_request" (fun characteristics ->
569 { characteristics })
570 |> Object.member "characteristics" (list char_write_codec) ~enc:(fun r ->
571 r.characteristics)
572 |> Object.seal
573
574(* Write a characteristic *)
575let put_characteristic ~net ~sw session ~aid ~iid value =
576 let req =
577 { characteristics = [ { cw_aid = aid; cw_iid = iid; cw_value = value } ] }
578 in
579 let body = Json.to_string char_write_request_codec req in
580 let path = "/characteristics" in
581 let req =
582 Fmt.str
583 "PUT %s HTTP/1.1\r\n\
584 Host: %s:%d\r\n\
585 Content-Type: application/hap+json\r\n\
586 Content-Length: %d\r\n\
587 \r\n\
588 %s"
589 path session.ip session.port (String.length body) body
590 in
591 let* _decrypted = request ~net ~sw session req in
592 Ok ()
593
594(* Read characteristics *)
595let characteristics ~net ~sw session ~ids =
596 let ids_str =
597 String.concat "," (List.map (fun (aid, iid) -> Fmt.str "%d.%d" aid iid) ids)
598 in
599 let path = Fmt.str "/characteristics?id=%s" ids_str in
600 let req =
601 Fmt.str "GET %s HTTP/1.1\r\nHost: %s:%d\r\n\r\n" path session.ip
602 session.port
603 in
604 let* decrypted = request ~net ~sw session req in
605 parse_json_response decrypted
606
607(* Pairing storage directory *)
608let pairings_dir = ".hap/pairings"
609
610let ensure_pairings_dir ~fs =
611 let hap_path = Eio.Path.(fs / ".hap") in
612 let pairings_path = Eio.Path.(fs / pairings_dir) in
613 (try Eio.Path.mkdir ~perm:0o700 hap_path with Eio.Exn.Io _ -> ());
614 try Eio.Path.mkdir ~perm:0o700 pairings_path with Eio.Exn.Io _ -> ()
615
616(* Sanitize device_id for filename (replace colons with dashes) *)
617let sanitize_id id = String.map (fun c -> if c = ':' then '-' else c) id
618
619let pairing_path_for_id device_id =
620 Fmt.str "%s/hap-%s.json" pairings_dir (sanitize_id device_id)
621
622(** Jsont codec for pairing storage *)
623module Pairing_json = struct
624 type stored = {
625 accessory_id : string;
626 accessory_ltpk : string; (* Base64-encoded *)
627 controller_id : string;
628 controller_ltsk : string; (* Base64-encoded *)
629 controller_ltpk : string; (* Base64-encoded *)
630 }
631
632 let stored =
633 let open Json.Codec in
634 Object.map ~kind:"hap.pairing"
635 (fun
636 accessory_id
637 accessory_ltpk
638 controller_id
639 controller_ltsk
640 controller_ltpk
641 ->
642 {
643 accessory_id;
644 accessory_ltpk;
645 controller_id;
646 controller_ltsk;
647 controller_ltpk;
648 })
649 |> Object.member "accessory_id" string ~enc:(fun p -> p.accessory_id)
650 |> Object.member "accessory_ltpk" string ~enc:(fun p -> p.accessory_ltpk)
651 |> Object.member "controller_id" string ~enc:(fun p -> p.controller_id)
652 |> Object.member "controller_ltsk" string ~enc:(fun p -> p.controller_ltsk)
653 |> Object.member "controller_ltpk" string ~enc:(fun p -> p.controller_ltpk)
654 |> Object.seal
655
656 let of_pairing (p : pairing) : stored =
657 {
658 accessory_id = p.accessory_id;
659 accessory_ltpk = Base64.encode_string p.accessory_ltpk;
660 controller_id = p.controller_id;
661 controller_ltsk = Base64.encode_string p.controller_ltsk;
662 controller_ltpk = Base64.encode_string p.controller_ltpk;
663 }
664
665 let to_pairing (s : stored) : pairing =
666 {
667 accessory_id = s.accessory_id;
668 accessory_ltpk = Base64.decode_exn s.accessory_ltpk;
669 controller_id = s.controller_id;
670 controller_ltsk = Base64.decode_exn s.controller_ltsk;
671 controller_ltpk = Base64.decode_exn s.controller_ltpk;
672 }
673end
674
675(* Save/load pairing to file *)
676let save_pairing ~fs ~path (pairing : pairing) =
677 let stored = Pairing_json.of_pairing pairing in
678 let json = Json.to_string ~indent:2 Pairing_json.stored stored in
679 Eio.Path.save ~create:(`Or_truncate 0o600) Eio.Path.(fs / path) json
680
681let load_pairing ~fs ~path =
682 let full_path = Eio.Path.(fs / path) in
683 if not (Eio.Path.is_file full_path) then None
684 else
685 begin try
686 let content = Eio.Path.load full_path in
687 match Json.of_string Pairing_json.stored content with
688 | Ok stored -> Some (Pairing_json.to_pairing stored)
689 | Error _ -> None
690 with Eio.Io _ -> None
691 end
692
693(* Save pairing by device_id *)
694let save_pairing_by_id ~fs pairing =
695 ensure_pairings_dir ~fs;
696 let path = pairing_path_for_id pairing.accessory_id in
697 save_pairing ~fs ~path pairing;
698 path
699
700(* Find pairing for a device by its HAP device_id *)
701let pairing_by_id ~fs device_id =
702 let path = pairing_path_for_id device_id in
703 load_pairing ~fs ~path
704
705(* HAP category codes *)
706let category_name = function
707 | 1 -> "Other"
708 | 2 -> "Bridge"
709 | 3 -> "Fan"
710 | 4 -> "Garage Door Opener"
711 | 5 -> "Lightbulb"
712 | 6 -> "Door Lock"
713 | 7 -> "Outlet"
714 | 8 -> "Switch"
715 | 9 -> "Thermostat"
716 | 10 -> "Sensor"
717 | 11 -> "Security System"
718 | 12 -> "Door"
719 | 13 -> "Window"
720 | 14 -> "Window Covering"
721 | 15 -> "Programmable Switch"
722 | 16 -> "Range Extender"
723 | 17 -> "IP Camera"
724 | 18 -> "Video Doorbell"
725 | 19 -> "Air Purifier"
726 | 20 -> "Heater"
727 | 21 -> "Air Conditioner"
728 | 22 -> "Humidifier"
729 | 23 -> "Dehumidifier"
730 | 24 -> "Apple TV"
731 | 25 -> "HomePod"
732 | 26 -> "Speaker"
733 | 27 -> "AirPort"
734 | 28 -> "Sprinkler"
735 | 29 -> "Faucet"
736 | 30 -> "Shower Head"
737 | 31 -> "Television"
738 | 32 -> "Target Controller"
739 | 33 -> "WiFi Router"
740 | 34 -> "Audio Receiver"
741 | 35 -> "TV Set Top Box"
742 | 36 -> "TV Streaming Stick"
743 | _ -> "Unknown"
744
745(* Parse HAP TXT record *)
746let parse_hap_txt txt =
747 (* TXT record contains key=value pairs *)
748 let pairs = String.split_on_char ' ' txt in
749 let find key =
750 List.find_map
751 (fun p ->
752 match String.split_on_char '=' p with
753 | [ k; v ] when k = key -> Some v
754 | _ -> None)
755 pairs
756 in
757 let find_int key = Option.bind (find key) int_of_string_opt in
758 let device_id = find "id" in
759 let model = find "md" in
760 let config_num = find_int "c#" in
761 let state_num = find_int "s#" in
762 let category = find_int "ci" in
763 let paired = find_int "sf" = Some 0 in
764 (device_id, model, config_num, state_num, category, paired)
765
766(* Build accessory_info from mDNS instance, SRV, TXT, and address records *)
767let build_device_info (r : Mdns.response) instance =
768 match
769 List.find_opt (fun (n, _, _) -> Domain_name.equal n instance) r.srvs
770 with
771 | None -> None
772 | Some (_, port, target) ->
773 let txt =
774 List.find_map
775 (fun (n, t) -> if Domain_name.equal n instance then Some t else None)
776 r.txts
777 |> Option.value ~default:[] |> String.concat " "
778 in
779 let ip =
780 List.find_map
781 (fun (n, ip) ->
782 if Domain_name.equal n target then Some (Ipaddr.V4.to_string ip)
783 else None)
784 r.addrs
785 |> Option.value ~default:(Domain_name.to_string target)
786 in
787 let device_id, model, config_num, state_num, category, paired =
788 parse_hap_txt txt
789 in
790 let name =
791 match Domain_name.get_label instance 0 with
792 | Ok label -> label
793 | Error _ -> Domain_name.to_string instance
794 in
795 Some
796 {
797 name;
798 device_id = Option.value ~default:"" device_id;
799 ip;
800 port;
801 model;
802 config_num = Option.value ~default:0 config_num;
803 state_num = Option.value ~default:0 state_num;
804 category = Option.value ~default:0 category;
805 paired;
806 }
807
808(* Discover HAP devices using mDNS *)
809let discover ~sw ~net ~clock ?(timeout = 3.0) () =
810 let service_name = Domain_name.of_string_exn "_hap._tcp.local" in
811 let r = Mdns.merge (Mdns.query ~sw ~net ~clock ~timeout service_name) in
812 (* Get unique service instances from PTR records *)
813 let instances =
814 List.filter_map
815 (fun (service, instance) ->
816 if Domain_name.equal service service_name then Some instance else None)
817 r.ptrs
818 |> List.sort_uniq Domain_name.compare
819 in
820 (* Build device info for each instance *)
821 List.filter_map (build_device_info r) instances
822
823(* Find pairing for an IP by discovering the device first *)
824let pairing_for_ip ~sw ~net ~clock ~fs ip =
825 let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
826 match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with
827 | None -> None
828 | Some info ->
829 if info.device_id = "" then None else pairing_by_id ~fs info.device_id
830
831(* Get accessory info for an IP *)
832let accessory_info ~sw ~net ~clock ip =
833 let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
834 List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices
835
836(* Pretty print accessory info *)
837let pp_accessory_info ppf info =
838 let cat = category_name info.category in
839 let status = if info.paired then "paired" else "unpaired" in
840 Fmt.pf ppf "@[<v 0>%s@," info.name;
841 Fmt.pf ppf " Type: %s@," cat;
842 Fmt.pf ppf " Device ID: %s@," info.device_id;
843 Fmt.pf ppf " Address: %s:%d@," info.ip info.port;
844 Option.iter (fun m -> Fmt.pf ppf " Model: %s@," m) info.model;
845 Fmt.pf ppf " Status: %s@," status;
846 Fmt.pf ppf " Config: #%d, State: #%d@]" info.config_num info.state_num
847
848(** {1 HAP JSON Codecs} *)
849
850module Hap_json = struct
851 open Json.Codec
852
853 type characteristic = { iid : int; type_ : string; value : Json.t option }
854 (** HAP characteristic *)
855
856 let characteristic =
857 Object.map ~kind:"hap.characteristic" (fun iid type_ value ->
858 { iid; type_; value })
859 |> Object.member "iid" int ~enc:(fun c -> c.iid)
860 |> Object.member "type" string ~enc:(fun c -> c.type_)
861 |> Object.opt_member "value" Value.t ~enc:(fun c -> c.value)
862 |> Object.seal
863
864 type service = {
865 iid : int;
866 type_ : string;
867 characteristics : characteristic list;
868 }
869 (** HAP service *)
870
871 let service =
872 Object.map ~kind:"hap.service" (fun iid type_ characteristics ->
873 { iid; type_; characteristics })
874 |> Object.member "iid" int ~enc:(fun s -> s.iid)
875 |> Object.member "type" string ~enc:(fun s -> s.type_)
876 |> Object.member "characteristics" (list characteristic) ~enc:(fun s ->
877 s.characteristics)
878 |> Object.seal
879
880 type accessory = { aid : int; services : service list }
881 (** HAP accessory *)
882
883 let accessory =
884 Object.map ~kind:"hap.accessory" (fun aid services -> { aid; services })
885 |> Object.member "aid" int ~enc:(fun a -> a.aid)
886 |> Object.member "services" (list service) ~enc:(fun a -> a.services)
887 |> Object.seal
888
889 type accessories_response = { accessories : accessory list }
890 (** HAP accessories response *)
891
892 let accessories_response =
893 Object.map ~kind:"hap.accessories_response" (fun accessories ->
894 { accessories })
895 |> Object.member "accessories" (list accessory) ~enc:(fun r ->
896 r.accessories)
897 |> Object.seal
898
899 type char_value = { aid : int; iid : int; value : Json.t option }
900 (** HAP characteristics value *)
901
902 let char_value =
903 Object.map ~kind:"hap.char_value" (fun aid iid value -> { aid; iid; value })
904 |> Object.member "aid" int ~enc:(fun c -> c.aid)
905 |> Object.member "iid" int ~enc:(fun c -> c.iid)
906 |> Object.opt_member "value" Value.t ~enc:(fun c -> c.value)
907 |> Object.seal
908
909 type characteristics_response = { characteristics : char_value list }
910
911 let characteristics_response =
912 Object.map ~kind:"hap.characteristics_response" (fun characteristics ->
913 { characteristics })
914 |> Object.member "characteristics" (list char_value) ~enc:(fun r ->
915 r.characteristics)
916 |> Object.seal
917end
918
919(** {1 High-level control} *)
920
921(* HAP characteristic type UUIDs (short form) *)
922module Char_type = struct
923 let on = "25" (* 00000025-0000-1000-8000-0026BB765291 *)
924end
925
926(* Decode Json.t via codec *)
927let decode codec json = Json.of_string codec (Json.Value.to_string json)
928
929(* Find the On characteristic IID from accessories JSON *)
930let on_characteristic_iid json =
931 match decode Hap_json.accessories_response json with
932 | Error _ -> None
933 | Ok resp ->
934 List.find_map
935 (fun (acc : Hap_json.accessory) ->
936 List.find_map
937 (fun (svc : Hap_json.service) ->
938 List.find_map
939 (fun (chr : Hap_json.characteristic) ->
940 if String.lowercase_ascii chr.type_ = Char_type.on then
941 Some (acc.aid, chr.iid)
942 else None)
943 svc.characteristics)
944 acc.services)
945 resp.accessories
946
947(* Control an accessory by IP - establishes session, finds characteristic, sets value *)
948let control_outlet ~net ~sw ~clock ~fs ~ip ~value =
949 (* 1. Discover to get device info *)
950 let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
951 match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with
952 | None -> Error (`Msg "Device not found via HAP discovery")
953 | Some info -> (
954 if info.device_id = "" then Error (`Msg "Device has no device_id")
955 else
956 (* 2. Find pairing *)
957 match pairing_by_id ~fs info.device_id with
958 | None ->
959 Error (`Msg "No pairing found for device - run 'plug pair' first")
960 | Some pairing -> (
961 (* 3. Establish session *)
962 let* session =
963 pair_verify ~net ~sw ~clock ~ip ~port:info.port ~pairing
964 in
965 (* 4. Get accessories to find On characteristic *)
966 let* accessories_json = accessories ~net ~sw session in
967 match on_characteristic_iid accessories_json with
968 | None -> Error (`Msg "Could not find On characteristic")
969 | Some (aid, iid) ->
970 (* 5. Set value *)
971 put_characteristic ~net ~sw session ~aid ~iid
972 (Json.Bool (value, Json.Meta.none))))
973
974let turn_on_outlet ~net ~sw ~clock ~fs ip =
975 control_outlet ~net ~sw ~clock ~fs ~ip ~value:true
976
977let turn_off_outlet ~net ~sw ~clock ~fs ip =
978 control_outlet ~net ~sw ~clock ~fs ~ip ~value:false
979
980(* Extract bool value from characteristics response *)
981let bool_value json =
982 match decode Hap_json.characteristics_response json with
983 | Error _ -> None
984 | Ok (resp : Hap_json.characteristics_response) -> (
985 match resp.characteristics with
986 | [ (c : Hap_json.char_value) ] -> (
987 match c.value with Some (Json.Bool (b, _)) -> Some b | _ -> None)
988 | _ -> None)
989
990let toggle_outlet ~net ~sw ~clock ~fs ip =
991 (* For toggle, we need to read current state first *)
992 let devices = discover ~sw ~net ~clock ~timeout:2.0 () in
993 match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with
994 | None -> Error (`Msg "Device not found via HAP discovery")
995 | Some info -> (
996 if info.device_id = "" then Error (`Msg "Device has no device_id")
997 else
998 match pairing_by_id ~fs info.device_id with
999 | None -> Error (`Msg "No pairing found for device")
1000 | Some pairing -> (
1001 let* session =
1002 pair_verify ~net ~sw ~clock ~ip ~port:info.port ~pairing
1003 in
1004 let* accessories_json = accessories ~net ~sw session in
1005 match on_characteristic_iid accessories_json with
1006 | None -> Error (`Msg "Could not find On characteristic")
1007 | Some (aid, iid) -> (
1008 let* chars_json =
1009 characteristics ~net ~sw session ~ids:[ (aid, iid) ]
1010 in
1011 match bool_value chars_json with
1012 | None -> Error (`Msg "Could not read current state")
1013 | Some v ->
1014 put_characteristic ~net ~sw session ~aid ~iid
1015 (Json.Bool (not v, Json.Meta.none)))))