App-OpenHAP
view release on metacpan or search on metacpan
t/conformance/hap-http.t view on Meta::CPAN
my $pos = 0;
while ( $pos < length($data) ) {
my $length = unpack( 'v', substr( $data, $pos, 2 ) );
my $aad = substr( $data, $pos, 2 );
$pos += 2;
my $ciphertext = substr( $data, $pos, $length );
$pos += $length;
my $tag = substr( $data, $pos, 16 );
$pos += 16;
my $nonce = pack( 'x[4]Q<', $state->{dec}++ );
my $plain =
Protocol::HAP::Crypto->chacha20poly1305_decrypt(
$ACC_TO_CTRL, $nonce, $ciphertext, $tag, $aad );
return unless defined $plain;
$out .= $plain;
}
return $out;
}
sub dispatch ( $hap, $method, $path, $body = undef, $session = undef )
{
$session //= verified_session($hap);
my $raw = Protocol::HAP::HTTP::build_request(
method => $method,
path => $path,
body => $body // '',
);
$raw = client_encrypt( $session, $raw ) if $session->is_encrypted;
$OUT{ $session->id } = '';
$hap->receive( $session, $raw );
my $response = delete $OUT{ $session->id };
$response = client_decrypt( $session, $response )
if $session->is_encrypted;
my ( $head, $resp_body ) = split /\r\n\r\n/, $response, 2;
my ($status) = $head =~ m{^HTTP/1\.1 (\d+)};
my %headers;
for my $line ( split /\r\n/, $head ) {
$headers{ lc $1 } = $2 if $line =~ /^([^:]+):\s*(.*)$/;
}
return ( $status, \%headers, $resp_body // '' );
}
# Find the aid/iid of a characteristic by short type in /accessories
sub find_char ( $accessories, $type )
{
for my $acc ( @{ $accessories->{accessories} } ) {
for my $svc ( @{ $acc->{services} } ) {
for my $char ( @{ $svc->{characteristics} } ) {
return ( $acc->{aid}, $char->{iid} )
if $char->{type} eq $type;
}
}
}
return;
}
subtest '[HAP-HTTP §1] endpoints require a verified session' => sub {
my $hap = make_hap();
my $unverified = $hap->session_open;
for my $probe (
[ 'POST', '/pairings' ],
[ 'GET', '/accessories' ],
[ 'GET', '/characteristics?id=1.1' ],
[ 'PUT', '/characteristics' ],
[ 'PUT', '/prepare' ],
)
{
my ( $status, undef, undef ) =
dispatch( $hap, @$probe, undef, $unverified );
is( $status, 470,
"[HAP-HTTP §13.4] @$probe returns 470 "
. 'without pair-verify' );
}
# Pairing endpoints do not need a verified session
my $m1 = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 0 ),
);
my ( $status, undef, undef ) =
dispatch( $hap, 'POST', '/pair-setup', $m1, $unverified );
is( $status, 200,
'[HAP-HTTP §4] POST /pair-setup open to unverified sessions'
);
# Pair-verify is also open and answers with TLV
my $pv_m1 = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_PublicKey(), 'X' x 32,
);
( $status, my $headers, undef ) =
dispatch( $hap, 'POST', '/pair-verify', $pv_m1, $unverified );
is( $status, 200,
'[HAP-HTTP §5] POST /pair-verify open to unverified sessions'
);
};
subtest '[HAP-HTTP §2] content types' => sub {
my $hap = make_hap();
my $m1 = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 0 ),
);
my ( undef, $headers, undef ) =
dispatch( $hap, 'POST', '/pair-setup', $m1,
$hap->session_open );
is( $headers->{'content-type'},
'application/pairing+tlv8',
'pairing endpoints use application/pairing+tlv8' );
( undef, $headers, undef ) = dispatch( $hap, 'GET', '/accessories' );
is( $headers->{'content-type'},
'application/hap+json',
'accessory endpoints use application/hap+json' );
};
subtest '[HAP-HTTP §3] POST /identify paired vs unpaired' => sub {
my $hap = make_hap();
my $unverified = $hap->session_open;
my ( $status, undef, undef ) =
dispatch( $hap, 'POST', '/identify', undef, $unverified );
is( $status, 204, 'unpaired identify returns 204 No Content' );
$hap->{store}->save_pairing( 'controller', 'X' x 32, 1 );
( $status, undef, my $body ) =
dispatch( $hap, 'POST', '/identify', undef, $unverified );
is( $status, 400, 'paired identify returns 400' );
is( $json->decode($body)->{status},
-70401, 'paired identify body is {"status":-70401}' );
};
subtest '[HAP-HTTP §7] GET /accessories structure' => sub {
my $hap = make_hap();
my ( $status, undef, $body ) =
dispatch( $hap, 'GET', '/accessories' );
is( $status, 200, 'returns 200 with body' );
my $data = $json->decode($body);
ok( ref $data->{accessories} eq 'ARRAY', 'accessories array' );
my ($bridge) = grep { $_->{aid} == 1 } @{ $data->{accessories} };
ok( $bridge, 'bridge accessory has aid 1' );
my ($heater) = grep { $_->{aid} == 2 } @{ $data->{accessories} };
ok( $heater, '[HAP-HTTP §7.1] accessory object has aid and services' );
ok( ref $heater->{services} eq 'ARRAY',
'[HAP-HTTP §7.1] services is an array' );
for my $svc ( @{ $heater->{services} } ) {
ok( defined $svc->{iid},
'[HAP-HTTP §7.2] service object has iid' );
ok( defined $svc->{type},
'[HAP-HTTP §7.2] service object has type' );
ok( ref $svc->{characteristics} eq 'ARRAY',
'[HAP-HTTP §7.2] service has characteristics array' );
}
# [HAP-HTTP §7.3] characteristic objects carry type, iid, perms,
# format, and value for readable characteristics
my ($char) =
grep { $_->{type} eq '25' }
map { @{ $_->{characteristics} } } @{ $heater->{services} };
ok( $char, 'found On characteristic object' );
ok( defined $char->{iid},
'[HAP-HTTP §7.3] characteristic has iid' );
ok( defined $char->{format},
'[HAP-HTTP §7.3] characteristic has format' );
ok( ref $char->{perms} eq 'ARRAY',
'[HAP-HTTP §7.3] characteristic has perms' );
ok( exists $char->{value},
'[HAP-HTTP §7.3] readable characteristic has value' );
};
subtest '[HAP-HTTP §8] GET /characteristics' => sub {
t/conformance/hap-http.t view on Meta::CPAN
subtest '[HAP-HTTP §9] PUT /characteristics' => sub {
my $hap = make_hap();
my ( undef, undef, $acc_body ) =
dispatch( $hap, 'GET', '/accessories' );
my ( $aid, $iid ) = find_char( $json->decode($acc_body), '25' );
# A successful write returns 204 No Content
my $put = $json->encode( { characteristics =>
[ { aid => $aid, iid => $iid, value => 1 } ] } );
my ( $status, undef, $body ) =
dispatch( $hap, 'PUT', '/characteristics', $put );
is( $status, 204,
'[HAP-HTTP §13.1][HAP-HTTP §16.2] successful write '
. 'returns 204 No Content' );
is( $body, '', '204 response has no body' );
# Write to nonexistent characteristic: 207 with -70409
$put = $json->encode( { characteristics =>
[ { aid => $aid, iid => 9999, value => 1 } ] } );
( $status, undef, $body ) =
dispatch( $hap, 'PUT', '/characteristics', $put );
is( $status, 207, 'partial failure returns 207 Multi-Status' );
is( $json->decode($body)->{characteristics}[0]{status},
-70409, 'unknown iid has status -70409' );
# Write to a read-only characteristic: -70404
my ( undef, $ro_iid ) = find_char( $json->decode($acc_body), '30' );
$put = $json->encode( { characteristics =>
[ { aid => $aid, iid => $ro_iid, value => 'x' } ] } );
( $status, undef, $body ) =
dispatch( $hap, 'PUT', '/characteristics', $put );
is( $status, 207, 'read-only write returns 207' );
is( $json->decode($body)->{characteristics}[0]{status},
-70404, 'read-only write has status -70404' );
# [HAP-HTTP §13.2] malformed JSON returns 400
( $status, undef, undef ) =
dispatch( $hap, 'PUT', '/characteristics', 'not json' );
is( $status, 400, 'malformed body returns 400 Bad Request' );
};
subtest '[HAP-HTTP §10] PUT /prepare timed write' => sub {
my $hap = make_hap();
my $session = verified_session($hap);
my $prepare = $json->encode( { ttl => 2500, pid => 11122333 } );
my ( $status, undef, $body ) =
dispatch( $hap, 'PUT', '/prepare', $prepare, $session );
is( $status, 200, 'prepare returns 200' );
is( $json->decode($body)->{status}, 0, 'prepare status 0' );
# Missing ttl/pid -> -70410 invalid value
( $status, undef, $body ) =
dispatch( $hap, 'PUT', '/prepare', '{}', $session );
is( $status, 400, 'missing ttl/pid rejected' );
is( $json->decode($body)->{status},
-70410, 'missing ttl/pid has status -70410' );
# The server also accepts POST. The spec shows POST in the
# endpoint table.
( $status, undef, undef ) =
dispatch( $hap, 'POST', '/prepare', $prepare, $session );
is( $status, 200, 'POST /prepare also accepted' );
};
subtest '[HAP-HTTP §6][HAP-Pairing §7][HAP-Pairing §7.1] add pairing' =>
sub {
my $hap = make_hap();
$hap->{store}->save_pairing( 'admin-ctrl', 'A' x 32, 1 );
$hap->{store}->save_pairing( 'user-ctrl', 'U' x 32, 0 );
my $add = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 3 ),
Protocol::HAP::Pairing::kTLVType_Identifier(), 'new-ctrl',
Protocol::HAP::Pairing::kTLVType_PublicKey(), 'N' x 32,
Protocol::HAP::Pairing::kTLVType_Permissions(), pack( 'C', 0 ),
);
# Non-admin controller -> 0x02 Authentication
my ( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$add, verified_session( $hap, 'user-ctrl' ) );
my %tlv = Protocol::HAP::TLV::decode($body);
is( unpack( 'C', $tlv{ Protocol::HAP::Pairing::kTLVType_Error() } ),
Protocol::HAP::Pairing::kTLVError_Authentication(),
'[HAP-Pairing §7.4] non-admin add rejected with 0x02' );
# Admin controller -> success M2
( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$add, verified_session( $hap, 'admin-ctrl' ) );
%tlv = Protocol::HAP::TLV::decode($body);
is( unpack( 'C', $tlv{ Protocol::HAP::Pairing::kTLVType_State() } ),
2, 'admin add returns M2' );
ok( !exists $tlv{ Protocol::HAP::Pairing::kTLVType_Error() },
'admin add succeeds' );
ok( exists $hap->{store}->load_pairings()->{'new-ctrl'},
'pairing stored' );
# Same identifier, different LTPK -> 0x01 Unknown
my $conflict = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 3 ),
Protocol::HAP::Pairing::kTLVType_Identifier(), 'new-ctrl',
Protocol::HAP::Pairing::kTLVType_PublicKey(), 'Z' x 32,
Protocol::HAP::Pairing::kTLVType_Permissions(), pack( 'C', 1 ),
);
( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$conflict, verified_session( $hap, 'admin-ctrl' ) );
%tlv = Protocol::HAP::TLV::decode($body);
is( unpack( 'C', $tlv{ Protocol::HAP::Pairing::kTLVType_Error() } ),
Protocol::HAP::Pairing::kTLVError_Unknown(),
'[HAP-Pairing §7.4] existing identifier with different '
. 'LTPK rejected with 0x01' );
# Same identifier, same LTPK -> permissions updated, success
my $update = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 3 ),
Protocol::HAP::Pairing::kTLVType_Identifier(), 'new-ctrl',
Protocol::HAP::Pairing::kTLVType_PublicKey(), 'N' x 32,
t/conformance/hap-http.t view on Meta::CPAN
( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$update, verified_session( $hap, 'admin-ctrl' ) );
%tlv = Protocol::HAP::TLV::decode($body);
ok( !exists $tlv{ Protocol::HAP::Pairing::kTLVType_Error() },
'matching LTPK updates permissions' );
is( $hap->{store}->load_pairings()->{'new-ctrl'}{permissions},
1, '[HAP-Pairing §6.1] permissions updated to admin (0x01)' );
};
subtest '[HAP-Pairing §7.2][HAP-Pairing §7.3] remove and list' => sub {
my $hap = make_hap();
$hap->{store}->save_pairing( 'admin-ctrl', 'A' x 32, 1 );
$hap->{store}->save_pairing( 'user-ctrl', 'U' x 32, 0 );
# List pairings (admin only)
my $list = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 5 ),
);
my ( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$list, verified_session( $hap, 'user-ctrl' ) );
my %tlv = Protocol::HAP::TLV::decode($body);
is( unpack( 'C', $tlv{ Protocol::HAP::Pairing::kTLVType_Error() } ),
Protocol::HAP::Pairing::kTLVError_Authentication(),
'[HAP-Pairing §7.4] non-admin list rejected with 0x02' );
( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$list, verified_session( $hap, 'admin-ctrl' ) );
like( $body, qr/admin-ctrl/, 'list contains admin identifier' );
like( $body, qr/user-ctrl/, 'list contains user identifier' );
like( $body, qr/\xFF\x00/,
'entries separated by zero-length 0xFF separator' );
# The removal of a pairing that does not exist returns success
my $remove_ghost = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 4 ),
Protocol::HAP::Pairing::kTLVType_Identifier(), 'ghost-ctrl',
);
( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$remove_ghost, verified_session( $hap, 'admin-ctrl' ) );
%tlv = Protocol::HAP::TLV::decode($body);
ok( !exists $tlv{ Protocol::HAP::Pairing::kTLVType_Error() },
'removing nonexistent pairing returns success' );
# The removal of the last admin clears all pairings
my $remove_admin = Protocol::HAP::TLV::encode(
Protocol::HAP::Pairing::kTLVType_State(), pack( 'C', 1 ),
Protocol::HAP::Pairing::kTLVType_Method(), pack( 'C', 4 ),
Protocol::HAP::Pairing::kTLVType_Identifier(), 'admin-ctrl',
);
( $status, undef, $body ) = dispatch( $hap, 'POST', '/pairings',
$remove_admin, verified_session( $hap, 'admin-ctrl' ) );
%tlv = Protocol::HAP::TLV::decode($body);
ok( !exists $tlv{ Protocol::HAP::Pairing::kTLVType_Error() },
'removing last admin succeeds' );
is( scalar keys %{ $hap->{store}->load_pairings() },
0, 'all pairings removed with the last admin' );
};
subtest '[HAP-HTTP §13][HAP-HTTP §13.2] unknown endpoint returns 404' =>
sub {
my $hap = make_hap();
my ( $status, undef, undef ) =
dispatch( $hap, 'GET', '/no-such-endpoint' );
is( $status, 404, 'unknown endpoint returns 404' );
};
subtest '[HAP-HTTP §15][HAP-HTTP §15.1] JSON value encoding' => sub {
my $hap = make_hap();
my ( undef, undef, $acc_body ) =
dispatch( $hap, 'GET', '/accessories' );
my ( $aid, $iid ) = find_char( $json->decode($acc_body), '25' );
# A bool encodes as JSON true/false, not 1/0
my ( undef, undef, $body ) =
dispatch( $hap, 'GET', "/characteristics?id=$aid.$iid" );
like( $body, qr/"value"\s*:\s*(?:true|false)/,
'bool value encodes as JSON boolean' );
my $put = $json->encode( { characteristics =>
[ { aid => $aid, iid => $iid, value => 1 } ] } );
dispatch( $hap, 'PUT', '/characteristics', $put );
( undef, undef, $body ) =
dispatch( $hap, 'GET', "/characteristics?id=$aid.$iid" );
like( $body, qr/"value"\s*:\s*true/, 'true after write of 1' );
# The string characteristics encode as JSON strings
my ( undef, $name_iid ) = find_char( $json->decode($acc_body), '23' );
( undef, undef, $body ) =
dispatch( $hap, 'GET', "/characteristics?id=$aid.$name_iid" );
like( $body, qr/"value"\s*:\s*"/, 'string value encodes as string' );
};
subtest '[HAP-HTTP §15.2] type coercion on write' => sub {
my $hap = make_hap();
my ( undef, undef, $acc_body ) =
dispatch( $hap, 'GET', '/accessories' );
my ( $aid, $iid ) = find_char( $json->decode($acc_body), '25' );
# JSON true and numeric 1 both write a bool characteristic
for my $value ( \1, 1 ) {
my $put = $json->encode( { characteristics =>
[ { aid => $aid, iid => $iid,
value => $value } ] } );
my ( $status, undef, undef ) =
dispatch( $hap, 'PUT', '/characteristics', $put );
is( $status, 204, 'bool write coerced and accepted' );
}
};
subtest '[HAP-HTTP §16][HAP-HTTP §16.3] event subscription via ev:true' =>
sub {
my $hap = make_hap();
my ( undef, undef, $acc_body ) =
dispatch( $hap, 'GET', '/accessories' );
my ( $aid, $iid ) = find_char( $json->decode($acc_body), '25' );
my $session = verified_session($hap);
my $put = $json->encode( { characteristics =>
[ { aid => $aid, iid => $iid, ev => \1 } ] } );
my ( $status, undef, undef ) =
dispatch( $hap, 'PUT', '/characteristics', $put, $session );
is( $status, 204, 'subscription write returns 204' );
ok( exists $hap->{event_subscriptions}{"$aid.$iid"}{ $session->id },
'session registered for events' );
( run in 2.521 seconds using v1.01-cache-2.11-cpan-9789f410c06 )