perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Harden CID tag decoding failures
+113
-4
+7
-2
lib/ATProto/PDS/EventStream.pm
+7
-2
lib/ATProto/PDS/EventStream.pm
···
59
59
state $decoder = CBOR::XS->new->filter(sub {
60
60
my ($tag, $value) = @_;
61
61
if ($tag == 42 && !ref($value)) {
62
-
my $cid_bytes = substr($value, 1);
63
-
return ATProto::PDS::Repo::CID->from_bytes($cid_bytes);
62
+
return _decode_cid_tag_payload($value);
64
63
}
65
64
return;
66
65
});
67
66
return $decoder;
67
+
}
68
+
69
+
sub _decode_cid_tag_payload ($value) {
70
+
die 'invalid CID tag payload'
71
+
unless defined($value) && length($value) && substr($value, 0, 1) eq "\x00";
72
+
return ATProto::PDS::Repo::CID->from_bytes(substr($value, 1));
68
73
}
69
74
70
75
1;
+8
-2
lib/ATProto/PDS/Repo/DagCbor.pm
+8
-2
lib/ATProto/PDS/Repo/DagCbor.pm
···
35
35
state $decoder = CBOR::XS->new->filter(sub {
36
36
my ($tag, $value) = @_;
37
37
if ($tag == 42 && !ref($value)) {
38
-
my $cid_bytes = substr($value, 1);
39
-
return ATProto::PDS::Repo::CID->from_bytes($cid_bytes);
38
+
return _decode_cid_tag_payload($value);
40
39
}
41
40
return;
42
41
});
43
42
return $decoder;
43
+
}
44
+
45
+
sub _decode_cid_tag_payload {
46
+
my ($value) = @_;
47
+
die 'invalid CID tag payload'
48
+
unless defined($value) && length($value) && substr($value, 0, 1) eq "\x00";
49
+
return ATProto::PDS::Repo::CID->from_bytes(substr($value, 1));
44
50
}
45
51
46
52
sub _encode_value {
+83
t/event-stream.t
+83
t/event-stream.t
···
1
+
use v5.34;
2
+
use warnings;
3
+
4
+
use Config ();
5
+
use CBOR::XS ();
6
+
use File::Spec;
7
+
use FindBin qw($Bin);
8
+
use Test::More;
9
+
10
+
BEGIN {
11
+
require lib;
12
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
13
+
lib->import(
14
+
File::Spec->catdir($root, 'lib'),
15
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
16
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
17
+
);
18
+
}
19
+
20
+
use ATProto::PDS::EventStream qw(decode_frame encode_error_frame encode_info_frame encode_message_frame);
21
+
use ATProto::PDS::Repo::DagCbor qw(encode_dag_cbor);
22
+
use ATProto::PDS::Repo::CID;
23
+
24
+
my $cid = ATProto::PDS::Repo::CID->for_raw('event-stream');
25
+
26
+
my $message = encode_message_frame('#commit', {
27
+
seq => 7,
28
+
commit => $cid,
29
+
repo => 'did:web:example.test',
30
+
});
31
+
32
+
my $decoded = decode_frame($message);
33
+
is($decoded->{header}{op}, 1, 'message frames decode as op=1');
34
+
is($decoded->{header}{t}, '#commit', 'message frames preserve the type');
35
+
is($decoded->{body}{seq}, 7, 'message frames preserve the body payload');
36
+
ok($decoded->{body}{commit}->isa('ATProto::PDS::Repo::CID'), 'CID fields decode as CID objects');
37
+
is($decoded->{body}{commit}->to_string, $cid->to_string, 'decoded CID matches the encoded CID');
38
+
is($decoded->{consumed}, length($message), 'decode_frame reports the consumed message length');
39
+
40
+
my $info = decode_frame(encode_info_frame('OutdatedCursor', 'Cursor is too old'));
41
+
is($info->{header}{t}, '#info', 'info helpers emit #info frames');
42
+
is($info->{body}{name}, 'OutdatedCursor', 'info helpers preserve the info name');
43
+
is($info->{body}{message}, 'Cursor is too old', 'info helpers preserve the optional message');
44
+
45
+
my $error = decode_frame(encode_error_frame('FutureCursor', 'Cursor is too new'));
46
+
is($error->{header}{op}, -1, 'error helpers emit error frames');
47
+
is($error->{body}{error}, 'FutureCursor', 'error helpers preserve the error name');
48
+
is($error->{body}{message}, 'Cursor is too new', 'error helpers preserve the optional message');
49
+
50
+
my $trailing = decode_frame($message . 'junk');
51
+
is($trailing->{consumed}, length($message), 'decode_frame reports only the first frame when trailing bytes remain');
52
+
is($trailing->{body}{commit}->to_string, $cid->to_string, 'trailing bytes do not corrupt the decoded frame');
53
+
54
+
my $truncated_error = do {
55
+
my @warnings;
56
+
local $@;
57
+
local $SIG{__WARN__} = sub { push @warnings, @_ };
58
+
my $error = eval { decode_frame(substr($message, 0, length($message) - 1)); 1 } ? undef : $@;
59
+
is_deeply(\@warnings, [], 'truncated frames fail without decoder warnings');
60
+
$error;
61
+
};
62
+
ok($truncated_error, 'truncated frames are rejected');
63
+
64
+
my $invalid_cid_frame = encode_dag_cbor({
65
+
op => 1,
66
+
t => '#commit',
67
+
}) . CBOR::XS::encode_cbor({
68
+
commit => CBOR::XS::tag(42, ''),
69
+
repo => 'did:web:example.test',
70
+
seq => 8,
71
+
});
72
+
73
+
my $invalid_cid_error = do {
74
+
my @warnings;
75
+
local $@;
76
+
local $SIG{__WARN__} = sub { push @warnings, @_ };
77
+
my $error = eval { decode_frame($invalid_cid_frame); 1 } ? undef : $@;
78
+
is_deeply(\@warnings, [], 'invalid CID tag payloads fail without decoder warnings');
79
+
$error;
80
+
};
81
+
like($invalid_cid_error, qr/invalid CID tag payload/, 'invalid CID tag payloads are rejected cleanly');
82
+
83
+
done_testing;
+15
t/repo_formats.t
+15
t/repo_formats.t
···
1
1
use v5.34;
2
2
use warnings;
3
3
4
+
use CBOR::XS ();
4
5
use Config ();
5
6
use FindBin qw($Bin);
6
7
use File::Spec;
···
66
67
my $parsed = read_car($car);
67
68
is($parsed->{roots}[0]->to_string, $record_cid->to_string, 'car root roundtrip works');
68
69
ok(@{ $parsed->{blocks} } >= 2, 'car returns blocks');
70
+
71
+
my $invalid_cid_payload = CBOR::XS::encode_cbor({
72
+
link => CBOR::XS::tag(42, ''),
73
+
});
74
+
75
+
my $invalid_cid_error = do {
76
+
my @warnings;
77
+
local $@;
78
+
local $SIG{__WARN__} = sub { push @warnings, @_ };
79
+
my $error = eval { decode_dag_cbor($invalid_cid_payload); 1 } ? undef : $@;
80
+
is(\@warnings, [], 'invalid DAG-CBOR CID tags fail without warnings');
81
+
$error;
82
+
};
83
+
like($invalid_cid_error, qr/invalid CID tag payload/, 'invalid DAG-CBOR CID tags are rejected cleanly');
69
84
70
85
done_testing;