Something went wrong. Try again.
HomeKit Accessory Protocol (HAP)
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926let log_src = Logs.Src.create "hap"
module Log = (val Logs.src_log log_src : Logs.LOG)open Result.Syntax
let err_pair_setup code = Error (`Msg (Fmt.str "Pair setup error: %d" (Char.code code.[0])))
let err_pair_setup_m4 code = Error (`Msg (Fmt.str "Pair setup M4 error: %d" (Char.code code.[0])))
let err_pair_setup_m6 code = Error (`Msg (Fmt.str "Pair setup M6 error: %d" (Char.code code.[0])))
let err_pair_verify_m2 code = Error (`Msg (Fmt.str "Pair verify M2 error: %d" (Char.code code.[0])))
let err_pair_verify_m4 code = Error (`Msg (Fmt.str "Pair verify M4 error: %d" (Char.code code.[0])))
let ipv4_of_string ip = Eio_addr.ip (Ipaddr.of_string_exn ip)
module Tlv = struct type t = (int * string) list
let empty = [] let add typ value tlv = (typ, value) :: tlv
let get typ tlv = List.find_map (fun (t, v) -> if t = typ then Some v else None) tlv
let get_exn typ tlv = match get typ tlv with | Some v -> v | None -> Fmt.failwith "TLV type %d not found" typ
let encode tlv = let buf = Buffer.create 256 in List.iter (fun (typ, value) -> let len = String.length value in let rec write_chunks offset = if offset >= len then () else begin let chunk_len = min 255 (len - offset) in Buffer.add_char buf (Char.chr typ); Buffer.add_char buf (Char.chr chunk_len); Buffer.add_substring buf value offset chunk_len; write_chunks (offset + chunk_len) end in if len = 0 then begin Buffer.add_char buf (Char.chr typ); Buffer.add_char buf '\x00' end else write_chunks 0) (List.rev tlv); Buffer.contents buf
(* Push the new (typ, value) pair onto [acc], merging with the previous entry when they share the same type (split values are concatenated). *) let push_tlv acc typ value = match acc with | (prev_typ, prev_val) :: rest when prev_typ = typ -> (typ, prev_val ^ value) :: rest | _ -> (typ, value) :: acc
let decode data = let len = String.length data in let rec parse offset acc = if offset + 2 > len then List.rev acc else let typ = Char.code data.[offset] in let vlen = Char.code data.[offset + 1] in if offset + 2 + vlen > len then List.rev acc else let value = String.sub data (offset + 2) vlen in parse (offset + 2 + vlen) (push_tlv acc typ value) in parse 0 []end
module Tlv_type = struct let method_ = 0x00 let identifier = 0x01 let salt = 0x02 let public_key = 0x03 let proof = 0x04 let encrypted_data = 0x05 let state = 0x06 let error = 0x07 let retry_delay = 0x08 let certificate = 0x09 let signature = 0x0a let permissions = 0x0b let fragment_data = 0x0c let fragment_last = 0x0d let separator = 0xffend
module Hap_error = struct let unknown = 0x01 let authentication = 0x02 let backoff = 0x03 let max_peers = 0x04 let max_tries = 0x05 let unavailable = 0x06 let busy = 0x07end
let chacha20_poly1305_encrypt ~key ~nonce ~aad data = let key = Crypto.Chacha20.of_string key in let encrypted = Crypto.Chacha20.authenticate_encrypt ~key ~nonce ~adata:aad data in encrypted
let chacha20_poly1305_decrypt ~key ~nonce ~aad data = let key = Crypto.Chacha20.of_string key in match Crypto.Chacha20.authenticate_decrypt ~key ~nonce ~adata:aad data with | Some decrypted -> Ok decrypted | None -> Error (`Msg "Decryption failed")
let hkdf_sha512 ~salt ~ikm ~info ~length = let prk = Hkdf.extract ~hash:`SHA512 ~salt ikm in Hkdf.expand ~hash:`SHA512 ~prk ~info length
module Ed25519 = struct type keypair = { secret : string; public : string }
let generate () = let priv, pub = Crypto_ec.Ed25519.generate () in { secret = Crypto_ec.Ed25519.priv_to_octets priv; public = Crypto_ec.Ed25519.pub_to_octets pub; }
let sign ~secret data = match Crypto_ec.Ed25519.priv_of_octets secret with | Ok priv -> Crypto_ec.Ed25519.sign ~key:priv data | Error _ -> failwith "Invalid Ed25519 private key"
let verify ~public ~signature data = match Crypto_ec.Ed25519.pub_of_octets public with | Ok pub -> Crypto_ec.Ed25519.verify ~key:pub signature ~msg:data | Error _ -> falseend
module X25519 = struct type keypair = { secret : string; public : string }
let generate () = let secret, public = Crypto_ec.X25519.gen_key () in { secret = Crypto_ec.X25519.secret_to_octets secret; public }
let shared_secret ~secret ~public = match Crypto_ec.X25519.secret_of_octets secret with | Ok (secret, _) -> ( match Crypto_ec.X25519.key_exchange secret public with | Ok s -> Ok s | Error _ -> Error (`Msg "X25519 key exchange failed")) | Error _ -> Error (`Msg "Invalid X25519 secret key")end
type pairing = { accessory_id : string; accessory_ltpk : string; controller_id : string; controller_ltsk : string; controller_ltpk : string;}
type accessory_info = { name : string; device_id : string; ip : string; port : int; model : string option; config_num : int; state_num : int; category : int; paired : bool;}
(* Holds only the per-session keys; the long-term [pairing] keys that derive them live with the caller. *)type session = { ip : string; port : int; encrypt_key : string; decrypt_key : string; mutable encrypt_count : int64; mutable decrypt_count : int64;}
let encrypt_frame session data = let nonce = Bytes.create 12 in Bytes.set_int64_le nonce 4 session.encrypt_count; session.encrypt_count <- Int64.succ session.encrypt_count; let len = String.length data in let len_bytes = Bytes.create 2 in Bytes.set_uint16_le len_bytes 0 len; let aad = Bytes.to_string len_bytes in let encrypted = chacha20_poly1305_encrypt ~key:session.encrypt_key ~nonce:(Bytes.to_string nonce) ~aad data in aad ^ encrypted
let decrypt_frame session data = if String.length data < 18 then Error (`Msg "Frame too short") else begin let len = Char.code data.[0] lor (Char.code data.[1] lsl 8) in let encrypted = String.sub data 2 (String.length data - 2) in if String.length encrypted < len + 16 then Error (`Msg "Frame truncated") else begin let nonce = Bytes.create 12 in Bytes.set_int64_le nonce 4 session.decrypt_count; session.decrypt_count <- Int64.succ session.decrypt_count; let aad = String.sub data 0 2 in chacha20_poly1305_decrypt ~key:session.decrypt_key ~nonce:(Bytes.to_string nonce) ~aad encrypted end end
let http_post ~net ~clock ~sw ~ip ~port ~path ~content_type:ct ~body = let url = Fmt.str "http://%s:%d%s" ip port path in let headers = Requests_eio.Headers.(empty |> set_string "Content-Type" ct) in let body = Requests_eio.Body.of_string Requests_eio.Mime.octet_stream body in let timeout = Requests_eio.Timeout.v ~connect:10.0 ~read:10.0 () in let t = Requests_eio.v ~sw ~timeout ~verify_tls:false ~clock net in let response = Requests_eio.post t ~headers ~body url in Ok (Requests_eio.Response.text response)
let build_m5 ~session_key_bytes ~enc_key (controller_kp : Ed25519.keypair) controller_id = let controller_x = hkdf_sha512 ~salt:"Pair-Setup-Controller-Sign-Salt" ~ikm:session_key_bytes ~info:"Pair-Setup-Controller-Sign-Info" ~length:32 in let sign_data = controller_x ^ controller_id ^ controller_kp.public in let signature = Ed25519.sign ~secret:controller_kp.secret sign_data in let sub_tlv = Tlv.( empty |> add Tlv_type.identifier controller_id |> add Tlv_type.public_key controller_kp.public |> add Tlv_type.signature signature |> encode) in let encrypted = chacha20_poly1305_encrypt ~key:enc_key ~nonce:"\x00\x00\x00\x00PS-Msg05" ~aad:"" sub_tlv in Tlv.( empty |> add Tlv_type.state "\x05" |> add Tlv_type.encrypted_data encrypted |> encode)
let verify_m6 ~session_key_bytes ~enc_key (controller_kp : Ed25519.keypair) controller_id m6 = let enc_data = Tlv.get_exn Tlv_type.encrypted_data m6 in let* decrypted = chacha20_poly1305_decrypt ~key:enc_key ~nonce:"\x00\x00\x00\x00PS-Msg06" ~aad:"" enc_data in let sub_tlv = Tlv.decode decrypted in let accessory_id = Tlv.get_exn Tlv_type.identifier sub_tlv in let accessory_ltpk = Tlv.get_exn Tlv_type.public_key sub_tlv in let accessory_sig = Tlv.get_exn Tlv_type.signature sub_tlv in let accessory_x = hkdf_sha512 ~salt:"Pair-Setup-Accessory-Sign-Salt" ~ikm:session_key_bytes ~info:"Pair-Setup-Accessory-Sign-Info" ~length:32 in let verify_data = accessory_x ^ accessory_id ^ accessory_ltpk in if not (Ed25519.verify ~public:accessory_ltpk ~signature:accessory_sig verify_data) then Error (`Msg "Accessory signature verification failed") else begin Log.info (fun f -> f "Pair setup complete! Accessory ID: %s" accessory_id); Ok { accessory_id; accessory_ltpk; controller_id; controller_ltsk = controller_kp.secret; controller_ltpk = controller_kp.public; } end
let pair_setup_exchange ~net ~sw ~clock ~ip ~port ~session_key_bytes ~enc_key = let controller_kp = Ed25519.generate () in let controller_id = "maison-controller" in let m5 = build_m5 ~session_key_bytes ~enc_key controller_kp controller_id in let* m6_body = http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup" ~content_type:"application/pairing+tlv8" ~body:m5 in let m6 = Tlv.decode m6_body in match Tlv.get Tlv_type.error m6 with | Some e -> err_pair_setup_m6 e | None -> verify_m6 ~session_key_bytes ~enc_key controller_kp controller_id m6
let srp_verify ~net ~sw ~clock ~ip ~port ~srp_client ~salt ~big_b ~session_key = let big_a = Srp.Client.public_key srp_client in let m1_proof = Srp.Client.compute_proof srp_client ~salt ~big_b ~session_key in let n_len = (Z.numbits Srp.n + 7) / 8 in let m3 = Tlv.( empty |> add Tlv_type.state "\x03" |> add Tlv_type.public_key (Srp.bytes_of_z ~pad:n_len big_a) |> add Tlv_type.proof m1_proof |> encode) in let* m4_body = http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup" ~content_type:"application/pairing+tlv8" ~body:m3 in let m4 = Tlv.decode m4_body in match Tlv.get Tlv_type.error m4 with | Some e -> err_pair_setup_m4 e | None -> let m2_proof = Tlv.get_exn Tlv_type.proof m4 in if not (Srp.Client.verify_proof srp_client ~m1:m1_proof ~m2:m2_proof ~session_key) then Error (`Msg "Server proof verification failed") else begin Log.info (fun f -> f "SRP verification successful"); let enc_key = hkdf_sha512 ~salt:"Pair-Setup-Encrypt-Salt" ~ikm:session_key ~info:"Pair-Setup-Encrypt-Info" ~length:32 in pair_setup_exchange ~net ~sw ~clock ~ip ~port ~session_key_bytes:session_key ~enc_key end
let pair_setup ~net ~sw ~clock ~ip ~port ~pin = Log.info (fun f -> f "Starting pair setup with %s:%d" ip port); let m1 = Tlv.( empty |> add Tlv_type.state "\x01" |> add Tlv_type.method_ "\x00" |> encode) in let* m2_body = http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-setup" ~content_type:"application/pairing+tlv8" ~body:m1 in let m2 = Tlv.decode m2_body in match Tlv.get Tlv_type.error m2 with | Some e -> err_pair_setup e | None -> let salt = Tlv.get_exn Tlv_type.salt m2 in let big_b_bytes = Tlv.get_exn Tlv_type.public_key m2 in let big_b = Srp.z_of_bytes big_b_bytes in Log.info (fun f -> f "Received M2, salt=%d bytes, B=%d bytes" (String.length salt) (String.length big_b_bytes)); let srp_client = Srp.Client.v ~username:"Pair-Setup" ~password:pin in let* session_key = Srp.Client.compute_session_key srp_client ~salt ~big_b in srp_verify ~net ~sw ~clock ~ip ~port ~srp_client ~salt ~big_b ~session_key
let build_verify_m3 ~enc_key ~pairing ~kp ~accessory_pk = let sign_data = kp.X25519.public ^ pairing.controller_id ^ accessory_pk in let signature = Ed25519.sign ~secret:pairing.controller_ltsk sign_data in let sub_tlv = Tlv.( empty |> add Tlv_type.identifier pairing.controller_id |> add Tlv_type.signature signature |> encode) in let encrypted = chacha20_poly1305_encrypt ~key:enc_key ~nonce:"\x00\x00\x00\x00PV-Msg03" ~aad:"" sub_tlv in Tlv.( empty |> add Tlv_type.state "\x03" |> add Tlv_type.encrypted_data encrypted |> encode)
let derive_session_keys ~ip ~port ~shared = let enc_key = hkdf_sha512 ~salt:"Control-Salt" ~ikm:shared ~info:"Control-Write-Encryption-Key" ~length:32 in let dec_key = hkdf_sha512 ~salt:"Control-Salt" ~ikm:shared ~info:"Control-Read-Encryption-Key" ~length:32 in Log.info (fun f -> f "Pair verify successful, session established"); Ok { ip; port; encrypt_key = enc_key; decrypt_key = dec_key; encrypt_count = 0L; decrypt_count = 0L; }
let pair_verify_response ~net ~sw ~clock ~ip ~port ~pairing ~kp ~accessory_pk ~enc_key ~shared = let m3 = build_verify_m3 ~enc_key ~pairing ~kp ~accessory_pk in let* m4_body = http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-verify" ~content_type:"application/pairing+tlv8" ~body:m3 in let m4 = Tlv.decode m4_body in match Tlv.get Tlv_type.error m4 with | Some e -> err_pair_verify_m4 e | None -> derive_session_keys ~ip ~port ~shared
let verify_m2 ~pairing ~kp ~enc_key ~enc_data ~accessory_pk = let* decrypted = chacha20_poly1305_decrypt ~key:enc_key ~nonce:"\x00\x00\x00\x00PV-Msg02" ~aad:"" enc_data in let sub_tlv = Tlv.decode decrypted in let accessory_id = Tlv.get_exn Tlv_type.identifier sub_tlv in let accessory_sig = Tlv.get_exn Tlv_type.signature sub_tlv in if accessory_id <> pairing.accessory_id then Error (`Msg "Accessory ID mismatch") else let verify_data = accessory_pk ^ accessory_id ^ kp.X25519.public in if not (Ed25519.verify ~public:pairing.accessory_ltpk ~signature:accessory_sig verify_data) then Error (`Msg "Accessory signature verification failed") else Ok ()
let pair_verify ~net ~sw ~clock ~ip ~port ~pairing = Log.info (fun f -> f "Starting pair verify with %s:%d" ip port); let kp = X25519.generate () in let m1 = Tlv.( empty |> add Tlv_type.state "\x01" |> add Tlv_type.public_key kp.public |> encode) in let* m2_body = http_post ~net ~clock ~sw ~ip ~port ~path:"/pair-verify" ~content_type:"application/pairing+tlv8" ~body:m1 in let m2 = Tlv.decode m2_body in match Tlv.get Tlv_type.error m2 with | Some e -> err_pair_verify_m2 e | None -> let accessory_pk = Tlv.get_exn Tlv_type.public_key m2 in let enc_data = Tlv.get_exn Tlv_type.encrypted_data m2 in let* shared = X25519.shared_secret ~secret:kp.secret ~public:accessory_pk in let enc_key = hkdf_sha512 ~salt:"Pair-Verify-Encrypt-Salt" ~ikm:shared ~info:"Pair-Verify-Encrypt-Info" ~length:32 in let* () = verify_m2 ~pairing ~kp ~enc_key ~enc_data ~accessory_pk in pair_verify_response ~net ~sw ~clock ~ip ~port ~pairing ~kp ~accessory_pk ~enc_key ~shared
let request ~net ~sw session req = let encrypted = encrypt_frame session req in let addr = `Tcp (ipv4_of_string session.ip, session.port) in let flow = Eio.Net.connect ~sw net addr in Eio.Flow.copy_string encrypted flow; let buf = Buffer.create 4096 in let rec read () = let chunk = Cstruct.create 1024 in match Eio.Flow.single_read flow chunk with | n -> Buffer.add_string buf (Cstruct.to_string (Cstruct.sub chunk 0 n)); read () | exception End_of_file -> () in read (); Eio.Flow.close flow; decrypt_frame session (Buffer.contents buf)
let parse_json_response decrypted = match Re.(exec_opt (compile (str "\r\n\r\n")) decrypted) with | None -> Error (`Msg "Invalid response") | Some g -> let pos = Re.Group.stop g 0 in let body = String.sub decrypted pos (String.length decrypted - pos) in Result.map_error (fun e -> `Msg (Json.Error.to_string e)) (Json.Value.of_string body)
let accessories ~net ~sw session = let path = "/accessories" in let req = Fmt.str "GET %s HTTP/1.1\r\nHost: %s:%d\r\n\r\n" path session.ip session.port in let* decrypted = request ~net ~sw session req in parse_json_response decrypted
type char_write = { aid : int; iid : int; value : Json.t }
let char_write_codec = let open Json.Codec in Object.map ~kind:"char_write" (fun aid iid value -> { aid; iid; value }) |> Object.member "aid" int ~enc:(fun c -> c.aid) |> Object.member "iid" int ~enc:(fun c -> c.iid) |> Object.member "value" Value.t ~enc:(fun c -> c.value) |> Object.seal
type char_write_request = { characteristics : char_write list }
let char_write_request_codec = let open Json.Codec in Object.map ~kind:"char_write_request" (fun characteristics -> { characteristics }) |> Object.member "characteristics" (list char_write_codec) ~enc:(fun r -> r.characteristics) |> Object.seal
let put_characteristic ~net ~sw session ~aid ~iid value = let req = { characteristics = [ { aid; iid; value } ] } in let body = Json.to_string char_write_request_codec req in let path = "/characteristics" in let req = Fmt.str "PUT %s HTTP/1.1\r\n\ Host: %s:%d\r\n\ Content-Type: application/hap+json\r\n\ Content-Length: %d\r\n\ \r\n\ %s" path session.ip session.port (String.length body) body in let* _decrypted = request ~net ~sw session req in Ok ()
let characteristics ~net ~sw session ~ids = let ids_str = String.concat "," (List.map (fun (aid, iid) -> Fmt.str "%d.%d" aid iid) ids) in let path = Fmt.str "/characteristics?id=%s" ids_str in let req = Fmt.str "GET %s HTTP/1.1\r\nHost: %s:%d\r\n\r\n" path session.ip session.port in let* decrypted = request ~net ~sw session req in parse_json_response decrypted
let pairings_dir = ".hap/pairings"
let ensure_pairings_dir ~fs = let hap_path = Eio.Path.(fs / ".hap") in let pairings_path = Eio.Path.(fs / pairings_dir) in (try Eio.Path.mkdir ~perm:0o700 hap_path with Eio.Exn.Io _ -> ()); try Eio.Path.mkdir ~perm:0o700 pairings_path with Eio.Exn.Io _ -> ()
let sanitize_id id = String.map (fun c -> if c = ':' then '-' else c) id
let pairing_path_for_id device_id = Fmt.str "%s/hap-%s.json" pairings_dir (sanitize_id device_id)
module Pairing_json = struct type stored = { accessory_id : string; accessory_ltpk : string; controller_id : string; controller_ltsk : string; controller_ltpk : string; }
let stored = let open Json.Codec in Object.map ~kind:"hap.pairing" (fun accessory_id accessory_ltpk controller_id controller_ltsk controller_ltpk -> { accessory_id; accessory_ltpk; controller_id; controller_ltsk; controller_ltpk; }) |> Object.member "accessory_id" string ~enc:(fun p -> p.accessory_id) |> Object.member "accessory_ltpk" string ~enc:(fun p -> p.accessory_ltpk) |> Object.member "controller_id" string ~enc:(fun p -> p.controller_id) |> Object.member "controller_ltsk" string ~enc:(fun p -> p.controller_ltsk) |> Object.member "controller_ltpk" string ~enc:(fun p -> p.controller_ltpk) |> Object.seal
let of_pairing (p : pairing) : stored = { accessory_id = p.accessory_id; accessory_ltpk = Base64.encode_string p.accessory_ltpk; controller_id = p.controller_id; controller_ltsk = Base64.encode_string p.controller_ltsk; controller_ltpk = Base64.encode_string p.controller_ltpk; }
let to_pairing (s : stored) : pairing = { accessory_id = s.accessory_id; accessory_ltpk = Base64.decode_exn s.accessory_ltpk; controller_id = s.controller_id; controller_ltsk = Base64.decode_exn s.controller_ltsk; controller_ltpk = Base64.decode_exn s.controller_ltpk; }end
let save_pairing ~fs ~path (pairing : pairing) = let stored = Pairing_json.of_pairing pairing in let json = Json.to_string ~indent:2 Pairing_json.stored stored in Eio.Path.save ~create:(`Or_truncate 0o600) Eio.Path.(fs / path) json
let load_pairing ~fs ~path = let full_path = Eio.Path.(fs / path) in if not (Eio.Path.is_file full_path) then None else begin try let content = Eio.Path.load full_path in match Json.of_string Pairing_json.stored content with | Ok stored -> Some (Pairing_json.to_pairing stored) | Error _ -> None with Eio.Io _ -> None end
let save_pairing_by_id ~fs pairing = ensure_pairings_dir ~fs; let path = pairing_path_for_id pairing.accessory_id in save_pairing ~fs ~path pairing; path
let pairing_by_id ~fs device_id = let path = pairing_path_for_id device_id in load_pairing ~fs ~path
let category_name = function | 1 -> "Other" | 2 -> "Bridge" | 3 -> "Fan" | 4 -> "Garage Door Opener" | 5 -> "Lightbulb" | 6 -> "Door Lock" | 7 -> "Outlet" | 8 -> "Switch" | 9 -> "Thermostat" | 10 -> "Sensor" | 11 -> "Security System" | 12 -> "Door" | 13 -> "Window" | 14 -> "Window Covering" | 15 -> "Programmable Switch" | 16 -> "Range Extender" | 17 -> "IP Camera" | 18 -> "Video Doorbell" | 19 -> "Air Purifier" | 20 -> "Heater" | 21 -> "Air Conditioner" | 22 -> "Humidifier" | 23 -> "Dehumidifier" | 24 -> "Apple TV" | 25 -> "HomePod" | 26 -> "Speaker" | 27 -> "AirPort" | 28 -> "Sprinkler" | 29 -> "Faucet" | 30 -> "Shower Head" | 31 -> "Television" | 32 -> "Target Controller" | 33 -> "WiFi Router" | 34 -> "Audio Receiver" | 35 -> "TV Set Top Box" | 36 -> "TV Streaming Stick" | _ -> "Unknown"
let parse_hap_txt txt = let pairs = String.split_on_char ' ' txt in let find key = List.find_map (fun p -> match String.split_on_char '=' p with | [ k; v ] when k = key -> Some v | _ -> None) pairs in let find_int key = Option.bind (find key) int_of_string_opt in let device_id = find "id" in let model = find "md" in let config_num = find_int "c#" in let state_num = find_int "s#" in let category = find_int "ci" in let paired = find_int "sf" = Some 0 in (device_id, model, config_num, state_num, category, paired)
let build_device_info (r : Mdns.response) instance = match List.find_opt (fun (n, _, _) -> Domain_name.equal n instance) r.srvs with | None -> None | Some (_, port, target) -> let txt = List.find_map (fun (n, t) -> if Domain_name.equal n instance then Some t else None) r.txts |> Option.value ~default:[] |> String.concat " " in let ip = List.find_map (fun (n, ip) -> if Domain_name.equal n target then Some (Ipaddr.V4.to_string ip) else None) r.addrs |> Option.value ~default:(Domain_name.to_string target) in let device_id, model, config_num, state_num, category, paired = parse_hap_txt txt in let name = match Domain_name.get_label instance 0 with | Ok label -> label | Error _ -> Domain_name.to_string instance in Some { name; device_id = Option.value ~default:"" device_id; ip; port; model; config_num = Option.value ~default:0 config_num; state_num = Option.value ~default:0 state_num; category = Option.value ~default:0 category; paired; }
let discover ~sw ~net ~clock ?(timeout = 3.0) () = let service_name = Domain_name.of_string_exn "_hap._tcp.local" in let r = Mdns.merge (Mdns.query ~sw ~net ~clock ~timeout service_name) in let instances = List.filter_map (fun (service, instance) -> if Domain_name.equal service service_name then Some instance else None) r.ptrs |> List.sort_uniq Domain_name.compare in List.filter_map (build_device_info r) instances
let pairing_for_ip ~sw ~net ~clock ~fs ip = let devices = discover ~sw ~net ~clock ~timeout:2.0 () in match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with | None -> None | Some info -> if info.device_id = "" then None else pairing_by_id ~fs info.device_id
let accessory_info ~sw ~net ~clock ip = let devices = discover ~sw ~net ~clock ~timeout:2.0 () in List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices
let pp_accessory_info ppf info = let cat = category_name info.category in let status = if info.paired then "paired" else "unpaired" in Fmt.pf ppf "@[<v 0>%s@," info.name; Fmt.pf ppf " Type: %s@," cat; Fmt.pf ppf " Device ID: %s@," info.device_id; Fmt.pf ppf " Address: %s:%d@," info.ip info.port; Option.iter (fun m -> Fmt.pf ppf " Model: %s@," m) info.model; Fmt.pf ppf " Status: %s@," status; Fmt.pf ppf " Config: #%d, State: #%d@]" info.config_num info.state_num
module Hap_json = struct open Json.Codec
type characteristic = { iid : int; type_ : string; value : Json.t option }
let characteristic = Object.map ~kind:"hap.characteristic" (fun iid type_ value -> { iid; type_; value }) |> Object.member "iid" int ~enc:(fun c -> c.iid) |> Object.member "type" string ~enc:(fun c -> c.type_) |> Object.opt_member "value" Value.t ~enc:(fun c -> c.value) |> Object.seal
type service = { iid : int; type_ : string; characteristics : characteristic list; }
let service = Object.map ~kind:"hap.service" (fun iid type_ characteristics -> { iid; type_; characteristics }) |> Object.member "iid" int ~enc:(fun s -> s.iid) |> Object.member "type" string ~enc:(fun s -> s.type_) |> Object.member "characteristics" (list characteristic) ~enc:(fun s -> s.characteristics) |> Object.seal
type accessory = { aid : int; services : service list }
let accessory = Object.map ~kind:"hap.accessory" (fun aid services -> { aid; services }) |> Object.member "aid" int ~enc:(fun a -> a.aid) |> Object.member "services" (list service) ~enc:(fun a -> a.services) |> Object.seal
type accessories_response = { accessories : accessory list }
let accessories_response = Object.map ~kind:"hap.accessories_response" (fun accessories -> { accessories }) |> Object.member "accessories" (list accessory) ~enc:(fun r -> r.accessories) |> Object.seal
type char_value = { aid : int; iid : int; value : Json.t option }
let char_value = Object.map ~kind:"hap.char_value" (fun aid iid value -> { aid; iid; value }) |> Object.member "aid" int ~enc:(fun c -> c.aid) |> Object.member "iid" int ~enc:(fun c -> c.iid) |> Object.opt_member "value" Value.t ~enc:(fun c -> c.value) |> Object.seal
type characteristics_response = { characteristics : char_value list }
let characteristics_response = Object.map ~kind:"hap.characteristics_response" (fun characteristics -> { characteristics }) |> Object.member "characteristics" (list char_value) ~enc:(fun r -> r.characteristics) |> Object.sealend
module Char_type = struct let on = "25" (* 00000025-0000-1000-8000-0026BB765291 *)end
let decode codec json = Json.of_string codec (Json.Value.to_string json)
let on_characteristic aid (chr : Hap_json.characteristic) = if String.lowercase_ascii chr.type_ = Char_type.on then Some (aid, chr.iid) else None
let on_service aid (svc : Hap_json.service) = List.find_map (on_characteristic aid) svc.characteristics
let on_accessory (acc : Hap_json.accessory) = List.find_map (on_service acc.aid) acc.services
let on_characteristic_iid json = match decode Hap_json.accessories_response json with | Error _ -> None | Ok resp -> List.find_map on_accessory resp.accessories
let outlet_pairing ~missing_pairing ~net ~sw ~clock ~fs ~ip = let devices = discover ~sw ~net ~clock ~timeout:2.0 () in match List.find_opt (fun (d : accessory_info) -> d.ip = ip) devices with | None -> Error (`Msg "Device not found via HAP discovery") | Some info -> ( if info.device_id = "" then Error (`Msg "Device has no device_id") else match pairing_by_id ~fs info.device_id with | None -> Error (`Msg missing_pairing) | Some pairing -> Ok (info, pairing))
let outlet_session ~missing_pairing ~net ~sw ~clock ~fs ~ip = let* info, pairing = outlet_pairing ~missing_pairing ~net ~sw ~clock ~fs ~ip in pair_verify ~net ~sw ~clock ~ip ~port:info.port ~pairing
let outlet_on_characteristic ~net ~sw session = let* accessories_json = accessories ~net ~sw session in match on_characteristic_iid accessories_json with | None -> Error (`Msg "Could not find On characteristic") | Some on -> Ok on
let control_outlet ~net ~sw ~clock ~fs ~ip ~value = let* session = outlet_session ~net ~sw ~clock ~fs ~ip ~missing_pairing:"No pairing found for device - run 'plug pair' first" in let* aid, iid = outlet_on_characteristic ~net ~sw session in put_characteristic ~net ~sw session ~aid ~iid (Json.Bool (value, Json.Meta.none))
let turn_on_outlet ~net ~sw ~clock ~fs ip = control_outlet ~net ~sw ~clock ~fs ~ip ~value:true
let turn_off_outlet ~net ~sw ~clock ~fs ip = control_outlet ~net ~sw ~clock ~fs ~ip ~value:false
let bool_value json = match decode Hap_json.characteristics_response json with | Error _ -> None | Ok (resp : Hap_json.characteristics_response) -> ( match resp.characteristics with | [ (c : Hap_json.char_value) ] -> ( match c.value with Some (Json.Bool (b, _)) -> Some b | _ -> None) | _ -> None)
let toggle_outlet ~net ~sw ~clock ~fs ip = let* session = outlet_session ~net ~sw ~clock ~fs ~ip ~missing_pairing:"No pairing found for device" in let* aid, iid = outlet_on_characteristic ~net ~sw session in let* chars_json = characteristics ~net ~sw session ~ids:[ (aid, iid) ] in match bool_value chars_json with | None -> Error (`Msg "Could not read current state") | Some v -> put_characteristic ~net ~sw session ~aid ~iid (Json.Bool (not v, Json.Meta.none))