App-OpenHAP
view release on metacpan or search on metacpan
lib/Protocol/HAP/Server.pm view on Meta::CPAN
# ex:ts=8 sw=4:
# $OpenBSD$
#
# Copyright (c) 2026 Dick Olsson <hi@senzilla.io>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
use v5.36;
package Protocol::HAP::Server;
our $VERSION = '0.1.0';
use JSON::PP;
use MIME::Base64 qw(encode_base64);
use Digest::SHA qw(sha512);
use Protocol::HAP;
use Protocol::HAP::HTTP;
use Protocol::HAP::TLV;
use Protocol::HAP::Session;
use Protocol::HAP::Pairing;
use Protocol::HAP::Crypto;
use Protocol::HAP::Bridge;
use Protocol::HAP::Characteristic;
use Protocol::HAP::SetupCode qw(normalize_setup_code);
# Protocol::HAP::Server - the sans-IO HAP accessory-server engine.
#
# The engine consumes bytes and emits bytes. The host owns sockets,
# timers, logging, and persistence, injected through the contracts
# that Protocol/HAP.pod documents. The engine owns everything that is
# protocol: the read buffer and its bound, decryption, HTTP parsing,
# endpoint dispatch, the pairing state machines, the accessory
# database, and event delivery.
# The largest request the engine accepts: the header block plus the
# body that Content-Length declares. An unpaired client reaches
# /pair-setup, so the buffer of an unauthenticated connection needs a
# bound of its own. A HAP request is a small TLV or a short JSON
# document, so 64 KB is far above anything a controller sends.
use constant MAX_REQUEST_SIZE => 65536;
# The HAP status code for a request that arrives on an unverified
# connection [HAP-HTTP]. It is not an RFC 9110 code, so the codec does
# not know its reason phrase.
use constant STATUS_INSUFFICIENT_PRIVILEGES => 470;
# Characteristic types exempt from coalescing (HAP-HTTP.md §14):
# ProgrammableSwitchEvent (0x73), ButtonEvent (0x126),
# MotionDetected (0x22), ContactSensorState (0x6A)
use constant IMMEDIATE_EVENT_TYPES => {
'73' => 1,
'126' => 1,
'22' => 1,
'6A' => 1,
};
# Event coalescing delay in seconds (HAP-HTTP.md §14)
use constant EVENT_COALESCE_DELAY => 0.250;
# _response(%args):
# Build a response with the HAP defaults: the connection stays
# open, because a controller sends every request of a session
# over one connection.
sub _response (%args)
{
my %headers = %{ $args{headers} // {} };
$headers{Connection} //= 'keep-alive';
return Protocol::HAP::HTTP::build_response( %args,
headers => \%headers );
}
# _tlv_response($body):
# A 200 response with the pairing TLV content type. Every
# pairing and pairings-management reply uses it.
sub _tlv_response ($body)
{
return _response(
status => 200,
headers => { 'Content-Type' => 'application/pairing+tlv8' },
body => $body,
);
}
# _char_status($aid, $iid, $code):
# One per-characteristic result entry for the characteristics
# endpoints [HAP-HTTP].
sub _char_status ( $aid, $iid, $code )
{
return { aid => $aid + 0, iid => $iid + 0, status => $code };
}
# $class->new(%args):
# name, pin, setup_id, category - the accessory identity.
# store, logger, output, after, cancel, on_pairing_changed - the
# host contracts of Protocol/HAP.pod. store and output are
# required; after and cancel are optional, and without them the
# host calls flush_events itself.
sub new ( $class, %args )
{
my $pin = normalize_setup_code( $args{pin} )
// die 'valid pin required';
my $store = $args{store} // die 'store required';
my $output = $args{output} // die 'output required';
my $self = bless {
pin => $pin,
name => $args{name} // 'OpenHAP Bridge',
setup_id => $args{setup_id}, # Optional 4-char setup ID
category => $args{category} // 2, # Bridge
# The host contracts
store => $store,
logger => $args{logger} // Protocol::HAP->null_logger,
output => $output,
after => $args{after},
cancel => $args{cancel},
on_pairing_changed => $args{on_pairing_changed},
bridge => undef,
pairing => undef,
accessory_ltsk => undef,
accessory_ltpk => undef,
# Session ids come from an instance counter. Two engines
# in one process never share one.
next_session_id => 1,
event_subscriptions => {}, # Track event subscriptions
event_queue => {}, # Queued events for coalescing
event_flush_timer => undef, # The pending flush, if any
# utf8 mode: the codec takes and returns octets, never
# wide-character strings. The wire carries octets, the
# AEAD layer refuses wide characters, and Content-Length
# counts bytes. Without this flag, a non-ASCII value
# breaks all three.
json => JSON::PP->new->utf8,
}, $class;
$self->_initialize;
return $self;
}
sub _initialize ($self)
lib/Protocol/HAP/Server.pm view on Meta::CPAN
}
# $self->session_close($session):
# Release what the session holds: the pairing lock and its event
# subscriptions. The host calls this when it closes the
# connection.
sub session_close ( $self, $session )
{
$self->{pairing}->clear_pairing_state($session);
$self->_purge_event_subscriptions($session);
return;
}
# $self->_serve_request($session, $message, $was_encrypted):
# Dispatch one whole request and emit its response.
sub _serve_request ( $self, $session, $message, $was_encrypted )
{
my $request = Protocol::HAP::HTTP::parse_request($message);
unless ( defined $request ) {
$self->{logger}->warning('Malformed request');
$request =
{ method => '', path => '', headers => {}, body => '' };
}
$self->{logger}
->info( 'HTTP %s %s', $request->{method}, $request->{path} );
# Dispatch the request
my $response = $self->_dispatch( $request, $session );
# Encrypt the response only if the session was encrypted
# when the request arrived. See the note above.
if ($was_encrypted) {
$response = $session->encrypt($response);
}
$self->{output}->( $session, $response );
# Tell the host if this request changed the pairing state
$self->_notify_pairing_changed;
return;
}
# $self->_notify_pairing_changed:
# Call on_pairing_changed when the paired state flips. The host
# re-advertises its mDNS TXT record [HAP-mDNS §8].
sub _notify_pairing_changed ($self)
{
my $paired = $self->is_paired ? 1 : 0;
return if $self->{last_paired_state} == $paired;
$self->{last_paired_state} = $paired;
$self->{on_pairing_changed}->($paired)
if $self->{on_pairing_changed};
return;
}
# --- endpoint dispatch ----------------------------------------------------
sub _dispatch ( $self, $request, $session )
{
my $path = $request->{path};
my $method = $request->{method};
# Pairing endpoints. These need no verified session.
if ( $path eq '/pair-setup' && $method eq 'POST' ) {
return $self->_handle_pair_setup( $request, $session );
}
if ( $path eq '/pair-verify' && $method eq 'POST' ) {
return $self->_handle_pair_verify( $request, $session );
}
# Identify endpoint. It is for unpaired accessories only.
if ( $path eq '/identify' && $method eq 'POST' ) {
return $self->_handle_identify( $request, $session );
}
# All other endpoints need a verified session. The 470 code
# carries a reason phrase that only HAP defines, so the codec
# does not know it.
unless ( $session->is_verified ) {
return _response(
status => STATUS_INSUFFICIENT_PRIVILEGES,
status_text => 'Connection Authorization Required',
headers => { 'Content-Type' => 'application/hap+json' },
);
}
# Pairings management
if ( $path eq '/pairings' && $method eq 'POST' ) {
return $self->_handle_pairings( $request, $session );
}
# Accessory endpoints
if ( $path eq '/accessories' && $method eq 'GET' ) {
return $self->_handle_accessories( $request, $session );
}
# Remove the query string for path matching
my $base_path = $path;
$base_path =~ s/\?.*//;
if ( $base_path eq '/characteristics' && $method eq 'GET' ) {
return $self->_handle_characteristics_get( $request, $session );
}
if ( $base_path eq '/characteristics' && $method eq 'PUT' ) {
return $self->_handle_characteristics_put( $request, $session );
}
# Timed write preparation. The spec shows POST in the
# table, but the later text uses PUT. Accept both.
if ( $path eq '/prepare' && ( $method eq 'PUT' || $method eq 'POST' ) )
{
return $self->_handle_prepare( $request, $session );
}
# Not found
return _response(
status => 404,
headers => { 'Content-Type' => 'text/plain' },
body => 'Not Found',
);
}
sub _handle_pair_setup ( $self, $request, $session )
{
$self->{logger}->debug('Handling pair-setup request');
return _tlv_response( $self->{pairing}
->handle_pair_setup( $request->{body}, $session ) );
}
sub _handle_pair_verify ( $self, $request, $session )
{
$self->{logger}->debug('Handling pair-verify request');
return _tlv_response( $self->{pairing}
->handle_pair_verify( $request->{body}, $session ) );
}
sub _handle_accessories ( $self, $, $ )
{
my $json = $self->{json}->encode( $self->{bridge}->to_json );
return _response(
status => 200,
headers => { 'Content-Type' => 'application/hap+json' },
body => $json,
);
}
# $self->_resolve_char($aid, $iid):
# The accessory-then-characteristic lookup that both
# characteristics endpoints perform.
sub _resolve_char ( $self, $aid, $iid )
{
my $accessory = $self->{bridge}->get_accessory($aid);
return unless $accessory;
return $accessory->get_characteristic($iid);
}
sub _handle_characteristics_get ( $self, $request, $ )
{
# Parse the query string: ?id=1.11,1.13&meta=1&perms=1&type=1&ev=1
my $query = $request->{path};
$query =~ s/^.*\?//;
$self->{logger}->debug( 'Reading characteristics: %s', $query );
my %params;
for my $pair ( split /&/, $query ) {
my ( $key, $value ) = split /=/, $pair, 2;
$params{$key} = $value;
}
my @ids = split /,/, ( $params{id} // '' );
my $include_meta = $params{meta} // 0;
my $include_perms = $params{perms} // 0;
my $include_type = $params{type} // 0;
my $include_ev = $params{ev} // 0;
my @characteristics;
my $has_errors = 0;
for my $id (@ids) {
my ( $aid, $iid ) = split /\./, $id;
my $char = $self->_resolve_char( $aid, $iid );
unless ($char) {
push @characteristics,
_char_status( $aid, $iid, -70409 );
$has_errors = 1;
next;
}
my $result = {
aid => $aid + 0,
iid => $iid + 0,
value => $char->json_value,
};
# Add the optional metadata if the controller requests it
if ($include_meta) {
$result->{format} = $char->{format};
$result->{unit} = $char->{unit}
if defined $char->{unit};
$result->{minValue} = $char->{min}
if defined $char->{min};
$result->{maxValue} = $char->{max}
if defined $char->{max};
$result->{minStep} = $char->{step}
if defined $char->{step};
}
lib/Protocol/HAP/Server.pm view on Meta::CPAN
# Success for this characteristic
push @results, _char_status( $aid, $iid, 0 );
}
# Return 204 No Content when all writes succeed
return _response( status => 204 )
unless $has_errors;
# Return 207 Multi-Status with details if some writes fail
my $json = $self->{json}->encode( { characteristics => \@results } );
return _response(
status => 207,
headers => { 'Content-Type' => 'application/hap+json' },
body => $json,
);
}
sub _handle_identify ( $self, $, $ )
{
# Identify is only for unpaired accessories
if ( $self->is_paired ) {
return _response(
status => 400,
headers => { 'Content-Type' => 'application/hap+json' },
body => $self->{json}->encode( { status => -70401 } ),
);
}
$self->{logger}->info('Identify request received (unpaired)');
return _response( status => 204 );
}
sub _handle_pairings ( $self, $request, $session )
{
my %tlv = Protocol::HAP::TLV::decode( $request->{body} );
my $method_raw = $tlv{ Protocol::HAP::Pairing::kTLVType_Method() };
my $method = defined $method_raw ? unpack( 'C', $method_raw ) : -1;
$self->{logger}->debug( 'Pairings request method=%d', $method );
# Method values: 3=Add, 4=Remove, 5=List
if ( $method == 3 ) {
return $self->_handle_add_pairing( \%tlv, $session );
}
elsif ( $method == 4 ) {
return $self->_handle_remove_pairing( \%tlv, $session );
}
elsif ( $method == 5 ) {
return $self->_handle_list_pairings( \%tlv, $session );
}
# Unknown method
return $self->_pairings_error(
Protocol::HAP::Pairing::kTLVError_Unknown() );
}
# $self->_pairings_error($code):
# One failure response for the pairings endpoints.
sub _pairings_error ( $self, $code )
{
return _tlv_response(
Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(),
pack( 'C', 2 ),
Protocol::HAP::Pairing::kTLVType_Error(),
pack( 'C', $code ),
) );
}
# $self->_require_admin($session):
# The admin check of the pairings endpoints (HAP-Pairing.md §7).
# Return the loaded pairings when the session's controller is an
# admin, or undef.
sub _require_admin ( $self, $session )
{
my $pairings = $self->{store}->load_pairings;
my $current = $pairings->{ $session->controller_id };
return unless $current && $current->{permissions};
return $pairings;
}
sub _handle_add_pairing ( $self, $tlv, $session )
{
my $identifier =
$tlv->{ Protocol::HAP::Pairing::kTLVType_Identifier() };
my $ltpk = $tlv->{ Protocol::HAP::Pairing::kTLVType_PublicKey() };
my $perms = unpack( 'C',
$tlv->{ Protocol::HAP::Pairing::kTLVType_Permissions() }
// "\x00" );
$self->{logger}
->debug( 'Add pairing request for: %s', $identifier // 'unknown' );
# Only admins can add pairings
my $pairings = $self->_require_admin($session);
unless ($pairings) {
return $self->_pairings_error(
Protocol::HAP::Pairing::kTLVError_Authentication() );
}
# An existing identifier with a different LTPK is an error.
# With a matching LTPK, the server updates only the
# permissions (HAP-Pairing.md §7.4).
my $existing = $pairings->{$identifier};
if ( $existing && $existing->{ltpk} ne $ltpk ) {
return $self->_pairings_error(
Protocol::HAP::Pairing::kTLVError_Unknown() );
}
# Save the pairing
$self->{store}->save_pairing( $identifier, $ltpk, $perms );
$self->{logger}
->info( 'Added pairing for controller: %s', $identifier );
return _tlv_response(
Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(),
pack( 'C', 2 ),
) );
}
sub _handle_remove_pairing ( $self, $tlv, $session )
{
my $identifier =
$tlv->{ Protocol::HAP::Pairing::kTLVType_Identifier() };
$self->{logger}->debug( 'Remove pairing request for: %s',
$identifier // 'unknown' );
unless ( $self->_require_admin($session) ) {
( run in 0.331 second using v1.01-cache-2.11-cpan-9789f410c06 )