perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Align admin invite-code listing semantics
+208
-18
+2
-1
docs/TEST_AUDIT.md
+2
-1
docs/TEST_AUDIT.md
···
13
13
The current baseline for saying "the audited suite is green" is:
14
14
15
15
- `prove -lr t`
16
-
- latest full green result in the realigned Meridian worktree: `Files=48, Tests=2950`
16
+
- latest full green result in the realigned Meridian worktree: `Files=48, Tests=2967`
17
17
- `prove -lv t/server-auth.t`
18
18
- `perl -c script/differential-validate`
19
19
- `PERLSKY_RUN_REFERENCE_DIFF=1 prove -lv t/reference-differential.t`
···
60
60
- `com.atproto.admin.sendEmail` now follows the reference runtime’s `400 InvalidRequest` / `Recipient not found` shape for a missing recipient instead of returning a local `404 AccountNotFound`.
61
61
- `com.atproto.admin.updateAccountPassword` follows the reference runtime’s looser admin policy: it rejects overlong passwords with `400 InvalidRequest` / `Invalid password length.`, but does not impose the normal user-facing minimum-length gate.
62
62
- `com.atproto.admin.disableAccountInvites` / `enableAccountInvites` now ignore the local `note` field so the visible account state matches the official runtime instead of carrying an extra stored `inviteNote`.
63
+
- `com.atproto.admin.getInviteCodes` now matches the official runtime on sort validation, always-emitted cursor behavior, total `available` counts, and newest-first `uses` ordering.
63
64
- `app.bsky.actor.putPreferences` and `app.bsky.notification.putPreferencesV2` now have explicit shape validation plus focused regression coverage, turning an earlier hardening concern into a pinned contract.
64
65
- `com.atproto.identity.resolveHandle` should reject malformed handles with `400 InvalidRequest`, not quietly treat them as misses or return a local `InvalidHandle` variant.
65
66
- `com.atproto.identity.resolveHandle` should treat well-formed but unresolved handles as `400 InvalidRequest` with `Unable to resolve handle`, matching the official runtime instead of returning a local `404 HandleNotFound`.
+15
-5
lib/ATProto/PDS/API/Admin.pm
+15
-5
lib/ATProto/PDS/API/Admin.pm
···
217
217
218
218
$registry->register('com.atproto.admin.getInviteCodes', sub ($c, $endpoint) {
219
219
require_admin($c);
220
-
my $page = $c->store->list_invite_codes(
221
-
sort => $c->param('sort') // 'recent',
222
-
cursor => $c->param('cursor'),
223
-
limit => $c->param('limit') // 100,
224
-
);
220
+
my $sort = $c->param('sort') // 'recent';
221
+
xrpc_error(400, 'InvalidRequest', "unknown sort method: $sort")
222
+
unless $sort eq 'recent' || $sort eq 'usage';
223
+
my $page = eval {
224
+
$c->store->list_invite_codes(
225
+
sort => $sort,
226
+
cursor => $c->param('cursor'),
227
+
limit => $c->param('limit') // 100,
228
+
);
229
+
};
230
+
if (my $err = $@) {
231
+
xrpc_error(400, 'InvalidRequest', 'Malformed cursor')
232
+
if !ref($err) && ($err // q()) =~ /invalid usage cursor/;
233
+
die $err;
234
+
}
225
235
return {
226
236
(defined $page->{cursor} ? (cursor => $page->{cursor}) : ()),
227
237
codes => [ map { invite_code_view($c->store, $_) } @{ $page->{items} } ],
+1
-5
lib/ATProto/PDS/API/Helpers.pm
+1
-5
lib/ATProto/PDS/API/Helpers.pm
···
170
170
171
171
sub invite_code_view ($store, $row) {
172
172
my $uses = $store->list_invite_code_uses($row->{code});
173
-
my $consumed = scalar @$uses;
174
-
my $available = ($row->{use_count} // 0) - $consumed;
175
-
$available = 0 if $available < 0;
176
-
177
173
return {
178
174
code => $row->{code},
179
-
available => $row->{disabled} ? 0 : $available,
175
+
available => 0 + ($row->{use_count} // 0),
180
176
disabled => $row->{disabled} ? JSON::PP::true : JSON::PP::false,
181
177
forAccount => $row->{for_account} // q(),
182
178
createdBy => $row->{created_by} // q(),
+17
-7
lib/ATProto/PDS/Store/SQLite/Invites.pm
+17
-7
lib/ATProto/PDS/Store/SQLite/Invites.pm
···
60
60
$limit = 500 if $limit > 500;
61
61
my $cursor = $args{cursor};
62
62
my $sort = $args{sort} // 'recent';
63
+
die 'unknown sort method' unless $sort eq 'recent' || $sort eq 'usage';
63
64
my @bind;
64
65
my @where;
65
-
my $sql = q{
66
+
my $inner_sql = q{
66
67
SELECT invite_codes.*, COUNT(invite_code_uses.code) AS use_count_consumed
67
68
FROM invite_codes
68
69
LEFT JOIN invite_code_uses ON invite_code_uses.code = invite_codes.code
70
+
GROUP BY invite_codes.code
69
71
};
72
+
my $sql = "SELECT * FROM ($inner_sql) AS invite_codes";
70
73
if ($sort eq 'usage') {
71
74
if (defined $cursor && length $cursor) {
72
75
my ($cursor_use_count, $cursor_code) = ATProto::PDS::Store::SQLite::_parse_usage_cursor($cursor);
73
-
push @where, q{(invite_codes.use_count < ? OR (invite_codes.use_count = ? AND invite_codes.code > ?))};
76
+
push @where, q{(invite_codes.use_count_consumed < ? OR (invite_codes.use_count_consumed = ? AND invite_codes.code > ?))};
74
77
push @bind, $cursor_use_count, $cursor_use_count, $cursor_code;
75
78
}
76
79
$sql .= q{ WHERE } . join(q{ AND }, @where) if @where;
77
-
$sql .= q{ GROUP BY invite_codes.code ORDER BY invite_codes.use_count DESC, invite_codes.code ASC};
80
+
$sql .= q{ ORDER BY invite_codes.use_count_consumed DESC, invite_codes.code ASC};
78
81
} else {
79
82
if (defined $cursor && length $cursor) {
80
83
push @where, q{invite_codes.code > ?};
81
84
push @bind, $cursor;
82
85
}
83
86
$sql .= q{ WHERE } . join(q{ AND }, @where) if @where;
84
-
$sql .= q{ GROUP BY invite_codes.code ORDER BY invite_codes.created_at DESC, invite_codes.code DESC};
87
+
$sql .= q{ ORDER BY invite_codes.created_at DESC, invite_codes.code DESC};
85
88
}
86
89
$sql .= q{ LIMIT ?};
87
90
push @bind, $limit + 1;
88
91
my $rows = $self->dbh->selectall_arrayref($sql, { Slice => {} }, @bind);
89
-
return ATProto::PDS::Store::SQLite::_paginate(
92
+
my $page = ATProto::PDS::Store::SQLite::_paginate(
90
93
$rows,
91
94
$limit,
92
95
$sort eq 'usage'
93
-
? sub ($row) { ATProto::PDS::Store::SQLite::_usage_cursor($row->{use_count}, $row->{code}) }
96
+
? sub ($row) { ATProto::PDS::Store::SQLite::_usage_cursor($row->{use_count_consumed}, $row->{code}) }
94
97
: 'code',
95
98
);
99
+
if (!defined($page->{cursor}) && @{ $page->{items} || [] }) {
100
+
my $last = $page->{items}[-1];
101
+
$page->{cursor} = $sort eq 'usage'
102
+
? ATProto::PDS::Store::SQLite::_usage_cursor($last->{use_count_consumed}, $last->{code})
103
+
: $last->{code};
104
+
}
105
+
return $page;
96
106
}
97
107
98
108
sub list_invite_codes_for_account ($self, $did) {
···
150
160
151
161
sub list_invite_code_uses ($self, $code) {
152
162
return $self->dbh->selectall_arrayref(
153
-
q{SELECT * FROM invite_code_uses WHERE code = ? ORDER BY used_at ASC, used_by ASC},
163
+
q{SELECT * FROM invite_code_uses WHERE code = ? ORDER BY used_at DESC, used_by ASC},
154
164
{ Slice => {} },
155
165
$code,
156
166
);
+120
script/differential-validate
+120
script/differential-validate
···
2417
2417
pass('admin account-management semantics match the official reference PDS');
2418
2418
}
2419
2419
2420
+
note('Comparing admin invite-code listing semantics');
2421
+
for my $name (sort keys %server) {
2422
+
my $used_batch = post_json(
2423
+
$server{$name}{origin},
2424
+
'com.atproto.server.createInviteCodes',
2425
+
{
2426
+
codeCount => 1,
2427
+
useCount => 2,
2428
+
},
2429
+
admin_auth_header($server{$name}{admin_password}),
2430
+
);
2431
+
check($used_batch->is_success, "$name createInviteCodes succeeds for used-code batch");
2432
+
next unless $used_batch->is_success;
2433
+
my $used_code = (($used_batch->json || {})->{codes} || [])->[0]{codes}[0];
2434
+
2435
+
sleep 1.1;
2436
+
2437
+
my $unused_batch = post_json(
2438
+
$server{$name}{origin},
2439
+
'com.atproto.server.createInviteCodes',
2440
+
{
2441
+
codeCount => 1,
2442
+
useCount => 1,
2443
+
},
2444
+
admin_auth_header($server{$name}{admin_password}),
2445
+
);
2446
+
check($unused_batch->is_success, "$name createInviteCodes succeeds for unused-code batch");
2447
+
next unless $unused_batch->is_success;
2448
+
my $unused_code = (($unused_batch->json || {})->{codes} || [])->[0]{codes}[0];
2449
+
2450
+
my $invite_first = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
2451
+
handle => $name eq 'reference' ? 'invite-a-ref.test' : 'invite-a-perl.test',
2452
+
email => "invite-a-$name\@test.com",
2453
+
password => 'hunter22',
2454
+
inviteCode => $used_code,
2455
+
});
2456
+
check($invite_first->is_success, "$name first invite-code account creation succeeds");
2457
+
next unless $invite_first->is_success;
2458
+
my $invite_first_did = ($invite_first->json || {})->{did};
2459
+
2460
+
sleep 1.1;
2461
+
2462
+
my $invite_second = post_json($server{$name}{origin}, 'com.atproto.server.createAccount', {
2463
+
handle => $name eq 'reference' ? 'invite-b-ref.test' : 'invite-b-perl.test',
2464
+
email => "invite-b-$name\@test.com",
2465
+
password => 'hunter22',
2466
+
inviteCode => $used_code,
2467
+
});
2468
+
check($invite_second->is_success, "$name second invite-code account creation succeeds");
2469
+
next unless $invite_second->is_success;
2470
+
my $invite_second_did = ($invite_second->json || {})->{did};
2471
+
2472
+
my $recent = get_form(
2473
+
$server{$name}{origin},
2474
+
'com.atproto.admin.getInviteCodes',
2475
+
{ sort => 'recent', limit => 10 },
2476
+
admin_auth_header($server{$name}{admin_password}),
2477
+
);
2478
+
check($recent->is_success, "$name getInviteCodes recent succeeds");
2479
+
2480
+
my $usage = get_form(
2481
+
$server{$name}{origin},
2482
+
'com.atproto.admin.getInviteCodes',
2483
+
{ sort => 'usage', limit => 10 },
2484
+
admin_auth_header($server{$name}{admin_password}),
2485
+
);
2486
+
check($usage->is_success, "$name getInviteCodes usage succeeds");
2487
+
2488
+
my $bad_sort = get_form(
2489
+
$server{$name}{origin},
2490
+
'com.atproto.admin.getInviteCodes',
2491
+
{ sort => 'bogus', limit => 10 },
2492
+
admin_auth_header($server{$name}{admin_password}),
2493
+
);
2494
+
2495
+
my %code_label = (
2496
+
($used_code // q()) => 'used',
2497
+
($unused_code // q()) => 'unused',
2498
+
);
2499
+
my %did_label = (
2500
+
($invite_first_did // q()) => 'first',
2501
+
($invite_second_did // q()) => 'second',
2502
+
);
2503
+
my $normalize_codes = sub ($rows) {
2504
+
return [
2505
+
map {
2506
+
+{
2507
+
label => $code_label{$_->{code} // q()} // 'unknown',
2508
+
available => $_->{available},
2509
+
disabled => $_->{disabled} ? 1 : 0,
2510
+
forAccount => $_->{forAccount},
2511
+
createdBy => $_->{createdBy},
2512
+
uses_count => scalar @{ $_->{uses} || [] },
2513
+
use_labels => [ map { $did_label{$_->{usedBy} // q()} // 'unknown' } @{ $_->{uses} || [] } ],
2514
+
}
2515
+
} @$rows
2516
+
];
2517
+
};
2518
+
2519
+
$server{$name}{admin_invite_code_listing} = {
2520
+
recent => {
2521
+
cursor_present => defined(($recent->json || {})->{cursor}) ? 1 : 0,
2522
+
codes => $normalize_codes->(($recent->json || {})->{codes} || []),
2523
+
},
2524
+
usage => {
2525
+
cursor_present => defined(($usage->json || {})->{cursor}) ? 1 : 0,
2526
+
codes => $normalize_codes->(($usage->json || {})->{codes} || []),
2527
+
},
2528
+
bad_sort => normalize_xrpc_error($bad_sort),
2529
+
};
2530
+
}
2531
+
2532
+
if (!same_hash($server{reference}{admin_invite_code_listing}, $server{perlsky}{admin_invite_code_listing})) {
2533
+
note('reference admin invite code listing: ' . encode_json($server{reference}{admin_invite_code_listing}));
2534
+
note('perlsky admin invite code listing: ' . encode_json($server{perlsky}{admin_invite_code_listing}));
2535
+
fail_check('admin invite-code listing semantics match the official reference PDS');
2536
+
} else {
2537
+
pass('admin invite-code listing semantics match the official reference PDS');
2538
+
}
2539
+
2420
2540
note('Comparing email and account-delete semantics');
2421
2541
for my $name (sort keys %server) {
2422
2542
my $flow_handle = $name eq 'reference' ? 'ef-ref.test' : 'ef-perl.test';
+53
t/uncovered-endpoints.t
+53
t/uncovered-endpoints.t
···
226
226
my @admin_codes = @{ $t->tx->res->json->{codes}[0]{codes} || [] };
227
227
is(scalar @admin_codes, 2, 'admin createInviteCodes returns the requested number of codes');
228
228
229
+
$app->store->create_invite_code(
230
+
code => 'perlsky-audit-used',
231
+
for_account => 'admin',
232
+
created_by => 'admin',
233
+
use_count => 2,
234
+
created_at => 4_102_444_700,
235
+
);
236
+
$app->store->create_invite_code(
237
+
code => 'perlsky-audit-unused',
238
+
for_account => 'admin',
239
+
created_by => 'admin',
240
+
use_count => 1,
241
+
created_at => 4_102_444_800,
242
+
);
243
+
$app->store->record_invite_code_use(
244
+
code => 'perlsky-audit-used',
245
+
used_by => $did,
246
+
used_at => 4_102_444_900,
247
+
);
248
+
$app->store->record_invite_code_use(
249
+
code => 'perlsky-audit-used',
250
+
used_by => $bob->{did},
251
+
used_at => 4_102_445_000,
252
+
);
253
+
254
+
$t->get_ok('/xrpc/com.atproto.admin.getInviteCodes?sort=recent&limit=2' => {
255
+
Authorization => $admin_auth,
256
+
})->status_is(200)
257
+
->json_is('/codes/0/code' => 'perlsky-audit-unused')
258
+
->json_is('/codes/1/code' => 'perlsky-audit-used')
259
+
->json_has('/cursor');
260
+
261
+
$t->get_ok('/xrpc/com.atproto.admin.getInviteCodes?sort=usage&limit=20' => {
262
+
Authorization => $admin_auth,
263
+
})->status_is(200)
264
+
->json_is('/codes/0/code' => 'perlsky-audit-used')
265
+
->json_is('/codes/0/available' => 2)
266
+
->json_is('/codes/0/uses/0/usedBy' => $bob->{did})
267
+
->json_is('/codes/0/uses/1/usedBy' => $did)
268
+
->json_has('/cursor');
269
+
270
+
my $usage_codes = $t->tx->res->json->{codes} || [];
271
+
ok(
272
+
scalar(grep { ($_->{code} // q()) eq 'perlsky-audit-unused' } @$usage_codes),
273
+
'usage invite-code listing includes the unused seeded code',
274
+
);
275
+
276
+
$t->get_ok('/xrpc/com.atproto.admin.getInviteCodes?sort=bogus&limit=2' => {
277
+
Authorization => $admin_auth,
278
+
})->status_is(400)
279
+
->json_is('/error' => 'InvalidRequest')
280
+
->json_is('/message' => 'unknown sort method: bogus');
281
+
229
282
$t->post_ok('/xrpc/com.atproto.admin.disableInviteCodes' => {
230
283
Authorization => $admin_auth,
231
284
} => json => {