perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Align moderation errors and differential coverage with reference PDS
+172
-16
+11
-2
README.md
+11
-2
README.md
···
13
13
14
14
Reference differential validation:
15
15
16
-
- Run `script/differential-validate` to compare `perlds` against the official published `@atproto/pds` on a focused set of account, repo, sync, firehose, and `importRepo` snapshot-restore behaviors.
17
-
- Run `PERLDS_DIFF_ACCOUNT_DID_METHOD=did:plc script/differential-validate` to exercise the same harness in PLC-account mode, including recommended DID credentials, PLC signature requests, PLC handle updates, and token-gated PLC signing behavior.
16
+
- Run `script/differential-validate` to compare `perlds` against the official published `@atproto/pds` on a focused set of account, repo, moderation, sync, firehose, and `importRepo` snapshot-restore behaviors.
17
+
- Run `PERLDS_DIFF_ACCOUNT_DID_METHOD=did:plc script/differential-validate` to exercise the same harness in PLC-account mode, including recommended DID credentials, PLC signature requests, PLC handle updates, token-gated PLC signing behavior, and moderation checks after PLC handle changes.
18
18
- The helper installs the reference runtime into `.tools/reference-runtime` with Node 20 via `fnm`.
19
19
- Run `PERLDS_RUN_REFERENCE_DIFF=1 prove -lv t/reference-differential.t` to exercise the same harness from the test suite.
20
20
- Run `PERLDS_RUN_REFERENCE_DIFF=1 prove -lv t/reference-differential-plc.t` to run the PLC-specific reference comparison from the test suite.
21
+
22
+
Moderation and labels:
23
+
24
+
- `com.atproto.admin.updateSubjectStatus` now enforces repo, record, and blob takedowns as real behavior instead of passive metadata.
25
+
- Repo takedowns block ordinary login, repo writes, and public repo reads. `allowTakendown` sessions are accepted for parity with the reference PDS, but those sessions still cannot write.
26
+
- Record takedowns hide records from `com.atproto.repo.getRecord` and `com.atproto.repo.listRecords`.
27
+
- Blob takedowns quarantine blob reads for the public while still permitting authenticated self/admin recovery access, and they block both duplicate blob uploads and new record writes that reference quarantined blobs.
28
+
- `com.atproto.label.queryLabels`, `com.atproto.label.subscribeLabels`, and `com.atproto.temp.fetchLabels` are backed by persisted local labels rather than synthesized snapshots. Admin takedowns emit `!hide` labels and restores emit negation events.
29
+
- Label query/stream behavior is covered by local regression tests in `t/labels.t`. The official reference PDS does not provide a like-for-like local labeler implementation to diff against, so direct upstream differential checks are focused on moderation semantics rather than label RPC parity.
21
30
22
31
Interop fixtures:
23
32
+7
-1
lib/ATProto/PDS/API/Repo.pm
+7
-1
lib/ATProto/PDS/API/Repo.pm
···
120
120
$registry->register('com.atproto.repo.listRecords', sub ($c, $endpoint) {
121
121
my $account = _resolve_repo($c, $c->param('repo'));
122
122
_xrpc_error(404, 'RepoNotFound', 'Repository was not found') unless $account;
123
-
assert_repo_readable($c, $account);
123
+
assert_repo_readable(
124
+
$c,
125
+
$account,
126
+
status => 400,
127
+
error => 'InvalidRequest',
128
+
message => 'Could not find repo: ' . ($c->param('repo') // q()),
129
+
);
124
130
my $page = _list_visible_records(
125
131
$c,
126
132
$account->{did},
+3
-3
lib/ATProto/PDS/Moderation.pm
+3
-3
lib/ATProto/PDS/Moderation.pm
···
91
91
sub assert_login_allowed ($c, $account, %opts) {
92
92
xrpc_error(403, 'AccountDeleted', 'Account has been deleted') if defined $account->{deleted_at};
93
93
if (is_repo_takedown($c, $account->{did}) && !$opts{allow_takedown}) {
94
-
xrpc_error(403, 'AccountTakedown', 'Account has been taken down');
94
+
xrpc_error(401, 'AccountTakedown', 'Account has been taken down');
95
95
}
96
96
if (defined $account->{deactivated_at} && !$opts{allow_deactivated}) {
97
-
xrpc_error(403, 'AccountDeactivated', 'Account is deactivated');
97
+
xrpc_error(401, 'AccountDeactivated', 'Account is deactivated');
98
98
}
99
99
return 1;
100
100
}
···
124
124
125
125
sub assert_repo_writable ($c, $account) {
126
126
if (is_repo_takedown($c, $account->{did}) || defined $account->{deactivated_at}) {
127
-
xrpc_error(401, 'InvalidToken', 'Bad token scope');
127
+
xrpc_error(400, 'InvalidToken', 'Bad token scope');
128
128
}
129
129
return 1;
130
130
}
+147
-6
script/differential-validate
+147
-6
script/differential-validate
···
11
11
use File::Temp qw(tempdir);
12
12
use IO::Socket::INET;
13
13
use JSON::PP ();
14
+
use MIME::Base64 qw(encode_base64);
14
15
use POSIX qw(WNOHANG);
15
16
use Time::HiRes qw(sleep time);
16
17
···
195
196
196
197
sub auth_header ($token) {
197
198
return { Authorization => "Bearer $token" };
199
+
}
200
+
201
+
sub admin_auth_header ($password) {
202
+
return {
203
+
Authorization => 'Basic ' . encode_base64("admin:$password", q()),
204
+
};
198
205
}
199
206
200
207
sub normalized_domains ($res) {
···
505
512
506
513
my %server = (
507
514
reference => {
508
-
origin => $reference_info->{origin},
509
-
handle => 'alice.test',
510
-
email => 'alice-ref@test.com',
515
+
origin => $reference_info->{origin},
516
+
handle => 'alice.test',
517
+
email => 'alice-ref@test.com',
518
+
admin_password => 'reference-admin-secret',
511
519
},
512
520
perlds => {
513
-
origin => "http://127.0.0.1:$perl_port",
514
-
handle => 'alice.test',
515
-
email => 'alice-perl@test.com',
521
+
origin => "http://127.0.0.1:$perl_port",
522
+
handle => 'alice.test',
523
+
email => 'alice-perl@test.com',
524
+
admin_password => 'perlds-admin-secret',
516
525
},
517
526
);
518
527
···
672
681
next unless $res->is_success;
673
682
my $json = $res->json;
674
683
$server{$name}{record_uri} = $json->{uri};
684
+
$server{$name}{record_cid} = $json->{cid};
675
685
check(($json->{uri} // q()) =~ m{/app\.bsky\.feed\.post/diffpost\z}, "$name createRecord returns the expected record URI");
676
686
check(defined $json->{cid} && length $json->{cid}, "$name createRecord returns a CID");
677
687
}
688
+
689
+
note('Comparing moderation takedown behavior');
690
+
for my $name (sort keys %server) {
691
+
my $res = post_json(
692
+
$server{$name}{origin},
693
+
'com.atproto.admin.updateSubjectStatus',
694
+
{
695
+
subject => {
696
+
'$type' => 'com.atproto.admin.defs#repoRef',
697
+
did => $server{$name}{did},
698
+
},
699
+
takedown => { applied => true },
700
+
},
701
+
admin_auth_header($server{$name}{admin_password}),
702
+
);
703
+
check($res->is_success, "$name repo takedown succeeds");
704
+
next unless $res->is_success;
705
+
706
+
my $blocked_login = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
707
+
identifier => $server{$name}{renamed_handle} || $server{$name}{handle},
708
+
password => 'hunter22',
709
+
});
710
+
my $allowed_login = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
711
+
identifier => $server{$name}{renamed_handle} || $server{$name}{handle},
712
+
password => 'hunter22',
713
+
allowTakendown => true,
714
+
});
715
+
716
+
my $blocked_write = $allowed_login->is_success
717
+
? post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
718
+
repo => $server{$name}{did},
719
+
collection => 'app.bsky.feed.post',
720
+
rkey => 'takedown-diff',
721
+
record => {
722
+
%{$record},
723
+
text => "takedown write validation for $name",
724
+
},
725
+
}, auth_header(($allowed_login->json || {})->{accessJwt}))
726
+
: undef;
727
+
728
+
my $blocked_list = get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
729
+
repo => $server{$name}{did},
730
+
collection => 'app.bsky.feed.post',
731
+
});
732
+
733
+
$server{$name}{repo_takedown} = {
734
+
login_blocked => $blocked_login->is_success ? 0 : 1,
735
+
login_error => ($blocked_login->json || {})->{error},
736
+
allow_login => $allowed_login->is_success ? 1 : 0,
737
+
write_blocked => ($blocked_write && !$blocked_write->is_success) ? 1 : 0,
738
+
write_error => $blocked_write ? (($blocked_write->json || {})->{error}) : undef,
739
+
list_blocked => $blocked_list->is_success ? 0 : 1,
740
+
list_error => ($blocked_list->json || {})->{error},
741
+
};
742
+
743
+
$res = post_json(
744
+
$server{$name}{origin},
745
+
'com.atproto.admin.updateSubjectStatus',
746
+
{
747
+
subject => {
748
+
'$type' => 'com.atproto.admin.defs#repoRef',
749
+
did => $server{$name}{did},
750
+
},
751
+
takedown => { applied => false },
752
+
},
753
+
admin_auth_header($server{$name}{admin_password}),
754
+
);
755
+
check($res->is_success, "$name repo takedown restore succeeds");
756
+
757
+
$res = post_json(
758
+
$server{$name}{origin},
759
+
'com.atproto.admin.updateSubjectStatus',
760
+
{
761
+
subject => {
762
+
'$type' => 'com.atproto.repo.strongRef',
763
+
uri => $server{$name}{record_uri},
764
+
cid => $server{$name}{record_cid},
765
+
},
766
+
takedown => { applied => true },
767
+
},
768
+
admin_auth_header($server{$name}{admin_password}),
769
+
);
770
+
check($res->is_success, "$name record takedown succeeds");
771
+
next unless $res->is_success;
772
+
773
+
my $record_uri = $server{$name}{record_uri};
774
+
my ($collection, $rkey) = $record_uri =~ m{at://[^/]+/([^/]+)/([^/?#]+)\z};
775
+
my $get_record = get_form($server{$name}{origin}, 'com.atproto.repo.getRecord', {
776
+
repo => $server{$name}{did},
777
+
collection => $collection,
778
+
rkey => $rkey,
779
+
});
780
+
my $list_records = get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
781
+
repo => $server{$name}{did},
782
+
collection => $collection,
783
+
});
784
+
785
+
my $records = $list_records->is_success ? ($list_records->json->{records} || []) : [];
786
+
my $record_hidden = !(grep { (($_->{uri} // q()) eq $record_uri) } @$records);
787
+
$server{$name}{record_takedown} = {
788
+
get_blocked => $get_record->is_success ? 0 : 1,
789
+
get_error => ($get_record->json || {})->{error},
790
+
list_hidden => $record_hidden ? 1 : 0,
791
+
list_success => $list_records->is_success ? 1 : 0,
792
+
};
793
+
794
+
$res = post_json(
795
+
$server{$name}{origin},
796
+
'com.atproto.admin.updateSubjectStatus',
797
+
{
798
+
subject => {
799
+
'$type' => 'com.atproto.repo.strongRef',
800
+
uri => $record_uri,
801
+
cid => $server{$name}{record_cid},
802
+
},
803
+
takedown => { applied => false },
804
+
},
805
+
admin_auth_header($server{$name}{admin_password}),
806
+
);
807
+
check($res->is_success, "$name record takedown restore succeeds");
808
+
}
809
+
810
+
check(
811
+
same_hash($server{reference}{repo_takedown}, $server{perlds}{repo_takedown}),
812
+
'repo takedown login and write semantics match the official reference PDS',
813
+
);
814
+
815
+
check(
816
+
same_hash($server{reference}{record_takedown}, $server{perlds}{record_takedown}),
817
+
'record takedown visibility semantics match the official reference PDS',
818
+
);
678
819
679
820
note('Comparing listRecords');
680
821
for my $name (sort keys %server) {
+4
-4
t/moderation.t
+4
-4
t/moderation.t
···
101
101
$t->post_ok('/xrpc/com.atproto.server.createSession' => json => {
102
102
identifier => 'alice.example.test',
103
103
password => 'hunter22',
104
-
})->status_is(403)
104
+
})->status_is(401)
105
105
->json_is('/error', 'AccountTakedown');
106
106
107
107
$t->post_ok('/xrpc/com.atproto.server.createSession' => json => {
···
123
123
text => 'blocked',
124
124
createdAt => '2026-03-10T00:00:01Z',
125
125
},
126
-
})->status_is(401)
126
+
})->status_is(400)
127
127
->json_is('/error', 'InvalidToken')
128
128
->json_is('/message', 'Bad token scope');
129
129
130
130
$t->get_ok(Mojo::URL->new('/xrpc/com.atproto.repo.listRecords')->query(
131
131
repo => $did,
132
132
collection => 'app.bsky.feed.post',
133
-
))->status_is(404)
134
-
->json_is('/error', 'RepoNotFound');
133
+
))->status_is(400)
134
+
->json_is('/error', 'InvalidRequest');
135
135
136
136
$t->post_ok('/xrpc/com.atproto.moderation.createReport' => {
137
137
Authorization => "Bearer $takedown_access",