perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
13
fork

Configure Feed

Select the types of activity you want to include in your feed.

Harden CID tag decoding failures

alice ffd539e4 61f0257c

+113 -4
+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
··· 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
··· 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
··· 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;