perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
1#!/usr/bin/env perl
2use v5.34;
3use warnings;
4use feature 'signatures';
5no warnings 'experimental::signatures';
6
7use Config ();
8use DBI ();
9use File::Basename qw(dirname);
10use File::Path qw(make_path);
11use File::Spec;
12use File::Temp qw(tempdir);
13use IO::Socket::INET;
14use JSON::PP ();
15use MIME::Base64 qw(decode_base64);
16use POSIX qw(WNOHANG);
17use Time::HiRes qw(sleep time);
18
19BEGIN {
20 require lib;
21 my $root = File::Spec->rel2abs(File::Spec->catdir(dirname(__FILE__), '..'));
22 lib->import(
23 File::Spec->catdir($root, 'lib'),
24 File::Spec->catdir($root, 'local', 'lib', 'perl5'),
25 File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
26 );
27}
28
29use Mojo::JSON qw(decode_json encode_json true false);
30use Mojo::UserAgent;
31use ATProto::PDS::Repo::CAR qw(read_car);
32use ATProto::PDS::Repo::DagCbor qw(decode_dag_cbor);
33use ATProto::PDS::Test::Differential::Firehose qw(
34 first_frame
35 frames_until_quiet
36 next_commit_frame
37 quiet_firehose
38);
39use ATProto::PDS::Test::Differential::HTTP qw(
40 admin_auth_header
41 auth_header
42 get_form
43 get_json
44 get_json_url
45 post_bytes
46 post_empty
47 post_json
48);
49
50sub normalize_swap_message ($message) {
51 return 'record-at-cid' if ($message // q()) =~ /\ARecord was at b/i;
52 return 'record-at-null' if ($message // q()) eq 'Record was at null';
53 return 'commit-at-cid' if ($message // q()) =~ /\ACommit was at b/i;
54 return 'commit-at-null' if ($message // q()) eq 'Commit was at null';
55 return $message // q();
56}
57
58my $root = File::Spec->rel2abs(File::Spec->catdir(dirname(__FILE__), '..'));
59my $tmp = tempdir(CLEANUP => 1);
60my @children;
61my $failed = 0;
62
63END {
64 my $status = $?;
65 for my $child (reverse @children) {
66 next unless $child->{pid};
67 my $alive = kill 0, $child->{pid};
68 next unless $alive;
69 kill 'TERM', $child->{pid};
70 for (1 .. 40) {
71 my $done = waitpid($child->{pid}, WNOHANG);
72 last if $done == $child->{pid};
73 sleep 0.1;
74 }
75 kill 'KILL', $child->{pid} if kill 0, $child->{pid};
76 waitpid($child->{pid}, 0);
77 }
78 $? = $status;
79}
80
81sub note ($message) {
82 print "$message\n";
83}
84
85sub pass ($message) {
86 print "ok - $message\n";
87}
88
89sub fail_check ($message) {
90 print "not ok - $message\n";
91 $failed++;
92}
93
94sub check ($condition, $message) {
95 if ($condition) {
96 pass($message);
97 } else {
98 fail_check($message);
99 }
100}
101
102sub free_port () {
103 my $sock = IO::Socket::INET->new(
104 LocalAddr => '127.0.0.1',
105 LocalPort => 0,
106 Proto => 'tcp',
107 Listen => 5,
108 ReuseAddr => 1,
109 ) or die "unable to allocate a free port: $!";
110 my $port = $sock->sockport;
111 close $sock;
112 return $port;
113}
114
115sub spawn_logged ($name, $cmd, $env, $log_path) {
116 open my $log_fh, '>', $log_path or die "unable to open $log_path: $!";
117 my $pid = fork;
118 die "unable to fork for $name: $!" unless defined $pid;
119
120 if ($pid == 0) {
121 chdir $root or die "unable to chdir to $root: $!";
122 open STDOUT, '>&', $log_fh or die "unable to redirect stdout for $name: $!";
123 open STDERR, '>&', $log_fh or die "unable to redirect stderr for $name: $!";
124 %ENV = (%ENV, %{$env // {}});
125 exec @{$cmd} or die "unable to exec $name: $!";
126 }
127
128 close $log_fh;
129 my $child = {
130 name => $name,
131 pid => $pid,
132 log => $log_path,
133 };
134 push @children, $child;
135 return $child;
136}
137
138sub slurp_file ($path) {
139 return q() unless -f $path;
140 open my $fh, '<', $path or return q();
141 local $/;
142 return <$fh> // q();
143}
144
145sub b64url_decode ($text) {
146 my $copy = $text // q();
147 $copy =~ tr/-_/+\//;
148 my $pad = length($copy) % 4;
149 $copy .= '=' x (4 - $pad) if $pad;
150 return decode_base64($copy);
151}
152
153sub jwt_claims ($jwt) {
154 my (undef, $claims_b64, undef) = split /\./, ($jwt // q()), 3;
155 return {} unless defined $claims_b64 && length $claims_b64;
156 return decode_json(b64url_decode($claims_b64));
157}
158
159sub wait_for_ready_file ($name, $path, $timeout = 30) {
160 my $deadline = time + $timeout;
161 while (time < $deadline) {
162 if (-f $path) {
163 return decode_json(slurp_file($path));
164 }
165 sleep 0.1;
166 }
167 die "timed out waiting for $name ready file $path\n";
168}
169
170sub wait_for_http_ok ($name, $url, $timeout = 30) {
171 my $ua = Mojo::UserAgent->new(max_redirects => 0);
172 my $deadline = time + $timeout;
173 while (time < $deadline) {
174 my $tx = eval { $ua->get($url) };
175 if ($tx) {
176 my $res = eval { $tx->result };
177 return $res if $res && $res->is_success;
178 }
179 sleep 0.2;
180 }
181 die "timed out waiting for $name at $url\n";
182}
183
184sub setup_reference_runtime () {
185 my @cmd = ($^X, File::Spec->catfile($root, 'script', 'setup-reference-runtime'));
186 system(@cmd) == 0 or die "reference runtime setup failed\n";
187}
188
189sub random_hex ($bytes) {
190 open my $fh, '<:raw', '/dev/urandom' or die "unable to read /dev/urandom: $!";
191 read($fh, my $buf, $bytes) == $bytes or die "unable to read $bytes bytes from /dev/urandom\n";
192 close $fh;
193 return unpack('H*', $buf);
194}
195
196sub normalized_domains ($res) {
197 my $json = $res->json || {};
198 return [ sort map { /^\./ ? $_ : ".$_" } @{ $json->{availableUserDomains} || [] } ];
199}
200
201sub normalize_commit_frame ($frame, $did) {
202 my $header = $frame->{header} || {};
203 my $body = $frame->{body} || {};
204 my $first = $body->{ops}[0] || {};
205 my $commit_prev_is_null = 0;
206 my $blocks_count = 0;
207 my $commit_block_present = 0;
208
209 if (defined $body->{commit} && defined $body->{blocks}) {
210 my $car = read_car($body->{blocks});
211 $blocks_count = scalar @{ $car->{blocks} || [] };
212 my ($commit_block) = grep {
213 $_->{cid}->to_string eq $body->{commit}->to_string
214 } @{ $car->{blocks} || [] };
215 if ($commit_block) {
216 $commit_block_present = 1;
217 my $commit = decode_dag_cbor($commit_block->{bytes});
218 $commit_prev_is_null = exists($commit->{prev}) && !defined($commit->{prev}) ? 1 : 0;
219 }
220 }
221
222 return {
223 op => $header->{op},
224 type => $header->{t},
225 repo_match => (($body->{repo} // q()) eq $did) ? 1 : 0,
226 action => $first->{action},
227 path => $first->{path},
228 ops_count => 0 + @{ $body->{ops} || [] },
229 cid_present => defined($first->{cid}) ? 1 : 0,
230 prev_present => defined($first->{prev}) ? 1 : 0,
231 prev_data_present => defined($body->{prevData}) ? 1 : 0,
232 has_blocks => length($body->{blocks} // q()) > 0 ? 1 : 0,
233 has_commit => defined $body->{commit} ? 1 : 0,
234 has_since => exists($body->{since}) ? 1 : 0,
235 since_is_stringish => !defined($body->{since}) || !ref($body->{since}) ? 1 : 0,
236 seq_is_int => defined($body->{seq}) && $body->{seq} =~ /\A\d+\z/ ? 1 : 0,
237 too_big => $body->{tooBig} ? 1 : 0,
238 blocks_count => $blocks_count,
239 commit_block_present => $commit_block_present,
240 commit_prev_is_null => $commit_prev_is_null,
241 };
242}
243
244sub normalize_repo_export ($car_bytes, $expected_root = undef) {
245 my $car = read_car($car_bytes // q());
246 my @roots = @{ $car->{roots} || [] };
247 my @blocks = @{ $car->{blocks} || [] };
248 my %block_cids = map { $_->{cid}->to_string => 1 } @blocks;
249 my $root = @roots ? $roots[0]->to_string : undef;
250 return {
251 roots_count => 0 + @roots,
252 blocks_count => 0 + @blocks,
253 root_present => defined($root) ? 1 : 0,
254 root_in_blocks => (defined($root) && $block_cids{$root}) ? 1 : 0,
255 root_matches_latest => (defined($root) && defined($expected_root) && $root eq $expected_root) ? 1 : 0,
256 };
257}
258
259sub normalize_bootstrap_frames ($frames, $did, $handle) {
260 return [
261 map {
262 my $header = $_->{header} || {};
263 my $body = $_->{body} || {};
264 my $type = $header->{t} // q();
265 my %normalized = (
266 type => $type,
267 );
268 if ($type eq '#identity') {
269 %normalized = (
270 %normalized,
271 did_match => (($body->{did} // q()) eq $did) ? 1 : 0,
272 handle_match => (($body->{handle} // q()) eq $handle) ? 1 : 0,
273 );
274 } elsif ($type eq '#account') {
275 %normalized = (
276 %normalized,
277 did_match => (($body->{did} // q()) eq $did) ? 1 : 0,
278 active => $body->{active} ? 1 : 0,
279 );
280 } elsif ($type eq '#commit') {
281 %normalized = (
282 %normalized,
283 repo_match => (($body->{repo} // q()) eq $did) ? 1 : 0,
284 ops_count => 0 + @{ $body->{ops} || [] },
285 has_blocks => length($body->{blocks} // q()) > 0 ? 1 : 0,
286 );
287 } elsif ($type eq '#sync') {
288 %normalized = (
289 %normalized,
290 did_match => (($body->{did} // q()) eq $did) ? 1 : 0,
291 has_blocks => length($body->{blocks} // q()) > 0 ? 1 : 0,
292 );
293 }
294 \%normalized;
295 } @$frames
296 ];
297}
298
299sub same_hash ($left, $right) {
300 my $json = JSON::PP->new->canonical(1)->allow_nonref(1);
301 return $json->encode($left) eq $json->encode($right);
302}
303
304sub normalize_did_doc ($doc, $expected_did, $expected_handle, $expected_origin) {
305 my @services = grep { (($_->{id} // q()) eq '#atproto_pds') || (($_->{id} // q()) =~ /atproto_pds\z/) } @{ $doc->{service} || [] };
306 my @methods = grep { (($_->{id} // q()) eq '#atproto') || (($_->{id} // q()) =~ /#atproto\z/) } @{ $doc->{verificationMethod} || [] };
307 my $service = $services[0] || {};
308 my $method = $methods[0] || {};
309 return {
310 id_matches => (($doc->{id} // q()) eq $expected_did) ? 1 : 0,
311 handle_matches => (((($doc->{alsoKnownAs} || [])->[0]) // q()) eq "at://$expected_handle") ? 1 : 0,
312 service_endpoint_ok => (($service->{serviceEndpoint} // q()) eq $expected_origin) ? 1 : 0,
313 service_type_ok => (($service->{type} // q()) eq 'AtprotoPersonalDataServer') ? 1 : 0,
314 verification_type_set => defined($method->{type}) && length($method->{type}) ? 1 : 0,
315 verification_key_set => defined($method->{publicKeyMultibase}) && ($method->{publicKeyMultibase} =~ /\Az/) ? 1 : 0,
316 };
317}
318
319sub normalize_plc_credentials ($json, $expected_handle, $expected_origin) {
320 return {
321 handle_matches => (((($json->{alsoKnownAs} || [])->[0]) // q()) eq "at://$expected_handle") ? 1 : 0,
322 verification_is_did => (($json->{verificationMethods}{atproto} // q()) =~ /\Adid:key:/) ? 1 : 0,
323 rotation_key_count => 0 + @{ $json->{rotationKeys} || [] },
324 all_rotation_are_did => @{ $json->{rotationKeys} || [] }
325 ? ((grep { ($_ // q()) =~ /\Adid:key:/ } @{ $json->{rotationKeys} || [] }) == @{ $json->{rotationKeys} || [] } ? 1 : 0)
326 : 0,
327 service_endpoint_ok => (($json->{services}{atproto_pds}{endpoint} // q()) eq $expected_origin) ? 1 : 0,
328 service_type_ok => (($json->{services}{atproto_pds}{type} // q()) eq 'AtprotoPersonalDataServer') ? 1 : 0,
329 };
330}
331
332sub normalize_signed_plc_operation ($json, $expected_handle, $expected_origin) {
333 my $op = $json->{operation} || {};
334 return {
335 type_ok => (($op->{type} // q()) eq 'plc_operation') ? 1 : 0,
336 handle_matches => (((($op->{alsoKnownAs} || [])->[0]) // q()) eq "at://$expected_handle") ? 1 : 0,
337 verification_is_did => (($op->{verificationMethods}{atproto} // q()) =~ /\Adid:key:/) ? 1 : 0,
338 rotation_key_count => 0 + @{ $op->{rotationKeys} || [] },
339 service_endpoint_ok => (($op->{services}{atproto_pds}{endpoint} // q()) eq $expected_origin) ? 1 : 0,
340 has_prev => defined($op->{prev}) && length($op->{prev}) ? 1 : 0,
341 has_sig => defined($op->{sig}) && length($op->{sig}) ? 1 : 0,
342 };
343}
344
345sub normalize_xrpc_error ($res) {
346 my $json = $res->json || {};
347 return {
348 status => $res->code,
349 error => $json->{error},
350 };
351}
352
353sub crawler_requests ($origin) {
354 my $res = get_json_url("$origin/requests");
355 die "crawler request log fetch failed for $origin\n" unless $res->is_success;
356 return $res->json || {};
357}
358
359sub wait_for_crawler_requests ($name, $origin, $minimum = 1, $timeout = 10) {
360 my $deadline = time + $timeout;
361 while (time < $deadline) {
362 my $state = eval { crawler_requests($origin) };
363 if ($state && (($state->{count} // 0) >= $minimum)) {
364 return $state;
365 }
366 sleep 0.1;
367 }
368 die "timed out waiting for $name crawler requests at $origin\n";
369}
370
371sub sqlite_dbh ($path) {
372 return DBI->connect(
373 "dbi:SQLite:dbname=$path",
374 q(),
375 q(),
376 {
377 RaiseError => 1,
378 PrintError => 0,
379 AutoCommit => 1,
380 },
381 );
382}
383
384sub latest_email_token_record ($server, $purpose_key, $did) {
385 my $purpose = $server->{token_purpose}{$purpose_key} // die "unknown token purpose $purpose_key\n";
386 my $dbh = sqlite_dbh($server->{db_path});
387 my ($sql, @bind);
388 if (($server->{token_backend} // q()) eq 'reference') {
389 $sql = q{
390 SELECT did, purpose, token, requestedAt
391 FROM email_token
392 WHERE did = ? AND purpose = ?
393 ORDER BY requestedAt DESC
394 LIMIT 1
395 };
396 @bind = ($did, $purpose);
397 } else {
398 $sql = q{
399 SELECT did, purpose, token, email, created_at, expires_at, consumed_at
400 FROM action_tokens
401 WHERE did = ? AND purpose = ?
402 ORDER BY rowid DESC
403 LIMIT 1
404 };
405 @bind = ($did, $purpose);
406 }
407 my $row = $dbh->selectrow_hashref($sql, undef, @bind);
408 $dbh->disconnect;
409 return $row;
410}
411
412sub expire_email_token_record ($server, $purpose_key, $did) {
413 my $purpose = $server->{token_purpose}{$purpose_key} // die "unknown token purpose $purpose_key\n";
414 my $dbh = sqlite_dbh($server->{db_path});
415 if (($server->{token_backend} // q()) eq 'reference') {
416 $dbh->do(
417 q{UPDATE email_token SET requestedAt = ? WHERE did = ? AND purpose = ?},
418 undef,
419 '2000-01-01T00:00:00.000Z',
420 $did,
421 $purpose,
422 );
423 } else {
424 $dbh->do(
425 q{UPDATE action_tokens SET expires_at = ? WHERE did = ? AND purpose = ? AND consumed_at IS NULL},
426 undef,
427 1,
428 $did,
429 $purpose,
430 );
431 }
432 $dbh->disconnect;
433 return;
434}
435
436note('Preparing official reference runtime');
437setup_reference_runtime();
438
439my $diff_account_did_method = $ENV{PERLSKY_DIFF_ACCOUNT_DID_METHOD} // 'did:web';
440note("Differential mode: $diff_account_did_method");
441
442my $plc_port = free_port();
443my $reference_port = free_port();
444my $perl_port = free_port();
445
446my $plc_ready = File::Spec->catfile($tmp, 'plc.ready.json');
447my $ref_ready = File::Spec->catfile($tmp, 'reference.ready.json');
448my $reference_crawler_ready = File::Spec->catfile($tmp, 'reference-crawler.ready.json');
449my $perlsky_crawler_ready = File::Spec->catfile($tmp, 'perlsky-crawler.ready.json');
450
451my $plc_log = File::Spec->catfile($tmp, 'plc.log');
452my $ref_log = File::Spec->catfile($tmp, 'reference.log');
453my $perl_log = File::Spec->catfile($tmp, 'perlsky.log');
454my $reference_crawler_log = File::Spec->catfile($tmp, 'reference-crawler.log');
455my $perlsky_crawler_log = File::Spec->catfile($tmp, 'perlsky-crawler.log');
456
457my $plc = spawn_logged(
458 'plc-mock',
459 ['fnm', 'exec', '--using=20', '--', 'node', File::Spec->catfile($root, 'tools', 'differential', 'plc-mock.cjs')],
460 {
461 PERLSKY_READY_FILE => $plc_ready,
462 PERLSKY_PLC_PORT => $plc_port,
463 PERLSKY_PLC_HOST => '127.0.0.1',
464 },
465 $plc_log,
466);
467
468my $plc_info = wait_for_ready_file('plc mock', $plc_ready);
469pass("started local PLC mock at $plc_info->{origin}");
470
471my $reference_crawler_port = free_port();
472my $perlsky_crawler_port = free_port();
473
474my $reference_crawler = spawn_logged(
475 'reference-crawler',
476 ['fnm', 'exec', '--using=20', '--', 'node', File::Spec->catfile($root, 'tools', 'differential', 'crawler-mock.cjs')],
477 {
478 PERLSKY_READY_FILE => $reference_crawler_ready,
479 PERLSKY_CRAWLER_PORT => $reference_crawler_port,
480 PERLSKY_CRAWLER_HOST => '127.0.0.1',
481 },
482 $reference_crawler_log,
483);
484
485my $perlsky_crawler = spawn_logged(
486 'perlsky-crawler',
487 ['fnm', 'exec', '--using=20', '--', 'node', File::Spec->catfile($root, 'tools', 'differential', 'crawler-mock.cjs')],
488 {
489 PERLSKY_READY_FILE => $perlsky_crawler_ready,
490 PERLSKY_CRAWLER_PORT => $perlsky_crawler_port,
491 PERLSKY_CRAWLER_HOST => '127.0.0.1',
492 },
493 $perlsky_crawler_log,
494);
495
496my $reference_crawler_info = wait_for_ready_file('reference crawler', $reference_crawler_ready);
497wait_for_http_ok('reference crawler', "$reference_crawler_info->{origin}/_health");
498pass("started reference crawler mock at $reference_crawler_info->{origin}");
499
500my $perlsky_crawler_info = wait_for_ready_file('perlsky crawler', $perlsky_crawler_ready);
501wait_for_http_ok('perlsky crawler', "$perlsky_crawler_info->{origin}/_health");
502pass("started perlsky crawler mock at $perlsky_crawler_info->{origin}");
503
504my $reference_data = File::Spec->catdir($tmp, 'reference');
505make_path($reference_data);
506
507my $reference = spawn_logged(
508 'reference-pds',
509 ['fnm', 'exec', '--using=20', '--', 'node', File::Spec->catfile($root, 'tools', 'differential', 'reference-pds-runner.cjs')],
510 {
511 PERLSKY_READY_FILE => $ref_ready,
512 PDS_PORT => $reference_port,
513 PDS_HOSTNAME => 'localhost',
514 PDS_DEV_MODE => 1,
515 PDS_DATA_DIRECTORY => File::Spec->catdir($reference_data, 'data'),
516 PDS_BLOBSTORE_DISK_LOCATION => File::Spec->catdir($reference_data, 'blobs'),
517 PDS_BLOBSTORE_DISK_TMP_LOCATION => File::Spec->catdir($reference_data, 'blobs-tmp'),
518 PDS_PLC_ROTATION_KEY_K256_PRIVATE_KEY_HEX => random_hex(32),
519 PDS_JWT_SECRET => 'reference-jwt-secret',
520 PDS_ADMIN_PASSWORD => 'reference-admin-secret',
521 PDS_INVITE_REQUIRED => 0,
522 PDS_DID_PLC_URL => $plc_info->{origin},
523 PDS_CONTACT_EMAIL_ADDRESS => 'abuse@example.test',
524 PDS_CRAWLERS => $reference_crawler_info->{origin},
525 },
526 $ref_log,
527);
528
529my $reference_info = wait_for_ready_file('reference pds', $ref_ready);
530wait_for_http_ok('reference pds', "$reference_info->{origin}/xrpc/_health");
531pass("started official reference PDS at $reference_info->{origin}");
532
533my $perlsky_config = File::Spec->catfile($tmp, 'perlsky.json');
534open my $cfg_fh, '>', $perlsky_config or die "unable to write $perlsky_config: $!";
535print {$cfg_fh} encode_json({
536 base_url => "http://127.0.0.1:$perl_port",
537 hostname => 'localhost',
538 service_handle_domain => 'test',
539 service_did_method => 'did:web',
540 account_did_method => $diff_account_did_method,
541 ($diff_account_did_method eq 'did:plc'
542 ? (
543 plc_url => $plc_info->{origin},
544 plc_rotation_private_key_hex => ('11' x 32),
545 )
546 : ()),
547 jwt_secret => 'perlsky-jwt-secret',
548 admin_password => 'perlsky-admin-secret',
549 crawlers => [$perlsky_crawler_info->{origin}],
550 data_dir => File::Spec->catdir($tmp, 'perlsky-data'),
551 db_path => File::Spec->catfile($tmp, 'perlsky.sqlite'),
552});
553close $cfg_fh;
554
555my $perlsky = spawn_logged(
556 'perlsky',
557 [$^X, File::Spec->catfile($root, 'script', 'perlsky'), 'daemon', '-l', "http://127.0.0.1:$perl_port"],
558 {
559 PERLSKY_CONFIG => $perlsky_config,
560 },
561 $perl_log,
562);
563
564wait_for_http_ok('perlsky', "http://127.0.0.1:$perl_port/xrpc/_health");
565pass("started perlsky at http://127.0.0.1:$perl_port");
566
567my %server = (
568 reference => {
569 origin => $reference_info->{origin},
570 handle => 'alice.test',
571 email => 'alice-ref@test.com',
572 admin_password => 'reference-admin-secret',
573 crawler_origin => $reference_crawler_info->{origin},
574 db_path => File::Spec->catfile($reference_data, 'data', 'account.sqlite'),
575 token_backend => 'reference',
576 token_purpose => {
577 confirm => 'confirm_email',
578 update => 'update_email',
579 delete => 'delete_account',
580 plc => 'plc_operation',
581 },
582 },
583 perlsky => {
584 origin => "http://127.0.0.1:$perl_port",
585 handle => 'alice.test',
586 email => 'alice-perl@test.com',
587 admin_password => 'perlsky-admin-secret',
588 crawler_origin => $perlsky_crawler_info->{origin},
589 db_path => File::Spec->catfile($tmp, 'perlsky.sqlite'),
590 token_backend => 'perlsky',
591 token_purpose => {
592 confirm => 'email_confirm',
593 update => 'email_update',
594 delete => 'account_delete',
595 plc => 'plc_operation',
596 },
597 },
598);
599
600note('Comparing describeServer');
601for my $name (sort keys %server) {
602 my $res = get_json($server{$name}{origin}, 'com.atproto.server.describeServer');
603 check($res->is_success, "$name describeServer succeeds");
604 $server{$name}{describe} = $res->json if $res->is_success;
605}
606
607check(
608 same_hash(
609 {
610 inviteCodeRequired => $server{reference}{describe}{inviteCodeRequired} ? true : false,
611 availableUserDomains => normalized_domains(get_json($server{reference}{origin}, 'com.atproto.server.describeServer')),
612 },
613 {
614 inviteCodeRequired => $server{perlsky}{describe}{inviteCodeRequired} ? true : false,
615 availableUserDomains => normalized_domains(get_json($server{perlsky}{origin}, 'com.atproto.server.describeServer')),
616 },
617 ),
618 'describeServer matches on invite requirement and user domains',
619);
620
621note('Creating matching accounts');
622for my $name (sort keys %server) {
623 my $res = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
624 handle => $server{$name}{handle},
625 email => $server{$name}{email},
626 password => 'hunter22',
627 });
628 check($res->is_success, "$name createAccount succeeds");
629 next unless $res->is_success;
630
631 my $json = $res->json;
632 $server{$name}{did} = $json->{did};
633 $server{$name}{access} = $json->{accessJwt};
634 $server{$name}{refresh} = $json->{refreshJwt};
635 $server{$name}{create_account} = $json;
636
637 check(($json->{handle} // q()) eq $server{$name}{handle}, "$name createAccount returns normalized handle");
638 check(defined $json->{did} && $json->{did} =~ /\Adid:/, "$name createAccount returns a DID");
639 check(defined $json->{accessJwt} && length $json->{accessJwt}, "$name createAccount returns an access token");
640 check(defined $json->{refreshJwt} && length $json->{refreshJwt}, "$name createAccount returns a refresh token");
641 check(($json->{did} // q()) =~ /\Adid:plc:/, "$name createAccount returns a PLC DID")
642 if $diff_account_did_method eq 'did:plc';
643}
644
645note('Creating secondary accounts for conflict checks');
646for my $name (sort keys %server) {
647 my $res = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
648 handle => $name eq 'reference' ? 'bob-ref.test' : 'bob-perl.test',
649 email => $name eq 'reference' ? 'bob-ref@test.com' : 'bob-perl@test.com',
650 password => 'hunter22',
651 });
652 check($res->is_success, "$name secondary createAccount succeeds");
653 next unless $res->is_success;
654 my $json = $res->json || {};
655 $server{$name}{secondary_did} = $json->{did};
656 $server{$name}{secondary_handle} = $json->{handle};
657 $server{$name}{secondary_email} = $name eq 'reference' ? 'bob-ref@test.com' : 'bob-perl@test.com';
658 $server{$name}{secondary_access} = $json->{accessJwt};
659 $server{$name}{secondary_refresh} = $json->{refreshJwt};
660}
661
662note('Comparing account password boundary semantics');
663for my $name (sort keys %server) {
664 my $too_long_create = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
665 handle => "toolong-$name-" . substr(random_hex(3), 0, 6),
666 email => "toolong-$name-" . substr(random_hex(3), 0, 6) . '@test.com',
667 password => ('x' x 257),
668 });
669 my $invalid_email_create = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
670 handle => "bademail-$name-" . substr(random_hex(3), 0, 6),
671 email => 'not-an-email',
672 password => 'hunter22',
673 });
674 my $duplicate_email_create = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
675 handle => "dupemail-$name-" . substr(random_hex(3), 0, 6),
676 email => uc($server{$name}{email}),
677 password => 'hunter22',
678 });
679 my $duplicate_handle_create = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
680 handle => uc($server{$name}{handle}),
681 email => "duphandle-$name-" . substr(random_hex(3), 0, 6) . '@test.com',
682 password => 'hunter22',
683 });
684 my $too_long_session = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
685 identifier => $server{$name}{handle},
686 password => ('x' x 513),
687 });
688 my $password_reset_upper = post_json($server{$name}{origin}, 'com.atproto.server.requestPasswordReset', {
689 email => uc($server{$name}{email}),
690 });
691
692 $server{$name}{password_boundaries} = {
693 create_too_long => normalize_xrpc_error($too_long_create),
694 create_bad_email => normalize_xrpc_error($invalid_email_create),
695 create_dup_email => normalize_xrpc_error($duplicate_email_create),
696 create_dup_handle => normalize_xrpc_error($duplicate_handle_create),
697 session_too_long => normalize_xrpc_error($too_long_session),
698 reset_uppercase => {
699 status => $password_reset_upper->code // 0,
700 success => $password_reset_upper->is_success ? 1 : 0,
701 empty_body => (($password_reset_upper->body // q()) eq q()) ? 1 : 0,
702 },
703 };
704}
705
706if (!same_hash($server{reference}{password_boundaries}, $server{perlsky}{password_boundaries})) {
707 note('reference password boundaries: ' . encode_json($server{reference}{password_boundaries}));
708 note('perlsky password boundaries: ' . encode_json($server{perlsky}{password_boundaries}));
709 fail_check('account password boundary and reset-email semantics match the official reference PDS');
710} else {
711 pass('account password boundary and reset-email semantics match the official reference PDS');
712}
713
714note('Comparing handle conflict semantics');
715for my $name (sort keys %server) {
716 my $duplicate_identity_handle = post_json(
717 $server{$name}{origin},
718 'com.atproto.identity.updateHandle',
719 { handle => $server{$name}{secondary_handle} },
720 auth_header($server{$name}{access}),
721 );
722 my $duplicate_admin_handle = post_json(
723 $server{$name}{origin},
724 'com.atproto.admin.updateAccountHandle',
725 {
726 did => $server{$name}{did},
727 handle => $server{$name}{secondary_handle},
728 },
729 admin_auth_header($server{$name}{admin_password}),
730 );
731 $server{$name}{handle_conflicts} = {
732 identity_update_dup => normalize_xrpc_error($duplicate_identity_handle),
733 admin_update_dup => normalize_xrpc_error($duplicate_admin_handle),
734 };
735}
736
737if (!same_hash($server{reference}{handle_conflicts}, $server{perlsky}{handle_conflicts})) {
738 note('reference handle conflicts: ' . encode_json($server{reference}{handle_conflicts}));
739 note('perlsky handle conflicts: ' . encode_json($server{perlsky}{handle_conflicts}));
740 fail_check('handle conflict update semantics match the official reference PDS');
741} else {
742 pass('handle conflict update semantics match the official reference PDS');
743}
744
745note('Comparing resolveHandle');
746for my $name (sort keys %server) {
747 my $res = get_form($server{$name}{origin}, 'com.atproto.identity.resolveHandle', { handle => $server{$name}{handle} });
748 check($res->is_success, "$name resolveHandle succeeds");
749 next unless $res->is_success;
750 check(($res->json->{did} // q()) eq $server{$name}{did}, "$name resolveHandle returns the created DID");
751}
752
753for my $name (sort keys %server) {
754 my $res = get_form(
755 $server{$name}{origin},
756 'com.atproto.identity.resolveHandle',
757 { handle => 'missing.test' },
758 );
759 $server{$name}{resolve_handle_missing} = normalize_xrpc_error($res);
760}
761
762check(
763 same_hash($server{reference}{resolve_handle_missing}, $server{perlsky}{resolve_handle_missing}),
764 'resolveHandle missing-handle semantics match the official reference PDS',
765);
766
767note('Comparing resolveDid and resolveIdentity');
768for my $name (sort keys %server) {
769 my $resolve_did = get_form(
770 $server{$name}{origin},
771 'com.atproto.identity.resolveDid',
772 { did => $server{$name}{did} },
773 );
774
775 my $identity_by_did = get_form(
776 $server{$name}{origin},
777 'com.atproto.identity.resolveIdentity',
778 { identifier => $server{$name}{did} },
779 );
780
781 my $identity_by_handle = get_form(
782 $server{$name}{origin},
783 'com.atproto.identity.resolveIdentity',
784 { identifier => $server{$name}{handle} },
785 );
786
787 my $missing_did = get_form(
788 $server{$name}{origin},
789 'com.atproto.identity.resolveDid',
790 { did => 'did:web:missing.test' },
791 );
792
793 my $missing_identity_by_did = get_form(
794 $server{$name}{origin},
795 'com.atproto.identity.resolveIdentity',
796 { identifier => 'did:web:missing.test' },
797 );
798
799 my $missing_identity_by_handle = get_form(
800 $server{$name}{origin},
801 'com.atproto.identity.resolveIdentity',
802 { identifier => 'missing.test' },
803 );
804
805 my $invalid_handle = get_form(
806 $server{$name}{origin},
807 'com.atproto.identity.resolveHandle',
808 { handle => 'bad_handle' },
809 );
810
811 $server{$name}{identity_surface} = {
812 resolve_did => $resolve_did->is_success
813 ? {
814 status => $resolve_did->code,
815 did_doc => normalize_did_doc(
816 ($resolve_did->json || {})->{didDoc} || {},
817 $server{$name}{did},
818 $server{$name}{handle},
819 $server{$name}{origin},
820 ),
821 }
822 : normalize_xrpc_error($resolve_did),
823 identity_by_did => $identity_by_did->is_success
824 ? {
825 status => $identity_by_did->code,
826 did_match => ((($identity_by_did->json || {})->{did} // q()) eq $server{$name}{did}) ? 1 : 0,
827 handle_match => ((($identity_by_did->json || {})->{handle} // q()) eq $server{$name}{handle}) ? 1 : 0,
828 did_doc => normalize_did_doc(
829 (($identity_by_did->json || {})->{didDoc} || {}),
830 $server{$name}{did},
831 $server{$name}{handle},
832 $server{$name}{origin},
833 ),
834 }
835 : normalize_xrpc_error($identity_by_did),
836 identity_by_handle => $identity_by_handle->is_success
837 ? {
838 status => $identity_by_handle->code,
839 did_match => ((($identity_by_handle->json || {})->{did} // q()) eq $server{$name}{did}) ? 1 : 0,
840 handle_match => ((($identity_by_handle->json || {})->{handle} // q()) eq $server{$name}{handle}) ? 1 : 0,
841 did_doc => normalize_did_doc(
842 (($identity_by_handle->json || {})->{didDoc} || {}),
843 $server{$name}{did},
844 $server{$name}{handle},
845 $server{$name}{origin},
846 ),
847 }
848 : normalize_xrpc_error($identity_by_handle),
849 missing_did => normalize_xrpc_error($missing_did),
850 missing_identity_by_did => normalize_xrpc_error($missing_identity_by_did),
851 missing_identity_by_handle => normalize_xrpc_error($missing_identity_by_handle),
852 invalid_handle => normalize_xrpc_error($invalid_handle),
853 };
854}
855
856if (!same_hash($server{reference}{identity_surface}, $server{perlsky}{identity_surface})) {
857 note('reference identity surface: ' . encode_json($server{reference}{identity_surface}));
858 note('perlsky identity surface: ' . encode_json($server{perlsky}{identity_surface}));
859 fail_check('resolveDid and resolveIdentity local-account semantics match the official reference PDS');
860} else {
861 pass('resolveDid and resolveIdentity local-account semantics match the official reference PDS');
862}
863
864note('Comparing subscribeRepos bootstrap backfill');
865for my $name (sort keys %server) {
866 my $frames = frames_until_quiet("$server{$name}{origin}/xrpc/com.atproto.sync.subscribeRepos?cursor=0");
867 $server{$name}{bootstrap_firehose} = normalize_bootstrap_frames(
868 $frames,
869 $server{$name}{did},
870 $server{$name}{handle},
871 );
872 check(@$frames >= 1, "$name subscribeRepos emits bootstrap frames from cursor=0");
873}
874
875check(
876 same_hash($server{reference}{bootstrap_firehose}, $server{perlsky}{bootstrap_firehose}),
877 'subscribeRepos bootstrap backfill matches the official reference PDS semantics',
878);
879
880note('Comparing crawler notifications');
881for my $name (sort keys %server) {
882 my $state = wait_for_crawler_requests("$name crawler", $server{$name}{crawler_origin});
883 my $first = $state->{requests}[0]{body} || {};
884 $server{$name}{crawler_notice} = {
885 saw_request => (($state->{count} // 0) >= 1) ? 1 : 0,
886 hostname_matches => (($first->{hostname} // q()) eq 'localhost') ? 1 : 0,
887 };
888 check($server{$name}{crawler_notice}{saw_request}, "$name requested a relay crawl");
889 check($server{$name}{crawler_notice}{hostname_matches}, "$name requestCrawl uses the configured hostname");
890}
891
892check(
893 same_hash($server{reference}{crawler_notice}, $server{perlsky}{crawler_notice}),
894 'outbound crawler notifications match the official reference PDS semantics',
895);
896
897note('Comparing getSession');
898for my $name (sort keys %server) {
899 my $res = get_json($server{$name}{origin}, 'com.atproto.server.getSession', undef, auth_header($server{$name}{access}));
900 check($res->is_success, "$name getSession succeeds");
901 next unless $res->is_success;
902 my $json = $res->json;
903 $server{$name}{session} = $json;
904 check(($json->{did} // q()) eq $server{$name}{did}, "$name getSession returns the created DID");
905 check(($json->{handle} // q()) eq $server{$name}{handle}, "$name getSession returns the created handle");
906}
907
908note('Comparing refreshSession token rotation');
909for my $name (sort keys %server) {
910 my $res = post_empty(
911 $server{$name}{origin},
912 'com.atproto.server.refreshSession',
913 auth_header($server{$name}{refresh}),
914 );
915 check($res->is_success, "$name refreshSession succeeds");
916 next unless $res->is_success;
917 my $json = $res->json || {};
918 my $old_access = $server{$name}{access};
919 my $old_refresh = $server{$name}{refresh};
920 my $old_refresh_claims = jwt_claims($old_refresh);
921 $server{$name}{access} = $json->{accessJwt};
922 $server{$name}{refresh} = $json->{refreshJwt};
923 my $new_refresh_claims = jwt_claims($server{$name}{refresh});
924
925 my $old_access_res = get_json(
926 $server{$name}{origin},
927 'com.atproto.server.getSession',
928 undef,
929 auth_header($old_access),
930 );
931 my $old_refresh_res = post_empty(
932 $server{$name}{origin},
933 'com.atproto.server.refreshSession',
934 auth_header($old_refresh),
935 );
936 my $new_access_res = get_json(
937 $server{$name}{origin},
938 'com.atproto.server.getSession',
939 undef,
940 auth_header($server{$name}{access}),
941 );
942 my $old_refresh_json = $old_refresh_res->json || {};
943 my $reused_refresh_claims = jwt_claims($old_refresh_json->{refreshJwt});
944
945 $server{$name}{refresh_rotation} = {
946 has_access_jwt => length($json->{accessJwt} // q()) ? 1 : 0,
947 has_refresh_jwt => length($json->{refreshJwt} // q()) ? 1 : 0,
948 refresh_rotated => (($new_refresh_claims->{jti} // q()) ne ($old_refresh_claims->{jti} // q())) ? 1 : 0,
949 old_access_works => $old_access_res->is_success ? 1 : 0,
950 old_refresh_works => $old_refresh_res->is_success ? 1 : 0,
951 reused_refresh_matches => $old_refresh_res->is_success
952 && (($reused_refresh_claims->{jti} // q()) eq ($new_refresh_claims->{jti} // q()))
953 ? 1
954 : 0,
955 new_access_works => $new_access_res->is_success ? 1 : 0,
956 };
957}
958
959check(
960 same_hash($server{reference}{refresh_rotation}, $server{perlsky}{refresh_rotation}),
961 'refreshSession grace and successor semantics match the official reference PDS',
962);
963
964note('Comparing app password semantics');
965for my $name (sort keys %server) {
966 my $create_phone = post_json(
967 $server{$name}{origin},
968 'com.atproto.server.createAppPassword',
969 { name => 'phone' },
970 auth_header($server{$name}{access}),
971 );
972 check($create_phone->is_success, "$name createAppPassword succeeds for a standard app password");
973
974 my $create_desktop = post_json(
975 $server{$name}{origin},
976 'com.atproto.server.createAppPassword',
977 {
978 name => 'desktop',
979 privileged => true,
980 },
981 auth_header($server{$name}{access}),
982 );
983 check($create_desktop->is_success, "$name createAppPassword succeeds for a privileged app password");
984 next unless $create_phone->is_success && $create_desktop->is_success;
985
986 my $phone_json = $create_phone->json || {};
987 my $desktop_json = $create_desktop->json || {};
988
989 my $list_before = get_json(
990 $server{$name}{origin},
991 'com.atproto.server.listAppPasswords',
992 undef,
993 auth_header($server{$name}{access}),
994 );
995 check($list_before->is_success, "$name listAppPasswords succeeds after creation");
996
997 my $phone_session = post_json(
998 $server{$name}{origin},
999 'com.atproto.server.createSession',
1000 {
1001 identifier => $server{$name}{handle},
1002 password => $phone_json->{password},
1003 },
1004 );
1005 check($phone_session->is_success, "$name createSession succeeds with the standard app password");
1006
1007 my $desktop_session = post_json(
1008 $server{$name}{origin},
1009 'com.atproto.server.createSession',
1010 {
1011 identifier => $server{$name}{handle},
1012 password => $desktop_json->{password},
1013 },
1014 );
1015 check($desktop_session->is_success, "$name createSession succeeds with the privileged app password");
1016
1017 my $phone_access = ($phone_session->json || {})->{accessJwt};
1018 my $phone_refresh = ($phone_session->json || {})->{refreshJwt};
1019 my $desktop_access = ($desktop_session->json || {})->{accessJwt};
1020
1021 my $nested_create = post_json(
1022 $server{$name}{origin},
1023 'com.atproto.server.createAppPassword',
1024 { name => 'nested' },
1025 auth_header($phone_access),
1026 );
1027 my $phone_list = get_json(
1028 $server{$name}{origin},
1029 'com.atproto.server.listAppPasswords',
1030 undef,
1031 auth_header($phone_access),
1032 );
1033 my $phone_service_auth = get_form(
1034 $server{$name}{origin},
1035 'com.atproto.server.getServiceAuth',
1036 {
1037 aud => 'did:web:api.bsky.app',
1038 lxm => 'com.atproto.server.createaccount',
1039 },
1040 auth_header($phone_access),
1041 );
1042 my $desktop_service_auth = get_form(
1043 $server{$name}{origin},
1044 'com.atproto.server.getServiceAuth',
1045 {
1046 aud => 'did:web:api.bsky.app',
1047 lxm => 'com.atproto.server.createaccount',
1048 },
1049 auth_header($desktop_access),
1050 );
1051
1052 my $revoke_phone = post_json(
1053 $server{$name}{origin},
1054 'com.atproto.server.revokeAppPassword',
1055 { name => 'phone' },
1056 auth_header($server{$name}{access}),
1057 );
1058 check($revoke_phone->is_success, "$name revokeAppPassword succeeds for the standard app password");
1059
1060 my $revoked_refresh = post_empty(
1061 $server{$name}{origin},
1062 'com.atproto.server.refreshSession',
1063 auth_header($phone_refresh),
1064 );
1065 my $list_after = get_json(
1066 $server{$name}{origin},
1067 'com.atproto.server.listAppPasswords',
1068 undef,
1069 auth_header($server{$name}{access}),
1070 );
1071
1072 my %before_passwords = map {
1073 (
1074 ($_->{name} // q()) => {
1075 privileged => $_->{privileged} ? 1 : 0,
1076 }
1077 )
1078 } @{ ($list_before->json || {})->{passwords} || [] };
1079
1080 my %after_passwords = map {
1081 (
1082 ($_->{name} // q()) => {
1083 privileged => $_->{privileged} ? 1 : 0,
1084 }
1085 )
1086 } @{ ($list_after->json || {})->{passwords} || [] };
1087
1088 $server{$name}{app_passwords} = {
1089 phone_create => {
1090 name => $phone_json->{name} // q(),
1091 has_password => length($phone_json->{password} // q()) ? 1 : 0,
1092 privileged => $phone_json->{privileged} ? 1 : 0,
1093 },
1094 desktop_create => {
1095 name => $desktop_json->{name} // q(),
1096 has_password => length($desktop_json->{password} // q()) ? 1 : 0,
1097 privileged => $desktop_json->{privileged} ? 1 : 0,
1098 },
1099 list_before => {
1100 passwords => \%before_passwords,
1101 },
1102 phone_session_scope => jwt_claims($phone_access)->{scope} // q(),
1103 desktop_session_scope => jwt_claims($desktop_access)->{scope} // q(),
1104 nested_create_error => normalize_xrpc_error($nested_create),
1105 phone_list_error => normalize_xrpc_error($phone_list),
1106 phone_service_auth => normalize_xrpc_error($phone_service_auth),
1107 desktop_service_auth => {
1108 status => $desktop_service_auth->code,
1109 has_token => length((($desktop_service_auth->json || {})->{token}) // q()) ? 1 : 0,
1110 },
1111 revoked_refresh_error => normalize_xrpc_error($revoked_refresh),
1112 list_after => {
1113 passwords => \%after_passwords,
1114 },
1115 };
1116}
1117
1118if (!same_hash($server{reference}{app_passwords}, $server{perlsky}{app_passwords})) {
1119 note('reference app passwords: ' . encode_json($server{reference}{app_passwords}));
1120 note('perlsky app passwords: ' . encode_json($server{perlsky}{app_passwords}));
1121 fail_check('app password lifecycle semantics match the official reference PDS');
1122} else {
1123 pass('app password lifecycle semantics match the official reference PDS');
1124}
1125
1126if ($diff_account_did_method eq 'did:plc') {
1127 note('Comparing PLC identity semantics');
1128 for my $name (sort keys %server) {
1129 my $res = get_json(
1130 $server{$name}{origin},
1131 'com.atproto.identity.getRecommendedDidCredentials',
1132 undef,
1133 auth_header($server{$name}{access}),
1134 );
1135 check($res->is_success, "$name getRecommendedDidCredentials succeeds");
1136 next unless $res->is_success;
1137 $server{$name}{recommended_did} = normalize_plc_credentials(
1138 $res->json || {},
1139 $server{$name}{handle},
1140 $server{$name}{origin},
1141 );
1142 }
1143
1144 check(
1145 same_hash($server{reference}{recommended_did}, $server{perlsky}{recommended_did}),
1146 'getRecommendedDidCredentials matches the official reference PDS semantics',
1147 );
1148
1149 note('Comparing PLC signature requests');
1150 for my $name (sort keys %server) {
1151 my $res = post_empty(
1152 $server{$name}{origin},
1153 'com.atproto.identity.requestPlcOperationSignature',
1154 auth_header($server{$name}{access}),
1155 );
1156 check($res->is_success, "$name requestPlcOperationSignature succeeds");
1157 next unless $res->is_success;
1158 $server{$name}{plc_signature_request} = {
1159 status => $res->code // 0,
1160 empty_body => (($res->body // q()) eq q()) ? 1 : 0,
1161 };
1162 }
1163
1164 check(
1165 same_hash($server{reference}{plc_signature_request}, $server{perlsky}{plc_signature_request}),
1166 'requestPlcOperationSignature matches the official reference PDS empty-body semantics',
1167 );
1168
1169 note('Comparing PLC handle updates');
1170 for my $name (sort keys %server) {
1171 my $new_handle = $name eq 'reference' ? 'alice-renamed-ref.test' : 'alice-renamed-perl.test';
1172 my $res = post_json(
1173 $server{$name}{origin},
1174 'com.atproto.identity.updateHandle',
1175 { handle => $new_handle },
1176 auth_header($server{$name}{access}),
1177 );
1178 check($res->is_success, "$name updateHandle succeeds for PLC accounts");
1179 next unless $res->is_success;
1180 $server{$name}{plc_handle_update} = {
1181 status => $res->code // 0,
1182 empty_body => (($res->body // q()) eq q()) ? 1 : 0,
1183 };
1184 $server{$name}{renamed_handle} = $new_handle;
1185
1186 my $handle_res = get_form(
1187 $server{$name}{origin},
1188 'com.atproto.identity.resolveHandle',
1189 { handle => $new_handle },
1190 );
1191 check($handle_res->is_success, "$name resolveHandle finds the renamed PLC handle");
1192 check(($handle_res->json->{did} // q()) eq $server{$name}{did}, "$name renamed PLC handle still resolves to the same DID")
1193 if $handle_res->is_success;
1194 }
1195
1196 check(
1197 same_hash($server{reference}{plc_handle_update}, $server{perlsky}{plc_handle_update}),
1198 'updateHandle matches the official reference PDS empty-body semantics',
1199 );
1200
1201 note('Comparing PLC token requirements');
1202 for my $name (sort keys %server) {
1203 my $res = post_json(
1204 $server{$name}{origin},
1205 'com.atproto.identity.signPlcOperation',
1206 {},
1207 auth_header($server{$name}{access}),
1208 );
1209 check(!$res->is_success, "$name signPlcOperation rejects missing tokens");
1210 $server{$name}{missing_plc_token_error} = normalize_xrpc_error($res);
1211 }
1212
1213 check(
1214 same_hash($server{reference}{missing_plc_token_error}, $server{perlsky}{missing_plc_token_error}),
1215 'signPlcOperation matches the official reference PDS token requirement semantics',
1216 );
1217
1218 note('Comparing successful PLC submit semantics');
1219 for my $name (sort keys %server) {
1220 my $plc_token = latest_email_token_record($server{$name}, 'plc', $server{$name}{did});
1221 check($plc_token && length($plc_token->{token} // q()), "$name requestPlcOperationSignature issues a PLC token");
1222 next unless $plc_token && length($plc_token->{token} // q());
1223
1224 my $sign_res = post_json(
1225 $server{$name}{origin},
1226 'com.atproto.identity.signPlcOperation',
1227 { token => $plc_token->{token} },
1228 auth_header($server{$name}{access}),
1229 );
1230 check($sign_res->is_success, "$name signPlcOperation succeeds with the issued PLC token");
1231 next unless $sign_res->is_success;
1232
1233 my $submit_res = post_json(
1234 $server{$name}{origin},
1235 'com.atproto.identity.submitPlcOperation',
1236 { operation => (($sign_res->json || {})->{operation} || {}) },
1237 auth_header($server{$name}{access}),
1238 );
1239 check($submit_res->is_success, "$name submitPlcOperation succeeds with a signed PLC op");
1240 next unless $submit_res->is_success;
1241
1242 $server{$name}{plc_submit_success} = {
1243 status => $submit_res->code // 0,
1244 empty_body => (($submit_res->body // q()) eq q()) ? 1 : 0,
1245 };
1246 }
1247
1248 check(
1249 same_hash($server{reference}{plc_submit_success}, $server{perlsky}{plc_submit_success}),
1250 'submitPlcOperation matches the official reference PDS empty-body success semantics',
1251 );
1252
1253 note('Comparing PLC submitPlcOperation validation');
1254 for my $name (sort keys %server) {
1255 my $res = post_json(
1256 $server{$name}{origin},
1257 'com.atproto.identity.submitPlcOperation',
1258 { operation => {} },
1259 auth_header($server{$name}{access}),
1260 );
1261 check(!$res->is_success, "$name submitPlcOperation rejects malformed operations");
1262 $server{$name}{invalid_plc_operation_error} = normalize_xrpc_error($res);
1263 }
1264
1265 check(
1266 same_hash($server{reference}{invalid_plc_operation_error}, $server{perlsky}{invalid_plc_operation_error}),
1267 'submitPlcOperation matches the official reference PDS invalid-operation semantics',
1268 );
1269}
1270
1271my $record = {
1272 '$type' => 'app.bsky.feed.post',
1273 text => 'differential validation post',
1274 createdAt => '2026-03-10T00:00:00Z',
1275};
1276
1277note('Comparing createRecord');
1278for my $name (sort keys %server) {
1279 my $res = post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
1280 repo => $server{$name}{did},
1281 collection => 'app.bsky.feed.post',
1282 rkey => 'diffpost',
1283 record => $record,
1284 }, auth_header($server{$name}{access}));
1285 check($res->is_success, "$name createRecord succeeds");
1286 next unless $res->is_success;
1287 my $json = $res->json;
1288 $server{$name}{record_uri} = $json->{uri};
1289 $server{$name}{record_cid} = $json->{cid};
1290 check(($json->{uri} // q()) =~ m{/app\.bsky\.feed\.post/diffpost\z}, "$name createRecord returns the expected record URI");
1291 check(defined $json->{cid} && length $json->{cid}, "$name createRecord returns a CID");
1292}
1293
1294note('Comparing putRecord update and create semantics');
1295for my $name (sort keys %server) {
1296 my $update_res = post_json($server{$name}{origin}, 'com.atproto.repo.putRecord', {
1297 repo => $server{$name}{did},
1298 collection => 'app.bsky.feed.post',
1299 rkey => 'diffpost',
1300 record => {
1301 %{$record},
1302 text => "put update validation for $name",
1303 },
1304 }, auth_header($server{$name}{access}));
1305 check($update_res->is_success, "$name putRecord updates an existing record");
1306
1307 my $create_res = post_json($server{$name}{origin}, 'com.atproto.repo.putRecord', {
1308 repo => $server{$name}{did},
1309 collection => 'app.bsky.feed.post',
1310 rkey => 'put-created',
1311 record => {
1312 %{$record},
1313 text => "put create validation for $name",
1314 },
1315 }, auth_header($server{$name}{access}));
1316 check($create_res->is_success, "$name putRecord creates a missing record");
1317
1318 my $created_record = get_form($server{$name}{origin}, 'com.atproto.repo.getRecord', {
1319 repo => $server{$name}{did},
1320 collection => 'app.bsky.feed.post',
1321 rkey => 'put-created',
1322 });
1323
1324 $server{$name}{put_record} = {
1325 update_ok => $update_res->is_success ? 1 : 0,
1326 update_uri_expected => (($update_res->json || {})->{uri} // q()) =~ m{/app\.bsky\.feed\.post/diffpost\z} ? 1 : 0,
1327 update_has_cid => defined(($update_res->json || {})->{cid}) && length(($update_res->json || {})->{cid}) ? 1 : 0,
1328 create_ok => $create_res->is_success ? 1 : 0,
1329 create_uri_expected => (($create_res->json || {})->{uri} // q()) =~ m{/app\.bsky\.feed\.post/put-created\z} ? 1 : 0,
1330 create_has_cid => defined(($create_res->json || {})->{cid}) && length(($create_res->json || {})->{cid}) ? 1 : 0,
1331 created_record_reads => $created_record->is_success ? 1 : 0,
1332 created_text_ok => (($created_record->json || {})->{value}{text} // q()) =~ /^put create validation / ? 1 : 0,
1333 };
1334 $server{$name}{updated_record_cid} = ($update_res->json || {})->{cid};
1335}
1336
1337check(
1338 same_hash($server{reference}{put_record}, $server{perlsky}{put_record}),
1339 'putRecord create-or-update semantics match the official reference PDS',
1340);
1341
1342note('Comparing sync.getRecord deleted-record proof semantics');
1343for my $name (sort keys %server) {
1344 my $create_res = post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
1345 repo => $server{$name}{did},
1346 collection => 'app.bsky.feed.post',
1347 rkey => 'sync-delete-proof',
1348 record => {
1349 %{$record},
1350 text => "sync delete proof validation for $name",
1351 },
1352 }, auth_header($server{$name}{access}));
1353 check($create_res->is_success, "$name createRecord succeeds for deleted sync proof comparison");
1354 next unless $create_res->is_success;
1355
1356 my $deleted_record_cid = ($create_res->json || {})->{cid};
1357 my $delete_res = post_json($server{$name}{origin}, 'com.atproto.repo.deleteRecord', {
1358 repo => $server{$name}{did},
1359 collection => 'app.bsky.feed.post',
1360 rkey => 'sync-delete-proof',
1361 }, auth_header($server{$name}{access}));
1362 check($delete_res->is_success, "$name deleteRecord succeeds for deleted sync proof comparison");
1363 next unless $delete_res->is_success;
1364
1365 my $latest_commit = get_form(
1366 $server{$name}{origin},
1367 'com.atproto.sync.getLatestCommit',
1368 { did => $server{$name}{did} },
1369 );
1370 check($latest_commit->is_success, "$name getLatestCommit succeeds after deleted sync proof setup");
1371
1372 my $sync_record = get_form($server{$name}{origin}, 'com.atproto.sync.getRecord', {
1373 did => $server{$name}{did},
1374 collection => 'app.bsky.feed.post',
1375 rkey => 'sync-delete-proof',
1376 });
1377 my $sync_car = $sync_record->is_success ? read_car($sync_record->body // q()) : undef;
1378 my $latest_commit_json = $latest_commit->json || {};
1379 $server{$name}{deleted_sync_record_proof} = {
1380 proof_ok => $sync_record->is_success ? 1 : 0,
1381 proof_is_car => (($sync_record->headers->content_type // q()) =~ m{application/vnd\.ipld\.car}) ? 1 : 0,
1382 proof_root_matches_head => (
1383 $sync_car
1384 && $sync_car->{roots}[0]
1385 && (($sync_car->{roots}[0]->to_string // q()) eq (($latest_commit_json->{cid} // q())))
1386 ) ? 1 : 0,
1387 proof_omits_record => (
1388 !$sync_car
1389 || !scalar(grep { $_->{cid}->to_string eq $deleted_record_cid } @{ $sync_car->{blocks} || [] })
1390 ) ? 1 : 0,
1391 proof_has_tree => ($sync_car && @{ $sync_car->{blocks} || [] } >= 2) ? 1 : 0,
1392 };
1393}
1394
1395check(
1396 same_hash($server{reference}{deleted_sync_record_proof}, $server{perlsky}{deleted_sync_record_proof}),
1397 'sync.getRecord deleted-record proof semantics match the official reference PDS',
1398);
1399
1400note('Comparing repo stale-cid and missing-delete semantics');
1401for my $name (sort keys %server) {
1402 my $stale_get = get_form($server{$name}{origin}, 'com.atproto.repo.getRecord', {
1403 repo => $server{$name}{did},
1404 collection => 'app.bsky.feed.post',
1405 rkey => 'diffpost',
1406 cid => $server{$name}{record_cid},
1407 });
1408
1409 my $latest_before_missing_delete = get_form(
1410 $server{$name}{origin},
1411 'com.atproto.sync.getLatestCommit',
1412 { did => $server{$name}{did} },
1413 );
1414 check($latest_before_missing_delete->is_success, "$name getLatestCommit succeeds before missing delete");
1415
1416 my $missing_delete = post_json($server{$name}{origin}, 'com.atproto.repo.deleteRecord', {
1417 repo => $server{$name}{did},
1418 collection => 'app.bsky.feed.post',
1419 rkey => 'missing-rkey-ok',
1420 }, auth_header($server{$name}{access}));
1421
1422 my $latest_after_missing_delete = get_form(
1423 $server{$name}{origin},
1424 'com.atproto.sync.getLatestCommit',
1425 { did => $server{$name}{did} },
1426 );
1427 check($latest_after_missing_delete->is_success, "$name getLatestCommit succeeds after missing delete");
1428
1429 $server{$name}{repo_read_edges} = {
1430 stale_get => normalize_xrpc_error($stale_get),
1431 missing_delete => {
1432 status => $missing_delete->code // 0,
1433 body => $missing_delete->body,
1434 },
1435 latest_commit_unchanged => (
1436 (($latest_before_missing_delete->json || {})->{cid} // q()) eq (($latest_after_missing_delete->json || {})->{cid} // q())
1437 && (($latest_before_missing_delete->json || {})->{rev} // q()) eq (($latest_after_missing_delete->json || {})->{rev} // q())
1438 ) ? 1 : 0,
1439 };
1440}
1441
1442if (!same_hash($server{reference}{repo_read_edges}, $server{perlsky}{repo_read_edges})) {
1443 note('reference repo read edges: ' . encode_json($server{reference}{repo_read_edges}));
1444 note('perlsky repo read edges: ' . encode_json($server{perlsky}{repo_read_edges}));
1445 fail_check('repo stale-cid reads and missing-delete no-ops match the official reference PDS');
1446} else {
1447 pass('repo stale-cid reads and missing-delete no-ops match the official reference PDS');
1448}
1449
1450note('Comparing applyWrites');
1451for my $name (sort keys %server) {
1452 my $seed_update = post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
1453 repo => $server{$name}{did},
1454 collection => 'app.bsky.feed.post',
1455 rkey => 'apply-update-target',
1456 record => {
1457 %{$record},
1458 text => "applyWrites seed update for $name",
1459 },
1460 }, auth_header($server{$name}{access}));
1461 check($seed_update->is_success, "$name applyWrites seed update record succeeds");
1462
1463 my $seed_delete = post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
1464 repo => $server{$name}{did},
1465 collection => 'app.bsky.feed.post',
1466 rkey => 'apply-delete-target',
1467 record => {
1468 %{$record},
1469 text => "applyWrites seed delete for $name",
1470 },
1471 }, auth_header($server{$name}{access}));
1472 check($seed_delete->is_success, "$name applyWrites seed delete record succeeds");
1473 next unless $seed_update->is_success && $seed_delete->is_success;
1474
1475 my $apply = post_json($server{$name}{origin}, 'com.atproto.repo.applyWrites', {
1476 repo => $server{$name}{did},
1477 writes => [
1478 {
1479 '$type' => 'com.atproto.repo.applyWrites#create',
1480 collection => 'app.bsky.feed.post',
1481 rkey => 'apply-created',
1482 value => {
1483 '$type' => 'app.bsky.feed.post',
1484 text => "applyWrites create for $name",
1485 createdAt => '2026-03-12T00:00:01Z',
1486 },
1487 },
1488 {
1489 '$type' => 'com.atproto.repo.applyWrites#update',
1490 collection => 'app.bsky.feed.post',
1491 rkey => 'apply-update-target',
1492 value => {
1493 '$type' => 'app.bsky.feed.post',
1494 text => "applyWrites update for $name",
1495 createdAt => '2026-03-12T00:00:02Z',
1496 },
1497 },
1498 {
1499 '$type' => 'com.atproto.repo.applyWrites#delete',
1500 collection => 'app.bsky.feed.post',
1501 rkey => 'apply-delete-target',
1502 },
1503 ],
1504 }, auth_header($server{$name}{access}));
1505 check($apply->is_success, "$name applyWrites succeeds");
1506
1507 my $created = get_form($server{$name}{origin}, 'com.atproto.repo.getRecord', {
1508 repo => $server{$name}{did},
1509 collection => 'app.bsky.feed.post',
1510 rkey => 'apply-created',
1511 });
1512 my $updated = get_form($server{$name}{origin}, 'com.atproto.repo.getRecord', {
1513 repo => $server{$name}{did},
1514 collection => 'app.bsky.feed.post',
1515 rkey => 'apply-update-target',
1516 });
1517 my $deleted = get_form($server{$name}{origin}, 'com.atproto.repo.getRecord', {
1518 repo => $server{$name}{did},
1519 collection => 'app.bsky.feed.post',
1520 rkey => 'apply-delete-target',
1521 });
1522 my $missing_delete = post_json($server{$name}{origin}, 'com.atproto.repo.applyWrites', {
1523 repo => $server{$name}{did},
1524 writes => [
1525 {
1526 '$type' => 'com.atproto.repo.applyWrites#delete',
1527 collection => 'app.bsky.feed.post',
1528 rkey => 'apply-missing-target',
1529 },
1530 ],
1531 }, auth_header($server{$name}{access}));
1532
1533 my $apply_json = $apply->json || {};
1534 my $results = $apply_json->{results} || [];
1535 $server{$name}{apply_writes} = {
1536 ok => $apply->is_success ? 1 : 0,
1537 has_commit => ref($apply_json->{commit}) eq 'HASH' ? 1 : 0,
1538 results_count => 0 + @$results,
1539 create_result_type => ($results->[0]{'$type'} // q()),
1540 update_result_type => ($results->[1]{'$type'} // q()),
1541 delete_result_type => ($results->[2]{'$type'} // q()),
1542 created_text_ok => (($created->json || {})->{value}{text} // q()) =~ /\AapplyWrites create / ? 1 : 0,
1543 updated_text_ok => (($updated->json || {})->{value}{text} // q()) =~ /\AapplyWrites update / ? 1 : 0,
1544 deleted_missing => $deleted->is_success ? 0 : 1,
1545 deleted_error => ($deleted->json || {})->{error} // q(),
1546 };
1547 $server{$name}{apply_writes_missing_delete_error} = normalize_xrpc_error($missing_delete);
1548}
1549
1550if (!same_hash($server{reference}{apply_writes}, $server{perlsky}{apply_writes})) {
1551 note('reference applyWrites: ' . encode_json($server{reference}{apply_writes}));
1552 note('perlsky applyWrites: ' . encode_json($server{perlsky}{apply_writes}));
1553 fail_check('applyWrites matches the official reference PDS semantics');
1554} else {
1555 pass('applyWrites matches the official reference PDS semantics');
1556}
1557
1558if (!same_hash($server{reference}{apply_writes_missing_delete_error}, $server{perlsky}{apply_writes_missing_delete_error})) {
1559 note('reference applyWrites missing-delete error: ' . encode_json($server{reference}{apply_writes_missing_delete_error}));
1560 note('perlsky applyWrites missing-delete error: ' . encode_json($server{perlsky}{apply_writes_missing_delete_error}));
1561 pass('applyWrites missing-delete error remains a documented intentional divergence from the official runtime');
1562} else {
1563 pass('applyWrites missing-delete error matches the official reference PDS semantics');
1564}
1565
1566note('Comparing repo write swap preconditions');
1567for my $name (sort keys %server) {
1568 my $put_swap_commit = post_json($server{$name}{origin}, 'com.atproto.repo.putRecord', {
1569 repo => $server{$name}{did},
1570 collection => 'app.bsky.feed.post',
1571 rkey => 'diffpost',
1572 swapCommit => 'bafyreifakeheadmismatch',
1573 record => {
1574 '$type' => 'app.bsky.feed.post',
1575 text => "put swapCommit mismatch for $name",
1576 createdAt => '2026-03-11T00:00:02Z',
1577 },
1578 }, auth_header($server{$name}{access}));
1579
1580 my $put_swap_record = post_json($server{$name}{origin}, 'com.atproto.repo.putRecord', {
1581 repo => $server{$name}{did},
1582 collection => 'app.bsky.feed.post',
1583 rkey => 'diffpost',
1584 swapRecord => 'bafyreifakecidmismatch',
1585 record => {
1586 '$type' => 'app.bsky.feed.post',
1587 text => "put swapRecord mismatch for $name",
1588 createdAt => '2026-03-11T00:00:03Z',
1589 },
1590 }, auth_header($server{$name}{access}));
1591
1592 my $delete_swap_commit = post_json($server{$name}{origin}, 'com.atproto.repo.deleteRecord', {
1593 repo => $server{$name}{did},
1594 collection => 'app.bsky.feed.post',
1595 rkey => 'diffpost',
1596 swapCommit => 'bafyreifakeheadmismatch',
1597 }, auth_header($server{$name}{access}));
1598
1599 my $delete_swap_record = post_json($server{$name}{origin}, 'com.atproto.repo.deleteRecord', {
1600 repo => $server{$name}{did},
1601 collection => 'app.bsky.feed.post',
1602 rkey => 'diffpost',
1603 swapRecord => $server{$name}{record_cid},
1604 }, auth_header($server{$name}{access}));
1605
1606 $server{$name}{swap_preconditions} = {
1607 put_swap_commit => {
1608 status => $put_swap_commit->code // 0,
1609 error => ($put_swap_commit->json || {})->{error} // q(),
1610 message => normalize_swap_message(($put_swap_commit->json || {})->{message}),
1611 },
1612 put_swap_record => {
1613 status => $put_swap_record->code // 0,
1614 error => ($put_swap_record->json || {})->{error} // q(),
1615 message => normalize_swap_message(($put_swap_record->json || {})->{message}),
1616 },
1617 delete_swap_commit => {
1618 status => $delete_swap_commit->code // 0,
1619 error => ($delete_swap_commit->json || {})->{error} // q(),
1620 message => normalize_swap_message(($delete_swap_commit->json || {})->{message}),
1621 },
1622 delete_swap_record => {
1623 status => $delete_swap_record->code // 0,
1624 error => ($delete_swap_record->json || {})->{error} // q(),
1625 message => normalize_swap_message(($delete_swap_record->json || {})->{message}),
1626 },
1627 };
1628}
1629
1630if (!same_hash($server{reference}{swap_preconditions}, $server{perlsky}{swap_preconditions})) {
1631 note('reference swap preconditions: ' . encode_json($server{reference}{swap_preconditions}));
1632 note('perlsky swap preconditions: ' . encode_json($server{perlsky}{swap_preconditions}));
1633 fail_check('repo write swap preconditions match the official reference PDS');
1634} else {
1635 pass('repo write swap preconditions match the official reference PDS');
1636}
1637
1638note('Comparing moderation takedown behavior');
1639for my $name (sort keys %server) {
1640 my $res = post_json(
1641 $server{$name}{origin},
1642 'com.atproto.admin.updateSubjectStatus',
1643 {
1644 subject => {
1645 '$type' => 'com.atproto.admin.defs#repoRef',
1646 did => $server{$name}{did},
1647 },
1648 takedown => { applied => true },
1649 },
1650 admin_auth_header($server{$name}{admin_password}),
1651 );
1652 check($res->is_success, "$name repo takedown succeeds");
1653 next unless $res->is_success;
1654 my $repo_takedown_json = $res->json || {};
1655
1656 my $blocked_login = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
1657 identifier => $server{$name}{renamed_handle} || $server{$name}{handle},
1658 password => 'hunter22',
1659 });
1660 my $allowed_login = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
1661 identifier => $server{$name}{renamed_handle} || $server{$name}{handle},
1662 password => 'hunter22',
1663 allowTakendown => true,
1664 });
1665
1666 my $blocked_write = $allowed_login->is_success
1667 ? post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
1668 repo => $server{$name}{did},
1669 collection => 'app.bsky.feed.post',
1670 rkey => 'takedown-diff',
1671 record => {
1672 %{$record},
1673 text => "takedown write validation for $name",
1674 },
1675 }, auth_header(($allowed_login->json || {})->{accessJwt}))
1676 : undef;
1677
1678 my $blocked_list = get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
1679 repo => $server{$name}{did},
1680 collection => 'app.bsky.feed.post',
1681 });
1682
1683 $server{$name}{repo_takedown} = {
1684 login_blocked => $blocked_login->is_success ? 0 : 1,
1685 login_error => ($blocked_login->json || {})->{error},
1686 allow_login => $allowed_login->is_success ? 1 : 0,
1687 write_blocked => ($blocked_write && !$blocked_write->is_success) ? 1 : 0,
1688 write_error => $blocked_write ? (($blocked_write->json || {})->{error}) : undef,
1689 list_blocked => $blocked_list->is_success ? 0 : 1,
1690 list_error => ($blocked_list->json || {})->{error},
1691 response_subject_type => $repo_takedown_json->{subject}{'$type'},
1692 response_takedown => $repo_takedown_json->{takedown}{applied} ? 1 : 0,
1693 response_has_deactivated => exists($repo_takedown_json->{deactivated}) ? 1 : 0,
1694 };
1695
1696 $res = post_json(
1697 $server{$name}{origin},
1698 'com.atproto.admin.updateSubjectStatus',
1699 {
1700 subject => {
1701 '$type' => 'com.atproto.admin.defs#repoRef',
1702 did => $server{$name}{did},
1703 },
1704 takedown => { applied => false },
1705 },
1706 admin_auth_header($server{$name}{admin_password}),
1707 );
1708 check($res->is_success, "$name repo takedown restore succeeds");
1709
1710 $res = post_json(
1711 $server{$name}{origin},
1712 'com.atproto.admin.updateSubjectStatus',
1713 {
1714 subject => {
1715 '$type' => 'com.atproto.repo.strongRef',
1716 uri => $server{$name}{record_uri},
1717 cid => $server{$name}{record_cid},
1718 },
1719 takedown => { applied => true },
1720 },
1721 admin_auth_header($server{$name}{admin_password}),
1722 );
1723 check($res->is_success, "$name record takedown succeeds");
1724 next unless $res->is_success;
1725 my $record_takedown_json = $res->json || {};
1726
1727 my $record_uri = $server{$name}{record_uri};
1728 my ($collection, $rkey) = $record_uri =~ m{at://[^/]+/([^/]+)/([^/?#]+)\z};
1729 my $get_record = get_form($server{$name}{origin}, 'com.atproto.repo.getRecord', {
1730 repo => $server{$name}{did},
1731 collection => $collection,
1732 rkey => $rkey,
1733 });
1734 my $list_records = get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
1735 repo => $server{$name}{did},
1736 collection => $collection,
1737 });
1738
1739 my $records = $list_records->is_success ? ($list_records->json->{records} || []) : [];
1740 my $record_hidden = !(grep { (($_->{uri} // q()) eq $record_uri) } @$records);
1741 my $record_subject_status = get_form(
1742 $server{$name}{origin},
1743 'com.atproto.admin.getSubjectStatus',
1744 { uri => $record_uri },
1745 admin_auth_header($server{$name}{admin_password}),
1746 );
1747 my $record_subject_json = $record_subject_status->json || {};
1748 $server{$name}{record_takedown} = {
1749 get_blocked => $get_record->is_success ? 0 : 1,
1750 get_error => ($get_record->json || {})->{error},
1751 list_hidden => $record_hidden ? 1 : 0,
1752 list_success => $list_records->is_success ? 1 : 0,
1753 response_subject_type => $record_takedown_json->{subject}{'$type'},
1754 response_takedown => $record_takedown_json->{takedown}{applied} ? 1 : 0,
1755 response_has_deactivated => exists($record_takedown_json->{deactivated}) ? 1 : 0,
1756 subject_status_ok => $record_subject_status->is_success ? 1 : 0,
1757 subject_status_type => $record_subject_json->{subject}{'$type'},
1758 subject_status_takedown => $record_subject_json->{takedown}{applied} ? 1 : 0,
1759 };
1760
1761 my $sync_record = get_form($server{$name}{origin}, 'com.atproto.sync.getRecord', {
1762 did => $server{$name}{did},
1763 collection => $collection,
1764 rkey => $rkey,
1765 });
1766 my $sync_car = $sync_record->is_success ? read_car($sync_record->body // q()) : undef;
1767 $server{$name}{record_takedown_sync} = {
1768 proof_ok => $sync_record->is_success ? 1 : 0,
1769 proof_is_car => (($sync_record->headers->content_type // q()) =~ m{application/vnd\.ipld\.car}) ? 1 : 0,
1770 proof_has_record => (
1771 $sync_car
1772 && scalar(grep { $_->{cid}->to_string eq $server{$name}{record_cid} } @{ $sync_car->{blocks} || [] })
1773 ) ? 1 : 0,
1774 };
1775
1776 $res = post_json(
1777 $server{$name}{origin},
1778 'com.atproto.admin.updateSubjectStatus',
1779 {
1780 subject => {
1781 '$type' => 'com.atproto.repo.strongRef',
1782 uri => $record_uri,
1783 cid => $server{$name}{record_cid},
1784 },
1785 takedown => { applied => false },
1786 },
1787 admin_auth_header($server{$name}{admin_password}),
1788 );
1789 check($res->is_success, "$name record takedown restore succeeds");
1790}
1791
1792check(
1793 same_hash($server{reference}{repo_takedown}, $server{perlsky}{repo_takedown}),
1794 'repo takedown login and write semantics match the official reference PDS',
1795);
1796
1797check(
1798 same_hash($server{reference}{record_takedown}, $server{perlsky}{record_takedown}),
1799 'record takedown visibility semantics match the official reference PDS',
1800);
1801
1802check(
1803 same_hash($server{reference}{record_takedown_sync}, $server{perlsky}{record_takedown_sync}),
1804 'record takedown sync proof semantics match the official reference PDS',
1805);
1806
1807note('Comparing sync.getRepoStatus status semantics');
1808for my $name (sort keys %server) {
1809 my $active = get_form($server{$name}{origin}, 'com.atproto.sync.getRepoStatus', {
1810 did => $server{$name}{did},
1811 });
1812 check($active->is_success, "$name active getRepoStatus succeeds");
1813
1814 my $deactivate = post_json(
1815 $server{$name}{origin},
1816 'com.atproto.server.deactivateAccount',
1817 {},
1818 auth_header($server{$name}{access}),
1819 );
1820 check($deactivate->is_success, "$name deactivateAccount succeeds for repo status comparison");
1821
1822 my $deactivated = get_form($server{$name}{origin}, 'com.atproto.sync.getRepoStatus', {
1823 did => $server{$name}{did},
1824 });
1825 check($deactivated->is_success, "$name deactivated getRepoStatus succeeds");
1826
1827 my $deactivated_session = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
1828 identifier => $server{$name}{renamed_handle} || $server{$name}{handle},
1829 password => 'hunter22',
1830 });
1831 check($deactivated_session->is_success, "$name deactivated createSession succeeds for repo status comparison");
1832
1833 my $reactivate = post_json(
1834 $server{$name}{origin},
1835 'com.atproto.admin.updateSubjectStatus',
1836 {
1837 subject => {
1838 '$type' => 'com.atproto.admin.defs#repoRef',
1839 did => $server{$name}{did},
1840 },
1841 deactivated => { applied => false },
1842 },
1843 admin_auth_header($server{$name}{admin_password}),
1844 );
1845 check($reactivate->is_success, "$name repo reactivation succeeds for repo status comparison");
1846 my $reactivate_json = $reactivate->json || {};
1847
1848 my $takedown = post_json(
1849 $server{$name}{origin},
1850 'com.atproto.admin.updateSubjectStatus',
1851 {
1852 subject => {
1853 '$type' => 'com.atproto.admin.defs#repoRef',
1854 did => $server{$name}{did},
1855 },
1856 takedown => { applied => true },
1857 },
1858 admin_auth_header($server{$name}{admin_password}),
1859 );
1860 check($takedown->is_success, "$name repo takedown succeeds for repo status comparison");
1861
1862 my $takendown = get_form($server{$name}{origin}, 'com.atproto.sync.getRepoStatus', {
1863 did => $server{$name}{did},
1864 });
1865 check($takendown->is_success, "$name takendown getRepoStatus succeeds");
1866
1867 my $restore = post_json(
1868 $server{$name}{origin},
1869 'com.atproto.admin.updateSubjectStatus',
1870 {
1871 subject => {
1872 '$type' => 'com.atproto.admin.defs#repoRef',
1873 did => $server{$name}{did},
1874 },
1875 takedown => { applied => false },
1876 },
1877 admin_auth_header($server{$name}{admin_password}),
1878 );
1879 check($restore->is_success, "$name repo takedown restore succeeds for repo status comparison");
1880
1881 $server{$name}{repo_status_surface} = {
1882 active => {
1883 ok => $active->is_success ? 1 : 0,
1884 active => ($active->json || {})->{active} ? 1 : 0,
1885 status => ($active->json || {})->{status},
1886 has_rev => defined(($active->json || {})->{rev}) ? 1 : 0,
1887 },
1888 deactivated => {
1889 ok => $deactivated->is_success ? 1 : 0,
1890 active => ($deactivated->json || {})->{active} ? 1 : 0,
1891 status => ($deactivated->json || {})->{status},
1892 has_rev => defined(($deactivated->json || {})->{rev}) ? 1 : 0,
1893 },
1894 reactivate_response => {
1895 status => $reactivate->code // 0,
1896 subject_type => $reactivate_json->{subject}{'$type'},
1897 has_takedown => exists($reactivate_json->{takedown}) ? 1 : 0,
1898 has_deactivated => exists($reactivate_json->{deactivated}) ? 1 : 0,
1899 },
1900 takendown => {
1901 ok => $takendown->is_success ? 1 : 0,
1902 active => ($takendown->json || {})->{active} ? 1 : 0,
1903 status => ($takendown->json || {})->{status},
1904 has_rev => defined(($takendown->json || {})->{rev}) ? 1 : 0,
1905 },
1906 };
1907}
1908
1909check(
1910 same_hash($server{reference}{repo_status_surface}, $server{perlsky}{repo_status_surface}),
1911 'sync.getRepoStatus active, deactivated, and takendown semantics match the official reference PDS',
1912);
1913
1914note('Comparing describeRepo');
1915for my $name (sort keys %server) {
1916 my $res = get_form($server{$name}{origin}, 'com.atproto.repo.describeRepo', {
1917 repo => $server{$name}{did},
1918 });
1919 check($res->is_success, "$name describeRepo succeeds");
1920 next unless $res->is_success;
1921 my $json = $res->json || {};
1922 $server{$name}{describe_repo} = {
1923 handle_matches_account => (($json->{handle} // q()) eq ($server{$name}{handle} // q())) ? 1 : 0,
1924 did_matches_account => (($json->{did} // q()) eq ($server{$name}{did} // q())) ? 1 : 0,
1925 did_doc_id_matches_did => (($json->{didDoc}{id} // q()) eq ($server{$name}{did} // q())) ? 1 : 0,
1926 handle_is_correct => $json->{handleIsCorrect} ? 1 : 0,
1927 collections_nonempty => @{ $json->{collections} || [] } >= 1 ? 1 : 0,
1928 };
1929}
1930
1931check(
1932 same_hash($server{reference}{describe_repo}, $server{perlsky}{describe_repo}),
1933 'describeRepo matches the official reference PDS semantics',
1934);
1935
1936note('Comparing missing-repo read semantics');
1937for my $name (sort keys %server) {
1938 my $missing_did = 'did:web:missing.test';
1939 $server{$name}{missing_repo_reads} = {
1940 describe_repo => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.repo.describeRepo', {
1941 repo => $missing_did,
1942 })),
1943 list_records => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
1944 repo => $missing_did,
1945 collection => 'app.bsky.feed.post',
1946 })),
1947 latest_commit => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.sync.getLatestCommit', {
1948 did => $missing_did,
1949 })),
1950 sync_record => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.sync.getRecord', {
1951 did => $missing_did,
1952 collection => 'app.bsky.feed.post',
1953 rkey => 'diffpost',
1954 })),
1955 repo_export => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.sync.getRepo', {
1956 did => $missing_did,
1957 })),
1958 checkout_export => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.sync.getCheckout', {
1959 did => $missing_did,
1960 })),
1961 head => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.sync.getHead', {
1962 did => $missing_did,
1963 })),
1964 repo_status => normalize_xrpc_error(get_form($server{$name}{origin}, 'com.atproto.sync.getRepoStatus', {
1965 did => $missing_did,
1966 })),
1967 };
1968}
1969
1970if (!same_hash($server{reference}{missing_repo_reads}, $server{perlsky}{missing_repo_reads})) {
1971 note('reference missing repo reads: ' . encode_json($server{reference}{missing_repo_reads}));
1972 note('perlsky missing repo reads: ' . encode_json($server{perlsky}{missing_repo_reads}));
1973 fail_check('missing-repo read semantics match the official reference PDS');
1974} else {
1975 pass('missing-repo read semantics match the official reference PDS');
1976}
1977
1978note('Comparing listRecords');
1979for my $name (sort keys %server) {
1980 my $res = get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
1981 repo => $server{$name}{did},
1982 collection => 'app.bsky.feed.post',
1983 });
1984 check($res->is_success, "$name listRecords succeeds");
1985 next unless $res->is_success;
1986 my $records = $res->json->{records} || [];
1987 check(@{$records} >= 1, "$name listRecords returns at least one record");
1988 my %by_rkey = map {
1989 my ($rkey) = (($_->{uri} // q()) =~ m{/([^/?#]+)\z});
1990 ($rkey // q()) => $_;
1991 } @$records;
1992 $server{$name}{list_records} = {
1993 count => 0 + @$records,
1994 has_diffpost => exists $by_rkey{diffpost} ? 1 : 0,
1995 diffpost_updated => (($by_rkey{diffpost}{value}{text} // q()) =~ /^put update validation /) ? 1 : 0,
1996 has_put_created => exists $by_rkey{'put-created'} ? 1 : 0,
1997 put_created_matches => (($by_rkey{'put-created'}{value}{text} // q()) =~ /^put create validation /) ? 1 : 0,
1998 };
1999}
2000
2001check(
2002 same_hash($server{reference}{list_records}, $server{perlsky}{list_records}),
2003 'listRecords returns the same normalized record set as the official reference PDS',
2004);
2005
2006note('Comparing getLatestCommit');
2007for my $name (sort keys %server) {
2008 my $res = get_form($server{$name}{origin}, 'com.atproto.sync.getLatestCommit', { did => $server{$name}{did} });
2009 check($res->is_success, "$name getLatestCommit succeeds");
2010 next unless $res->is_success;
2011 my $json = $res->json;
2012 $server{$name}{latest_commit_raw} = $json;
2013 $server{$name}{latest_commit} = {
2014 has_cid => defined($json->{cid}) && length($json->{cid}) ? 1 : 0,
2015 has_rev => defined($json->{rev}) && length($json->{rev}) ? 1 : 0,
2016 };
2017 check(defined $json->{cid} && length $json->{cid}, "$name getLatestCommit returns a CID");
2018 check(defined $json->{rev} && length $json->{rev}, "$name getLatestCommit returns a rev");
2019}
2020
2021check(
2022 same_hash($server{reference}{latest_commit}, $server{perlsky}{latest_commit}),
2023 'getLatestCommit matches the official reference PDS semantics',
2024);
2025
2026note('Comparing checkAccountStatus');
2027for my $name (sort keys %server) {
2028 my $res = get_form(
2029 $server{$name}{origin},
2030 'com.atproto.server.checkAccountStatus',
2031 {},
2032 auth_header($server{$name}{access}),
2033 );
2034 check($res->is_success, "$name checkAccountStatus succeeds");
2035 next unless $res->is_success;
2036 my $json = $res->json || {};
2037 $server{$name}{check_account_status} = {
2038 activated => $json->{activated} ? 1 : 0,
2039 valid_did => $json->{validDid} ? 1 : 0,
2040 repo_commit_matches_head => (($json->{repoCommit} // q()) eq ($server{$name}{latest_commit_raw}{cid} // q())) ? 1 : 0,
2041 repo_rev_matches_head => (($json->{repoRev} // q()) eq ($server{$name}{latest_commit_raw}{rev} // q())) ? 1 : 0,
2042 repo_blocks_positive => ($json->{repoBlocks} // 0) > 0 ? 1 : 0,
2043 indexed_records_positive => ($json->{indexedRecords} // 0) > 0 ? 1 : 0,
2044 private_state_values => 0 + ($json->{privateStateValues} // 0),
2045 blob_counts_match => (($json->{expectedBlobs} // -1) == ($json->{importedBlobs} // -2)) ? 1 : 0,
2046 };
2047}
2048
2049check(
2050 same_hash($server{reference}{check_account_status}, $server{perlsky}{check_account_status}),
2051 'checkAccountStatus matches the official reference PDS semantics',
2052);
2053
2054note('Comparing getHead');
2055for my $name (sort keys %server) {
2056 my $res = get_form($server{$name}{origin}, 'com.atproto.sync.getHead', { did => $server{$name}{did} });
2057 check($res->is_success, "$name getHead succeeds");
2058 next unless $res->is_success;
2059 my $json = $res->json || {};
2060 $server{$name}{head} = {
2061 has_root => defined($json->{root}) && length($json->{root}) ? 1 : 0,
2062 matches_latest_commit => (($json->{root} // q()) eq (($server{$name}{latest_commit_raw}{cid} // q()))) ? 1 : 0,
2063 };
2064}
2065
2066check(
2067 same_hash($server{reference}{head}, $server{perlsky}{head}),
2068 'getHead matches the official reference PDS semantics',
2069);
2070
2071note('Comparing getBlocks');
2072for my $name (sort keys %server) {
2073 my $requested_cid = $server{$name}{latest_commit_raw}{cid};
2074 my $res = get_form($server{$name}{origin}, 'com.atproto.sync.getBlocks', {
2075 did => $server{$name}{did},
2076 cids => $requested_cid,
2077 });
2078 check($res->is_success, "$name getBlocks succeeds");
2079 my $car = $res->is_success ? read_car($res->body // q()) : undef;
2080
2081 my $no_cids = get_form($server{$name}{origin}, 'com.atproto.sync.getBlocks', {
2082 did => $server{$name}{did},
2083 });
2084 my $missing = get_form($server{$name}{origin}, 'com.atproto.sync.getBlocks', {
2085 did => $server{$name}{did},
2086 cids => 'bafyreifakecidmismatch',
2087 });
2088 my $missing_repo = get_form($server{$name}{origin}, 'com.atproto.sync.getBlocks', {
2089 did => 'did:web:missing.test',
2090 cids => $requested_cid,
2091 });
2092 my $wrong_repo = get_form($server{$name}{origin}, 'com.atproto.sync.getBlocks', {
2093 did => $server{$name}{secondary_did},
2094 cids => $requested_cid,
2095 });
2096
2097 $server{$name}{get_blocks} = {
2098 ok => $res->is_success ? 1 : 0,
2099 car_type => (($res->headers->content_type // q()) =~ m{application/vnd\.ipld\.car}) ? 1 : 0,
2100 roots_empty => ($car && !@{ $car->{roots} || [] }) ? 1 : 0,
2101 has_requested_cid => ($car && scalar(grep { $_->{cid}->to_string eq $requested_cid } @{ $car->{blocks} || [] })) ? 1 : 0,
2102 no_cids => normalize_xrpc_error($no_cids),
2103 missing => normalize_xrpc_error($missing),
2104 missing_repo => normalize_xrpc_error($missing_repo),
2105 wrong_repo => normalize_xrpc_error($wrong_repo),
2106 };
2107}
2108
2109check(
2110 same_hash($server{reference}{get_blocks}, $server{perlsky}{get_blocks}),
2111 'getBlocks repo scoping and missing-CID semantics match the official reference PDS',
2112);
2113
2114note('Comparing getRepo CAR exports');
2115for my $name (sort keys %server) {
2116 my $res = get_form($server{$name}{origin}, 'com.atproto.sync.getRepo', { did => $server{$name}{did} });
2117 check($res->is_success, "$name getRepo succeeds");
2118 next unless $res->is_success;
2119 my $ctype = $res->headers->content_type // q();
2120 check($ctype =~ m{application/vnd\.ipld\.car}, "$name getRepo returns CAR bytes");
2121 check(length($res->body // q()) > 0, "$name getRepo CAR payload is non-empty");
2122 $server{$name}{repo_snapshot_car} = $res->body;
2123 $server{$name}{repo_export} = normalize_repo_export(
2124 $res->body,
2125 $server{$name}{latest_commit_raw}{cid},
2126 );
2127}
2128
2129check(
2130 same_hash($server{reference}{repo_export}, $server{perlsky}{repo_export}),
2131 'getRepo matches the official reference PDS semantics',
2132);
2133
2134note('Comparing getCheckout CAR exports');
2135for my $name (sort keys %server) {
2136 my $res = get_form($server{$name}{origin}, 'com.atproto.sync.getCheckout', { did => $server{$name}{did} });
2137 check($res->is_success, "$name getCheckout succeeds");
2138 next unless $res->is_success;
2139 my $ctype = $res->headers->content_type // q();
2140 my $normalized = normalize_repo_export(
2141 $res->body,
2142 $server{$name}{latest_commit_raw}{cid},
2143 );
2144 $server{$name}{checkout} = {
2145 car_type => $ctype =~ m{application/vnd\.ipld\.car} ? 1 : 0,
2146 nonempty => length($res->body // q()) > 0 ? 1 : 0,
2147 %{$normalized},
2148 };
2149}
2150
2151check(
2152 same_hash($server{reference}{checkout}, $server{perlsky}{checkout}),
2153 'getCheckout matches the official reference PDS semantics',
2154);
2155
2156note('Comparing listBlobs since semantics');
2157for my $name (sort keys %server) {
2158 my $upload = post_bytes(
2159 $server{$name}{origin},
2160 'com.atproto.repo.uploadBlob',
2161 'sync blob bytes',
2162 'text/plain',
2163 auth_header($server{$name}{access}),
2164 );
2165 check($upload->is_success, "$name uploadBlob succeeds for listBlobs comparison");
2166 next unless $upload->is_success;
2167
2168 my $blob = ($upload->json || {})->{blob};
2169 my $preref_blob = get_form($server{$name}{origin}, 'com.atproto.sync.getBlob', {
2170 did => $server{$name}{did},
2171 cid => $blob->{ref}{'$link'},
2172 });
2173 my $create = post_json(
2174 $server{$name}{origin},
2175 'com.atproto.repo.createRecord',
2176 {
2177 repo => $server{$name}{did},
2178 collection => 'com.example.blobtest',
2179 rkey => 'blobtest',
2180 record => {
2181 '$type' => 'com.example.blobtest',
2182 blob => $blob,
2183 },
2184 },
2185 auth_header($server{$name}{access}),
2186 );
2187 check($create->is_success, "$name createRecord with blob succeeds for listBlobs comparison");
2188 next unless $create->is_success;
2189
2190 my $secondary_upload = post_bytes(
2191 $server{$name}{origin},
2192 'com.atproto.repo.uploadBlob',
2193 'sync blob bytes',
2194 'text/plain',
2195 auth_header($server{$name}{secondary_access}),
2196 );
2197 check($secondary_upload->is_success, "$name secondary uploadBlob succeeds for listBlobs comparison");
2198 next unless $secondary_upload->is_success;
2199
2200 my $res = get_form($server{$name}{origin}, 'com.atproto.sync.listBlobs', {
2201 did => $server{$name}{did},
2202 since => $server{$name}{latest_commit_raw}{rev},
2203 });
2204 my $secondary_res = get_form($server{$name}{origin}, 'com.atproto.sync.listBlobs', {
2205 did => $server{$name}{secondary_did},
2206 });
2207 my $missing_repo = get_form($server{$name}{origin}, 'com.atproto.sync.listBlobs', {
2208 did => 'did:web:missing.test',
2209 });
2210 check($res->is_success, "$name listBlobs with since succeeds");
2211 check($secondary_res->is_success, "$name secondary listBlobs succeeds");
2212 my $json = $res->json || {};
2213 my $secondary_json = $secondary_res->json || {};
2214 my $blob_cid = $blob->{ref}{'$link'};
2215 $server{$name}{sync_blob} = {
2216 cid => $blob_cid,
2217 };
2218 $server{$name}{list_blobs_since} = {
2219 ok => $res->is_success ? 1 : 0,
2220 returns_blob => (scalar grep { $_ eq $blob_cid } @{ $json->{cids} || [] }) ? 1 : 0,
2221 cursor_matches_tail => (($json->{cursor} // q()) eq (($json->{cids} || [])->[-1] // q())) ? 1 : 0,
2222 preref_blob => normalize_xrpc_error($preref_blob),
2223 secondary_empty => @{ $secondary_json->{cids} || [] } ? 0 : 1,
2224 missing_repo => normalize_xrpc_error($missing_repo),
2225 };
2226}
2227
2228if (!same_hash($server{reference}{list_blobs_since}, $server{perlsky}{list_blobs_since})) {
2229 note('reference listBlobs since: ' . encode_json($server{reference}{list_blobs_since}));
2230 note('perlsky listBlobs since: ' . encode_json($server{perlsky}{list_blobs_since}));
2231 fail_check('listBlobs since semantics match the official reference PDS');
2232} else {
2233 pass('listBlobs since semantics match the official reference PDS');
2234}
2235
2236note('Comparing getBlob');
2237for my $name (sort keys %server) {
2238 my $blob_cid = $server{$name}{sync_blob}{cid};
2239 my $res = get_form($server{$name}{origin}, 'com.atproto.sync.getBlob', {
2240 did => $server{$name}{did},
2241 cid => $blob_cid,
2242 });
2243 my $secondary = get_form($server{$name}{origin}, 'com.atproto.sync.getBlob', {
2244 did => $server{$name}{secondary_did},
2245 cid => $blob_cid,
2246 });
2247 my $missing_repo = get_form($server{$name}{origin}, 'com.atproto.sync.getBlob', {
2248 did => 'did:web:missing.test',
2249 cid => $blob_cid,
2250 });
2251 check($res->is_success, "$name getBlob succeeds");
2252 next unless $res->is_success;
2253 my $content_type = $res->headers->content_type // q();
2254 my $disposition = $res->headers->header('Content-Disposition') // q();
2255 $server{$name}{get_blob} = {
2256 body_matches => (($res->body // q()) eq 'sync blob bytes') ? 1 : 0,
2257 content_type_plain => ($content_type =~ /\Atext\/plain(?:\z|;)/) ? 1 : 0,
2258 nosniff => (($res->headers->header('X-Content-Type-Options') // q()) eq 'nosniff') ? 1 : 0,
2259 csp_sandbox => (($res->headers->header('Content-Security-Policy') // q()) eq q{default-src 'none'; sandbox}) ? 1 : 0,
2260 attachment_name => ($disposition =~ /\Aattachment; filename="/) ? 1 : 0,
2261 secondary => normalize_xrpc_error($secondary),
2262 missing_repo => normalize_xrpc_error($missing_repo),
2263 };
2264}
2265
2266check(
2267 same_hash($server{reference}{get_blob}, $server{perlsky}{get_blob}),
2268 'getBlob payload and hardening headers match the official reference PDS',
2269);
2270
2271note('Comparing blob subject-status semantics');
2272for my $name (sort keys %server) {
2273 my $blob_cid = $server{$name}{sync_blob}{cid};
2274 my $takedown = post_json(
2275 $server{$name}{origin},
2276 'com.atproto.admin.updateSubjectStatus',
2277 {
2278 subject => {
2279 '$type' => 'com.atproto.admin.defs#repoBlobRef',
2280 did => $server{$name}{did},
2281 cid => $blob_cid,
2282 },
2283 takedown => { applied => true },
2284 },
2285 admin_auth_header($server{$name}{admin_password}),
2286 );
2287 check($takedown->is_success, "$name blob takedown succeeds for subject-status comparison");
2288 next unless $takedown->is_success;
2289
2290 my $takedown_json = $takedown->json || {};
2291 my $status = get_form(
2292 $server{$name}{origin},
2293 'com.atproto.admin.getSubjectStatus',
2294 {
2295 did => $server{$name}{did},
2296 blob => $blob_cid,
2297 },
2298 admin_auth_header($server{$name}{admin_password}),
2299 );
2300 my $status_json = $status->json || {};
2301
2302 my $restore = post_json(
2303 $server{$name}{origin},
2304 'com.atproto.admin.updateSubjectStatus',
2305 {
2306 subject => {
2307 '$type' => 'com.atproto.admin.defs#repoBlobRef',
2308 did => $server{$name}{did},
2309 cid => $blob_cid,
2310 },
2311 takedown => { applied => false },
2312 },
2313 admin_auth_header($server{$name}{admin_password}),
2314 );
2315 check($restore->is_success, "$name blob takedown restore succeeds for subject-status comparison");
2316
2317 $server{$name}{blob_subject_status} = {
2318 update_subject_type => $takedown_json->{subject}{'$type'},
2319 update_takedown => $takedown_json->{takedown}{applied} ? 1 : 0,
2320 update_has_deactivated => exists($takedown_json->{deactivated}) ? 1 : 0,
2321 status_ok => $status->is_success ? 1 : 0,
2322 status_subject_type => $status_json->{subject}{'$type'},
2323 status_takedown => $status_json->{takedown}{applied} ? 1 : 0,
2324 restore_status => $restore->code // 0,
2325 };
2326}
2327
2328check(
2329 same_hash($server{reference}{blob_subject_status}, $server{perlsky}{blob_subject_status}),
2330 'blob subject-status semantics match the official reference PDS',
2331);
2332
2333note('Comparing listRepos');
2334for my $name (sort keys %server) {
2335 my $list_repos = get_form($server{$name}{origin}, 'com.atproto.sync.listRepos', {
2336 limit => 10,
2337 });
2338 check($list_repos->is_success, "$name listRepos succeeds");
2339 my $repos = $list_repos->is_success ? (($list_repos->json || {})->{repos} || []) : [];
2340 my ($repo_row) = grep { (($_->{did} // q()) eq $server{$name}{did}) } @$repos;
2341
2342 $server{$name}{list_repos_surface} = {
2343 repo_present => $repo_row ? 1 : 0,
2344 repo_active => (($repo_row || {})->{active} ? 1 : 0),
2345 repo_has_rev => defined(($repo_row || {})->{rev}) && length(($repo_row || {})->{rev}) ? 1 : 0,
2346 repo_did_matches => (($repo_row || {})->{did} // q()) eq $server{$name}{did} ? 1 : 0,
2347 };
2348}
2349
2350check(
2351 same_hash($server{reference}{list_repos_surface}, $server{perlsky}{list_repos_surface}),
2352 'listRepos matches the official reference PDS semantics',
2353);
2354
2355note('Comparing listMissingBlobs empty-state semantics');
2356for my $name (sort keys %server) {
2357 my $res = get_form($server{$name}{origin}, 'com.atproto.repo.listMissingBlobs', {}, auth_header($server{$name}{access}));
2358 check($res->is_success, "$name listMissingBlobs succeeds");
2359 next unless $res->is_success;
2360 my $json = $res->json || {};
2361 $server{$name}{list_missing_blobs} = {
2362 blobs_empty => (($json->{blobs} && ref($json->{blobs}) eq 'ARRAY' && !@{$json->{blobs}}) ? 1 : 0),
2363 has_cursor => exists $json->{cursor} ? 1 : 0,
2364 };
2365}
2366
2367check(
2368 same_hash($server{reference}{list_missing_blobs}, $server{perlsky}{list_missing_blobs}),
2369 'listMissingBlobs empty-state semantics match the official reference PDS',
2370);
2371
2372note('Comparing importRepo snapshot restore');
2373for my $name (sort keys %server) {
2374 my $res = post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
2375 repo => $server{$name}{did},
2376 collection => 'app.bsky.feed.post',
2377 rkey => 'import-diff',
2378 record => {
2379 %{$record},
2380 text => "import validation for $name",
2381 },
2382 }, auth_header($server{$name}{access}));
2383 check($res->is_success, "$name creates an extra record before importRepo");
2384 next unless $res->is_success;
2385
2386 my $import = post_bytes(
2387 $server{$name}{origin},
2388 'com.atproto.repo.importRepo',
2389 $server{$name}{repo_snapshot_car},
2390 'application/vnd.ipld.car',
2391 auth_header($server{$name}{access}),
2392 );
2393 check($import->is_success, "$name importRepo succeeds");
2394 next unless $import->is_success;
2395
2396 $res = get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
2397 repo => $server{$name}{did},
2398 collection => 'app.bsky.feed.post',
2399 });
2400 check($res->is_success, "$name listRecords succeeds after importRepo");
2401 next unless $res->is_success;
2402 my $records = $res->json->{records} || [];
2403 my @rkeys = sort map {
2404 my ($rkey) = (($_->{uri} // q()) =~ m{/([^/?#]+)\z});
2405 $rkey // q();
2406 } @$records;
2407 $server{$name}{import_repo_state} = {
2408 import_status => $import->code // 0,
2409 import_body => $import->body,
2410 record_count => 0 + @$records,
2411 rkeys => \@rkeys,
2412 restored_diffpost => scalar(grep { $_ eq 'diffpost' } @rkeys) ? 1 : 0,
2413 restored_put => scalar(grep { $_ eq 'put-created' } @rkeys) ? 1 : 0,
2414 dropped_import => scalar(grep { $_ eq 'import-diff' } @rkeys) ? 0 : 1,
2415 };
2416}
2417
2418check(
2419 same_hash($server{reference}{import_repo_state}, $server{perlsky}{import_repo_state}),
2420 'importRepo restores the same normalized repo state as the official reference PDS',
2421);
2422
2423note('Comparing firehose live follow behavior');
2424for my $name (sort keys %server) {
2425 my $quiet = quiet_firehose("$server{$name}{origin}/xrpc/com.atproto.sync.subscribeRepos");
2426 check($quiet, "$name subscribeRepos stays quiet with no cursor before a new write");
2427}
2428
2429for my $name (sort keys %server) {
2430 my $path = 'app.bsky.feed.post/firehose-diff';
2431 my $frame = next_commit_frame(
2432 "$server{$name}{origin}/xrpc/com.atproto.sync.subscribeRepos",
2433 $path,
2434 sub {
2435 my $res = post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
2436 repo => $server{$name}{did},
2437 collection => 'app.bsky.feed.post',
2438 rkey => 'firehose-diff',
2439 record => {
2440 %{$record},
2441 text => "firehose validation for $name",
2442 },
2443 }, auth_header($server{$name}{access}));
2444 die "createRecord for firehose failed on $name\n" unless $res->is_success;
2445 },
2446 );
2447 $server{$name}{firehose_commit} = normalize_commit_frame($frame, $server{$name}{did});
2448 check($server{$name}{firehose_commit}{repo_match}, "$name firehose commit belongs to the created repo");
2449}
2450
2451check(
2452 same_hash($server{reference}{firehose_commit}, $server{perlsky}{firehose_commit}),
2453 'subscribeRepos emits the same normalized commit semantics as the official reference PDS',
2454);
2455
2456note('Comparing firehose update behavior');
2457for my $name (sort keys %server) {
2458 my $path = 'app.bsky.feed.post/firehose-diff';
2459 my $frame = next_commit_frame(
2460 "$server{$name}{origin}/xrpc/com.atproto.sync.subscribeRepos",
2461 $path,
2462 sub {
2463 my $res = post_json($server{$name}{origin}, 'com.atproto.repo.putRecord', {
2464 repo => $server{$name}{did},
2465 collection => 'app.bsky.feed.post',
2466 rkey => 'firehose-diff',
2467 record => {
2468 %{$record},
2469 text => "firehose update validation for $name",
2470 },
2471 }, auth_header($server{$name}{access}));
2472 die "putRecord for firehose failed on $name\n" unless $res->is_success;
2473 },
2474 );
2475 $server{$name}{firehose_update_commit} = normalize_commit_frame($frame, $server{$name}{did});
2476 check(($server{$name}{firehose_update_commit}{action} // q()) eq 'update', "$name firehose update emits an update op");
2477}
2478
2479check(
2480 same_hash($server{reference}{firehose_update_commit}, $server{perlsky}{firehose_update_commit}),
2481 'subscribeRepos emits the same normalized update semantics as the official reference PDS',
2482);
2483
2484note('Comparing firehose delete behavior');
2485for my $name (sort keys %server) {
2486 my $path = 'app.bsky.feed.post/firehose-diff';
2487 my $frame = next_commit_frame(
2488 "$server{$name}{origin}/xrpc/com.atproto.sync.subscribeRepos",
2489 $path,
2490 sub {
2491 my $res = post_json($server{$name}{origin}, 'com.atproto.repo.deleteRecord', {
2492 repo => $server{$name}{did},
2493 collection => 'app.bsky.feed.post',
2494 rkey => 'firehose-diff',
2495 }, auth_header($server{$name}{access}));
2496 die "deleteRecord for firehose failed on $name\n" unless $res->is_success;
2497 },
2498 );
2499 $server{$name}{firehose_delete_commit} = normalize_commit_frame($frame, $server{$name}{did});
2500 check(($server{$name}{firehose_delete_commit}{action} // q()) eq 'delete', "$name firehose delete emits a delete op");
2501}
2502
2503check(
2504 same_hash($server{reference}{firehose_delete_commit}, $server{perlsky}{firehose_delete_commit}),
2505 'subscribeRepos emits the same normalized delete semantics as the official reference PDS',
2506);
2507
2508note('Comparing future cursor error behavior');
2509for my $name (sort keys %server) {
2510 my $frame = first_frame("$server{$name}{origin}/xrpc/com.atproto.sync.subscribeRepos?cursor=999999999999");
2511 my $header = $frame->{header} || {};
2512 my $body = $frame->{body} || {};
2513 $server{$name}{future_cursor} = {
2514 op => $header->{op},
2515 error => $body->{error},
2516 };
2517}
2518
2519check(
2520 same_hash($server{reference}{future_cursor}, $server{perlsky}{future_cursor}),
2521 'subscribeRepos agrees on future cursor errors',
2522);
2523
2524note('Comparing method-less getServiceAuth expiration bounds');
2525my $unbound_service_auth_exp = int(time + 120);
2526for my $name (sort keys %server) {
2527 my $res = get_form(
2528 $server{$name}{origin},
2529 'com.atproto.server.getServiceAuth',
2530 {
2531 aud => 'did:web:api.bsky.app',
2532 exp => $unbound_service_auth_exp,
2533 },
2534 auth_header($server{$name}{access}),
2535 );
2536 $server{$name}{service_auth_unbound_exp} = normalize_xrpc_error($res);
2537}
2538
2539check(
2540 same_hash($server{reference}{service_auth_unbound_exp}, $server{perlsky}{service_auth_unbound_exp}),
2541 'getServiceAuth agrees on method-less expiration bounds',
2542);
2543
2544note('Comparing deleteSession revocation behavior');
2545for my $name (sort keys %server) {
2546 my $session = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
2547 identifier => $server{$name}{renamed_handle} || $server{$name}{handle},
2548 password => 'hunter22',
2549 });
2550 check($session->is_success, "$name createSession succeeds before deleteSession");
2551 next unless $session->is_success;
2552 my $json = $session->json || {};
2553 my $delete = post_empty(
2554 $server{$name}{origin},
2555 'com.atproto.server.deleteSession',
2556 auth_header($json->{refreshJwt}),
2557 );
2558 my $refresh_after_delete = post_empty(
2559 $server{$name}{origin},
2560 'com.atproto.server.refreshSession',
2561 auth_header($json->{refreshJwt}),
2562 );
2563 my $fresh_session = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
2564 identifier => $server{$name}{renamed_handle} || $server{$name}{handle},
2565 password => 'hunter22',
2566 });
2567 $server{$name}{delete_session} = {
2568 delete_ok => $delete->is_success ? 1 : 0,
2569 refresh_revoked => $refresh_after_delete->is_success ? 0 : 1,
2570 fresh_login_works => $fresh_session->is_success ? 1 : 0,
2571 };
2572}
2573
2574check(
2575 same_hash($server{reference}{delete_session}, $server{perlsky}{delete_session}),
2576 'deleteSession revocation behavior matches the official reference PDS',
2577);
2578
2579note('Comparing createRecord stray swapRecord handling');
2580for my $name (sort keys %server) {
2581 my $res = post_json($server{$name}{origin}, 'com.atproto.repo.createRecord', {
2582 repo => $server{$name}{did},
2583 collection => 'app.bsky.feed.post',
2584 rkey => 'swapcreate',
2585 swapRecord => 'bafyreifakecidmismatch',
2586 record => {
2587 %{$record},
2588 text => "swap create validation for $name",
2589 },
2590 }, auth_header($server{$name}{access}));
2591 check($res->is_success, "$name createRecord ignores a stray swapRecord like the reference runtime");
2592 next unless $res->is_success;
2593 my $json = $res->json || {};
2594 $server{$name}{create_record_swap} = {
2595 uri_ok => (($json->{uri} // q()) =~ m{/app\.bsky\.feed\.post/swapcreate\z}) ? 1 : 0,
2596 cid_ok => (defined $json->{cid} && length $json->{cid}) ? 1 : 0,
2597 };
2598}
2599
2600check(
2601 same_hash($server{reference}{create_record_swap}, $server{perlsky}{create_record_swap}),
2602 'createRecord agrees on stray swapRecord handling',
2603);
2604
2605note('Comparing getServiceAuth post-takedown behavior');
2606for my $name (sort keys %server) {
2607 my $update = post_json(
2608 $server{$name}{origin},
2609 'com.atproto.admin.updateSubjectStatus',
2610 {
2611 subject => {
2612 '$type' => 'com.atproto.admin.defs#repoRef',
2613 did => $server{$name}{did},
2614 },
2615 takedown => { applied => true },
2616 },
2617 admin_auth_header($server{$name}{admin_password}),
2618 );
2619 check($update->is_success, "$name repo takedown succeeds before service-auth comparison");
2620 next unless $update->is_success;
2621
2622 my $blocked = get_form(
2623 $server{$name}{origin},
2624 'com.atproto.server.getServiceAuth',
2625 {
2626 aud => 'did:web:api.bsky.app',
2627 lxm => 'app.bsky.actor.getPreferences',
2628 },
2629 auth_header($server{$name}{access}),
2630 );
2631 my $migration = get_form(
2632 $server{$name}{origin},
2633 'com.atproto.server.getServiceAuth',
2634 {
2635 aud => 'did:web:api.bsky.app',
2636 lxm => 'com.atproto.server.createAccount',
2637 },
2638 auth_header($server{$name}{access}),
2639 );
2640 my $blocked_json = $blocked->json || {};
2641 my $migration_json = $migration->json || {};
2642
2643 $server{$name}{service_auth_takedown} = {
2644 standard_ok => $blocked->is_success ? 1 : 0,
2645 standard_token => (length($blocked_json->{token} // q()) ? 1 : 0),
2646 migration_ok => $migration->is_success ? 1 : 0,
2647 migration_token => (length($migration_json->{token} // q()) ? 1 : 0),
2648 };
2649}
2650
2651check(
2652 same_hash($server{reference}{service_auth_takedown}, $server{perlsky}{service_auth_takedown}),
2653 'getServiceAuth agrees on post-takedown behavior',
2654);
2655
2656note('Comparing admin account-management semantics');
2657for my $name (sort keys %server) {
2658 my $info = get_form(
2659 $server{$name}{origin},
2660 'com.atproto.admin.getAccountInfos',
2661 {
2662 dids => [ $server{$name}{did}, 'did:web:missing.test' ],
2663 },
2664 admin_auth_header($server{$name}{admin_password}),
2665 );
2666 my $info_missing = get_form(
2667 $server{$name}{origin},
2668 'com.atproto.admin.getAccountInfo',
2669 { did => 'did:web:missing.test' },
2670 admin_auth_header($server{$name}{admin_password}),
2671 );
2672 my $send_missing = post_json(
2673 $server{$name}{origin},
2674 'com.atproto.admin.sendEmail',
2675 {
2676 recipientDid => 'did:web:missing.test',
2677 content => 'hello',
2678 },
2679 admin_auth_header($server{$name}{admin_password}),
2680 );
2681 my $update_email_missing = post_json(
2682 $server{$name}{origin},
2683 'com.atproto.admin.updateAccountEmail',
2684 {
2685 account => 'did:web:missing.test',
2686 email => 'missing@test.invalid',
2687 },
2688 admin_auth_header($server{$name}{admin_password}),
2689 );
2690 my $delete_missing = post_json(
2691 $server{$name}{origin},
2692 'com.atproto.admin.deleteAccount',
2693 {
2694 did => 'did:web:missing.test',
2695 },
2696 admin_auth_header($server{$name}{admin_password}),
2697 );
2698 my $subject_active = get_form(
2699 $server{$name}{origin},
2700 'com.atproto.admin.getSubjectStatus',
2701 { did => $server{$name}{did} },
2702 admin_auth_header($server{$name}{admin_password}),
2703 );
2704 my $subject_missing = get_form(
2705 $server{$name}{origin},
2706 'com.atproto.admin.getSubjectStatus',
2707 { did => 'did:web:missing.test' },
2708 admin_auth_header($server{$name}{admin_password}),
2709 );
2710 my $subject_missing_blob_did = get_form(
2711 $server{$name}{origin},
2712 'com.atproto.admin.getSubjectStatus',
2713 { blob => 'bafkqaaa' },
2714 admin_auth_header($server{$name}{admin_password}),
2715 );
2716 my $subject_missing_ref = get_form(
2717 $server{$name}{origin},
2718 'com.atproto.admin.getSubjectStatus',
2719 {},
2720 admin_auth_header($server{$name}{admin_password}),
2721 );
2722 my $disable_admin = post_json(
2723 $server{$name}{origin},
2724 'com.atproto.admin.disableInviteCodes',
2725 { accounts => ['admin'] },
2726 admin_auth_header($server{$name}{admin_password}),
2727 );
2728 my $disable_invites = post_json(
2729 $server{$name}{origin},
2730 'com.atproto.admin.disableAccountInvites',
2731 {
2732 account => $server{$name}{did},
2733 note => 'diff disable',
2734 },
2735 admin_auth_header($server{$name}{admin_password}),
2736 );
2737 my $disable_invites_missing = post_json(
2738 $server{$name}{origin},
2739 'com.atproto.admin.disableAccountInvites',
2740 {
2741 account => 'did:web:missing.test',
2742 note => 'diff disable missing',
2743 },
2744 admin_auth_header($server{$name}{admin_password}),
2745 );
2746 my $disabled_info = get_form(
2747 $server{$name}{origin},
2748 'com.atproto.admin.getAccountInfo',
2749 { did => $server{$name}{did} },
2750 admin_auth_header($server{$name}{admin_password}),
2751 );
2752 my $enable_invites = post_json(
2753 $server{$name}{origin},
2754 'com.atproto.admin.enableAccountInvites',
2755 {
2756 account => $server{$name}{did},
2757 note => 'diff enable',
2758 },
2759 admin_auth_header($server{$name}{admin_password}),
2760 );
2761 my $enable_invites_missing = post_json(
2762 $server{$name}{origin},
2763 'com.atproto.admin.enableAccountInvites',
2764 {
2765 account => 'did:web:missing.test',
2766 note => 'diff enable missing',
2767 },
2768 admin_auth_header($server{$name}{admin_password}),
2769 );
2770 my $enabled_info = get_form(
2771 $server{$name}{origin},
2772 'com.atproto.admin.getAccountInfo',
2773 { did => $server{$name}{did} },
2774 admin_auth_header($server{$name}{admin_password}),
2775 );
2776 my $short_password = post_json(
2777 $server{$name}{origin},
2778 'com.atproto.admin.updateAccountPassword',
2779 {
2780 did => $server{$name}{secondary_did},
2781 password => 'short',
2782 },
2783 admin_auth_header($server{$name}{admin_password}),
2784 );
2785 my $reset_password = post_json(
2786 $server{$name}{origin},
2787 'com.atproto.admin.updateAccountPassword',
2788 {
2789 did => $server{$name}{secondary_did},
2790 password => 'newhunter22',
2791 },
2792 admin_auth_header($server{$name}{admin_password}),
2793 );
2794 my $reset_password_missing = post_json(
2795 $server{$name}{origin},
2796 'com.atproto.admin.updateAccountPassword',
2797 {
2798 did => 'did:web:missing.test',
2799 password => 'newhunter22',
2800 },
2801 admin_auth_header($server{$name}{admin_password}),
2802 );
2803 my $old_secondary_login = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
2804 identifier => $server{$name}{secondary_handle},
2805 password => 'hunter22',
2806 });
2807 my $new_secondary_login = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
2808 identifier => $server{$name}{secondary_handle},
2809 password => 'newhunter22',
2810 });
2811 my $updated_secondary_email = $name eq 'reference' ? 'bob-updated-ref@test.com' : 'bob-updated-perl@test.com';
2812 my $update_email_success = post_json(
2813 $server{$name}{origin},
2814 'com.atproto.admin.updateAccountEmail',
2815 {
2816 account => $server{$name}{secondary_did},
2817 email => $updated_secondary_email,
2818 },
2819 admin_auth_header($server{$name}{admin_password}),
2820 );
2821 my $updated_secondary_handle = $name eq 'reference' ? 'bob-updated-ref.test' : 'bob-updated-perl.test';
2822 my $update_handle_success = post_json(
2823 $server{$name}{origin},
2824 'com.atproto.admin.updateAccountHandle',
2825 {
2826 did => $server{$name}{secondary_did},
2827 handle => $updated_secondary_handle,
2828 },
2829 admin_auth_header($server{$name}{admin_password}),
2830 );
2831 my $updated_secondary_info = get_form(
2832 $server{$name}{origin},
2833 'com.atproto.admin.getAccountInfo',
2834 { did => $server{$name}{secondary_did} },
2835 admin_auth_header($server{$name}{admin_password}),
2836 );
2837
2838 my $info_json = $info->json || {};
2839 my @infos = @{ $info_json->{infos} || [] };
2840 my $subject_active_json = $subject_active->json || {};
2841 my $disabled_json = $disabled_info->json || {};
2842 my $enabled_json = $enabled_info->json || {};
2843 my $updated_secondary_json = $updated_secondary_info->json || {};
2844
2845 $server{$name}{admin_account_management} = {
2846 get_infos => {
2847 status => $info->code // 0,
2848 returned_count => scalar @infos,
2849 first_is_primary => (@infos && (($infos[0]{did} // q()) eq $server{$name}{did})) ? 1 : 0,
2850 },
2851 get_info_missing => normalize_xrpc_error($info_missing),
2852 send_missing => normalize_xrpc_error($send_missing),
2853 update_email_missing => normalize_xrpc_error($update_email_missing),
2854 delete_missing => {
2855 status => $delete_missing->code // 0,
2856 body => $delete_missing->body,
2857 },
2858 get_subject_active => {
2859 status => $subject_active->code // 0,
2860 subject_is_primary => (($subject_active_json->{subject}{did} // q()) eq $server{$name}{did}) ? 1 : 0,
2861 subject_type => $subject_active_json->{subject}{'$type'},
2862 takedown_applied => $subject_active_json->{takedown}{applied} ? 1 : 0,
2863 deactivated_applied => $subject_active_json->{deactivated}{applied} ? 1 : 0,
2864 },
2865 get_subject_missing => normalize_xrpc_error($subject_missing),
2866 get_subject_missing_blob_did => normalize_xrpc_error($subject_missing_blob_did),
2867 get_subject_missing_ref => normalize_xrpc_error($subject_missing_ref),
2868 disable_admin_codes => normalize_xrpc_error($disable_admin),
2869 disable_account_invites => {
2870 status => $disable_invites->code // 0,
2871 disabled_status => $disabled_info->code // 0,
2872 invites_disabled => $disabled_json->{invitesDisabled} ? 1 : 0,
2873 invite_note => $disabled_json->{inviteNote},
2874 },
2875 disable_account_invites_missing => {
2876 status => $disable_invites_missing->code // 0,
2877 body => $disable_invites_missing->body,
2878 },
2879 enable_account_invites => {
2880 status => $enable_invites->code // 0,
2881 enabled_status => $enabled_info->code // 0,
2882 invites_disabled => $enabled_json->{invitesDisabled} ? 1 : 0,
2883 invite_note => $enabled_json->{inviteNote},
2884 },
2885 enable_account_invites_missing => {
2886 status => $enable_invites_missing->code // 0,
2887 body => $enable_invites_missing->body,
2888 },
2889 update_password_short => normalize_xrpc_error($short_password),
2890 update_password_reset => {
2891 status => $reset_password->code // 0,
2892 old_login => normalize_xrpc_error($old_secondary_login),
2893 new_login => normalize_xrpc_error($new_secondary_login),
2894 },
2895 update_password_missing => {
2896 status => $reset_password_missing->code // 0,
2897 body => $reset_password_missing->body,
2898 },
2899 update_email_success => {
2900 status => $update_email_success->code // 0,
2901 body => $update_email_success->body,
2902 updated_email => (($updated_secondary_json->{email} // q()) eq $updated_secondary_email) ? 1 : 0,
2903 },
2904 update_handle_success => {
2905 status => $update_handle_success->code // 0,
2906 body => $update_handle_success->body,
2907 updated_handle => (($updated_secondary_json->{handle} // q()) eq $updated_secondary_handle) ? 1 : 0,
2908 },
2909 };
2910}
2911
2912if (!same_hash($server{reference}{admin_account_management}, $server{perlsky}{admin_account_management})) {
2913 note('reference admin account management: ' . encode_json($server{reference}{admin_account_management}));
2914 note('perlsky admin account management: ' . encode_json($server{perlsky}{admin_account_management}));
2915 fail_check('admin account-management semantics match the official reference PDS');
2916} else {
2917 pass('admin account-management semantics match the official reference PDS');
2918}
2919
2920note('Comparing admin invite-code listing semantics');
2921for my $name (sort keys %server) {
2922 my $used_batch = post_json(
2923 $server{$name}{origin},
2924 'com.atproto.server.createInviteCodes',
2925 {
2926 codeCount => 1,
2927 useCount => 2,
2928 },
2929 admin_auth_header($server{$name}{admin_password}),
2930 );
2931 check($used_batch->is_success, "$name createInviteCodes succeeds for used-code batch");
2932 next unless $used_batch->is_success;
2933 my $used_code = (($used_batch->json || {})->{codes} || [])->[0]{codes}[0];
2934
2935 sleep 1.1;
2936
2937 my $unused_batch = post_json(
2938 $server{$name}{origin},
2939 'com.atproto.server.createInviteCodes',
2940 {
2941 codeCount => 1,
2942 useCount => 1,
2943 },
2944 admin_auth_header($server{$name}{admin_password}),
2945 );
2946 check($unused_batch->is_success, "$name createInviteCodes succeeds for unused-code batch");
2947 next unless $unused_batch->is_success;
2948 my $unused_code = (($unused_batch->json || {})->{codes} || [])->[0]{codes}[0];
2949 my $disable_unused = post_json(
2950 $server{$name}{origin},
2951 'com.atproto.admin.disableInviteCodes',
2952 {
2953 codes => [$unused_code],
2954 },
2955 admin_auth_header($server{$name}{admin_password}),
2956 );
2957 check($disable_unused->is_success, "$name disableInviteCodes succeeds");
2958
2959 my $invite_first = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
2960 handle => $name eq 'reference' ? 'invite-a-ref.test' : 'invite-a-perl.test',
2961 email => "invite-a-$name\@test.com",
2962 password => 'hunter22',
2963 inviteCode => $used_code,
2964 });
2965 check($invite_first->is_success, "$name first invite-code account creation succeeds");
2966 next unless $invite_first->is_success;
2967 my $invite_first_did = ($invite_first->json || {})->{did};
2968 my $invite_first_access = ($invite_first->json || {})->{accessJwt};
2969
2970 sleep 1.1;
2971
2972 my $invite_second = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
2973 handle => $name eq 'reference' ? 'invite-b-ref.test' : 'invite-b-perl.test',
2974 email => "invite-b-$name\@test.com",
2975 password => 'hunter22',
2976 inviteCode => $used_code,
2977 });
2978 check($invite_second->is_success, "$name second invite-code account creation succeeds");
2979 next unless $invite_second->is_success;
2980 my $invite_second_did = ($invite_second->json || {})->{did};
2981
2982 my $account_batch = post_json(
2983 $server{$name}{origin},
2984 'com.atproto.server.createInviteCodes',
2985 {
2986 codeCount => 2,
2987 useCount => 1,
2988 forAccounts => [$invite_first_did],
2989 },
2990 admin_auth_header($server{$name}{admin_password}),
2991 );
2992 check($account_batch->is_success, "$name createInviteCodes succeeds for account-targeted batch");
2993 my @account_codes = @{ (($account_batch->json || {})->{codes} || [])->[0]{codes} || [] };
2994
2995 my $account_invites = get_json(
2996 $server{$name}{origin},
2997 'com.atproto.server.getAccountInviteCodes',
2998 undef,
2999 auth_header($invite_first_access),
3000 );
3001 check($account_invites->is_success, "$name getAccountInviteCodes succeeds");
3002
3003 my $recent = get_form(
3004 $server{$name}{origin},
3005 'com.atproto.admin.getInviteCodes',
3006 { sort => 'recent', limit => 10 },
3007 admin_auth_header($server{$name}{admin_password}),
3008 );
3009 check($recent->is_success, "$name getInviteCodes recent succeeds");
3010
3011 my $usage = get_form(
3012 $server{$name}{origin},
3013 'com.atproto.admin.getInviteCodes',
3014 { sort => 'usage', limit => 10 },
3015 admin_auth_header($server{$name}{admin_password}),
3016 );
3017 check($usage->is_success, "$name getInviteCodes usage succeeds");
3018
3019 my $bad_sort = get_form(
3020 $server{$name}{origin},
3021 'com.atproto.admin.getInviteCodes',
3022 { sort => 'bogus', limit => 10 },
3023 admin_auth_header($server{$name}{admin_password}),
3024 );
3025
3026 my %code_label = (
3027 ($used_code // q()) => 'used',
3028 ($unused_code // q()) => 'unused',
3029 ($account_codes[0] // q()) => 'account',
3030 ($account_codes[1] // q()) => 'account',
3031 );
3032 my %did_label = (
3033 ($invite_first_did // q()) => 'first',
3034 ($invite_second_did // q()) => 'second',
3035 );
3036 my %for_account_label = (
3037 admin => 'admin',
3038 ($invite_first_did // q()) => 'first_account',
3039 );
3040 my %account_code_label = map { $_ => 'account' } grep { defined($_) && length($_) } @account_codes;
3041 my $normalize_codes = sub ($rows) {
3042 return [
3043 map {
3044 +{
3045 label => $code_label{$_->{code} // q()} // 'unknown',
3046 available => $_->{available},
3047 disabled => $_->{disabled} ? 1 : 0,
3048 forAccount => $for_account_label{$_->{forAccount} // q()} // 'unknown',
3049 createdBy => $_->{createdBy},
3050 uses_count => scalar @{ $_->{uses} || [] },
3051 use_labels => [ map { $did_label{$_->{usedBy} // q()} // 'unknown' } @{ $_->{uses} || [] } ],
3052 }
3053 } @$rows
3054 ];
3055 };
3056 my $normalize_account_codes = sub ($rows) {
3057 return [ sort {
3058 ($a->{label} cmp $b->{label})
3059 || (($a->{forAccount} // q()) cmp ($b->{forAccount} // q()))
3060 || (($a->{createdBy} // q()) cmp ($b->{createdBy} // q()))
3061 } map {
3062 +{
3063 label => $account_code_label{$_->{code} // q()} // 'unknown',
3064 available => $_->{available},
3065 disabled => $_->{disabled} ? 1 : 0,
3066 forAccount => $for_account_label{$_->{forAccount} // q()} // 'unknown',
3067 createdBy => $_->{createdBy},
3068 uses_count => scalar @{ $_->{uses} || [] },
3069 }
3070 } @$rows
3071 ];
3072 };
3073
3074 $server{$name}{admin_invite_code_listing} = {
3075 disable_unused => {
3076 status => $disable_unused->code // 0,
3077 body => $disable_unused->body,
3078 },
3079 recent => {
3080 cursor_present => defined(($recent->json || {})->{cursor}) ? 1 : 0,
3081 codes => $normalize_codes->(($recent->json || {})->{codes} || []),
3082 },
3083 usage => {
3084 cursor_present => defined(($usage->json || {})->{cursor}) ? 1 : 0,
3085 codes => [
3086 sort {
3087 ($b->{uses_count} <=> $a->{uses_count})
3088 || ($a->{disabled} <=> $b->{disabled})
3089 || (($a->{label} // q()) cmp ($b->{label} // q()))
3090 || (($a->{forAccount} // q()) cmp ($b->{forAccount} // q()))
3091 } @{ $normalize_codes->(($usage->json || {})->{codes} || []) }
3092 ],
3093 },
3094 account => {
3095 codes => $normalize_account_codes->(($account_invites->json || {})->{codes} || []),
3096 },
3097 bad_sort => normalize_xrpc_error($bad_sort),
3098 };
3099}
3100
3101if (!same_hash($server{reference}{admin_invite_code_listing}, $server{perlsky}{admin_invite_code_listing})) {
3102 note('reference admin invite code listing: ' . encode_json($server{reference}{admin_invite_code_listing}));
3103 note('perlsky admin invite code listing: ' . encode_json($server{perlsky}{admin_invite_code_listing}));
3104 fail_check('admin invite-code listing semantics match the official reference PDS');
3105} else {
3106 pass('admin invite-code listing semantics match the official reference PDS');
3107}
3108
3109note('Comparing email and account-delete semantics');
3110for my $name (sort keys %server) {
3111 my $flow_handle = $name eq 'reference' ? 'ef-ref.test' : 'ef-perl.test';
3112 my $flow_email = "emailflow-$name\@test.com";
3113 my $updated_email = "updated-$name\@test.com";
3114
3115 my $flow_create = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
3116 handle => $flow_handle,
3117 email => $flow_email,
3118 password => 'hunter22',
3119 });
3120 check($flow_create->is_success, "$name createAccount succeeds for email lifecycle audit");
3121 next unless $flow_create->is_success;
3122
3123 my $flow_json = $flow_create->json || {};
3124 my $flow_did = $flow_json->{did};
3125 my $flow_access = $flow_json->{accessJwt};
3126
3127 my $initial_update = post_empty(
3128 $server{$name}{origin},
3129 'com.atproto.server.requestEmailUpdate',
3130 auth_header($flow_access),
3131 );
3132 my $request_confirm = post_empty(
3133 $server{$name}{origin},
3134 'com.atproto.server.requestEmailConfirmation',
3135 auth_header($flow_access),
3136 );
3137 my $confirm_token = latest_email_token_record($server{$name}, 'confirm', $flow_did);
3138
3139 my $wrong_confirm = post_json(
3140 $server{$name}{origin},
3141 'com.atproto.server.confirmEmail',
3142 {
3143 email => "wrong-$name\@test.com",
3144 token => $confirm_token->{token},
3145 },
3146 auth_header($flow_access),
3147 );
3148 my $confirm_ok = post_json(
3149 $server{$name}{origin},
3150 'com.atproto.server.confirmEmail',
3151 {
3152 email => uc $flow_email,
3153 token => $confirm_token->{token},
3154 },
3155 auth_header($flow_access),
3156 );
3157 my $session_after_confirm = get_json(
3158 $server{$name}{origin},
3159 'com.atproto.server.getSession',
3160 undef,
3161 auth_header($flow_access),
3162 );
3163
3164 my $confirmed_update = post_empty(
3165 $server{$name}{origin},
3166 'com.atproto.server.requestEmailUpdate',
3167 auth_header($flow_access),
3168 );
3169 my $update_token = latest_email_token_record($server{$name}, 'update', $flow_did);
3170 my $missing_update_token = post_json(
3171 $server{$name}{origin},
3172 'com.atproto.server.updateEmail',
3173 { email => $updated_email },
3174 auth_header($flow_access),
3175 );
3176
3177 expire_email_token_record($server{$name}, 'update', $flow_did);
3178 my $expired_update = post_json(
3179 $server{$name}{origin},
3180 'com.atproto.server.updateEmail',
3181 {
3182 email => $updated_email,
3183 token => $update_token->{token},
3184 },
3185 auth_header($flow_access),
3186 );
3187
3188 my $renew_update = post_empty(
3189 $server{$name}{origin},
3190 'com.atproto.server.requestEmailUpdate',
3191 auth_header($flow_access),
3192 );
3193 my $fresh_update_token = latest_email_token_record($server{$name}, 'update', $flow_did);
3194 my $update_ok = post_json(
3195 $server{$name}{origin},
3196 'com.atproto.server.updateEmail',
3197 {
3198 email => $updated_email,
3199 token => $fresh_update_token->{token},
3200 },
3201 auth_header($flow_access),
3202 );
3203 my $session_after_update = get_json(
3204 $server{$name}{origin},
3205 'com.atproto.server.getSession',
3206 undef,
3207 auth_header($flow_access),
3208 );
3209
3210 my $request_delete = post_empty(
3211 $server{$name}{origin},
3212 'com.atproto.server.requestAccountDelete',
3213 auth_header($flow_access),
3214 );
3215 my $delete_token = latest_email_token_record($server{$name}, 'delete', $flow_did);
3216
3217 expire_email_token_record($server{$name}, 'delete', $flow_did);
3218 my $expired_delete = post_json(
3219 $server{$name}{origin},
3220 'com.atproto.server.deleteAccount',
3221 {
3222 did => $flow_did,
3223 password => 'hunter22',
3224 token => $delete_token->{token},
3225 },
3226 );
3227
3228 my $renew_delete = post_empty(
3229 $server{$name}{origin},
3230 'com.atproto.server.requestAccountDelete',
3231 auth_header($flow_access),
3232 );
3233 my $fresh_delete_token = latest_email_token_record($server{$name}, 'delete', $flow_did);
3234 my $delete_ok = post_json(
3235 $server{$name}{origin},
3236 'com.atproto.server.deleteAccount',
3237 {
3238 did => $flow_did,
3239 password => 'hunter22',
3240 token => $fresh_delete_token->{token},
3241 },
3242 );
3243 my $post_delete_login = post_json($server{$name}{origin}, 'com.atproto.server.createSession', {
3244 identifier => $flow_handle,
3245 password => 'hunter22',
3246 });
3247
3248 $server{$name}{email_account_management} = {
3249 confirm => {
3250 initial_update => {
3251 status => $initial_update->code // 0,
3252 token_required => (($initial_update->json || {})->{tokenRequired} ? 1 : 0),
3253 },
3254 request_status => $request_confirm->code // 0,
3255 request_empty_body => (($request_confirm->body // q()) eq q()) ? 1 : 0,
3256 token_present => $confirm_token && length($confirm_token->{token} // q()) ? 1 : 0,
3257 wrong_email_error => {
3258 status => $wrong_confirm->code // 0,
3259 error => ($wrong_confirm->json || {})->{error},
3260 message => ($wrong_confirm->json || {})->{message},
3261 },
3262 confirm_status => $confirm_ok->code // 0,
3263 confirm_empty_body => (($confirm_ok->body // q()) eq q()) ? 1 : 0,
3264 session_confirmed => ($session_after_confirm->json || {})->{emailConfirmed} ? 1 : 0,
3265 },
3266 update => {
3267 request_status => $confirmed_update->code // 0,
3268 token_required => (($confirmed_update->json || {})->{tokenRequired} ? 1 : 0),
3269 token_present => $update_token && length($update_token->{token} // q()) ? 1 : 0,
3270 missing_token_error => {
3271 status => $missing_update_token->code // 0,
3272 error => ($missing_update_token->json || {})->{error},
3273 message => ($missing_update_token->json || {})->{message},
3274 },
3275 expired_token_error => {
3276 status => $expired_update->code // 0,
3277 error => ($expired_update->json || {})->{error},
3278 message => ($expired_update->json || {})->{message},
3279 },
3280 renew_status => $renew_update->code // 0,
3281 fresh_token_present => $fresh_update_token && length($fresh_update_token->{token} // q()) ? 1 : 0,
3282 update_status => $update_ok->code // 0,
3283 update_empty_body => (($update_ok->body // q()) eq q()) ? 1 : 0,
3284 session_email_matches => (($session_after_update->json || {})->{email} // q()) eq $updated_email ? 1 : 0,
3285 session_confirmed => ($session_after_update->json || {})->{emailConfirmed} ? 1 : 0,
3286 },
3287 delete => {
3288 request_status => $request_delete->code // 0,
3289 request_empty_body => (($request_delete->body // q()) eq q()) ? 1 : 0,
3290 token_present => $delete_token && length($delete_token->{token} // q()) ? 1 : 0,
3291 expired_token_error => {
3292 status => $expired_delete->code // 0,
3293 error => ($expired_delete->json || {})->{error},
3294 message => ($expired_delete->json || {})->{message},
3295 },
3296 renew_status => $renew_delete->code // 0,
3297 fresh_token_present => $fresh_delete_token && length($fresh_delete_token->{token} // q()) ? 1 : 0,
3298 delete_result => {
3299 status => $delete_ok->code // 0,
3300 error => ($delete_ok->json || {})->{error},
3301 message => ($delete_ok->json || {})->{message},
3302 },
3303 delete_empty_body => (($delete_ok->body // q()) eq q()) ? 1 : 0,
3304 post_delete_login => normalize_xrpc_error($post_delete_login),
3305 },
3306 };
3307}
3308
3309if (!same_hash($server{reference}{email_account_management}, $server{perlsky}{email_account_management})) {
3310 note('reference email account management: ' . encode_json($server{reference}{email_account_management}));
3311 note('perlsky email account management: ' . encode_json($server{perlsky}{email_account_management}));
3312 fail_check('email and account-delete semantics match the official reference PDS');
3313} else {
3314 pass('email and account-delete semantics match the official reference PDS');
3315}
3316
3317if ($failed) {
3318 print "\nReference PDS log:\n";
3319 print slurp_file($ref_log);
3320 print "\nperlsky log:\n";
3321 print slurp_file($perl_log);
3322 print "\nPLC mock log:\n";
3323 print slurp_file($plc_log);
3324 print "\nReference crawler log:\n";
3325 print slurp_file($reference_crawler_log);
3326 print "\nperlsky crawler log:\n";
3327 print slurp_file($perlsky_crawler_log);
3328 die "\ndifferential validation failed with $failed mismatches\n";
3329}
3330
3331note('Differential validation succeeded');
3332exit 0;