perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Reduce brittle broad-suite assertions
+61
-17
+4
-4
docs/TEST_AUDIT.md
+4
-4
docs/TEST_AUDIT.md
···
86
86
| `t/crypto-interop.t` | direct reference differential | pinned upstream crypto fixture coverage |
87
87
| `t/email-confirmation.t` | audited local regression | intentionally testing-friendly email flow |
88
88
| `t/event-stream.t` | audited local regression | wire-format, malformed frame, and event decoding coverage |
89
-
| `t/extended-api.t` | audited local regression | broad XRPC behavior including invites and moderation-adjacent flows |
90
-
| `t/external-surface.t` | audited local regression | external repo/account surface including missing-blob behavior; still mixes surface inventory with conformance assertions and should stay documented that way |
89
+
| `t/extended-api.t` | audited local regression | broad XRPC behavior including invites and moderation-adjacent flows; still intentionally mixes conformance-ish happy paths with local-policy coverage |
90
+
| `t/external-surface.t` | audited local regression | external repo/account surface including missing-blob behavior; intentionally broad, with order-insensitive assertions for label presence rather than brittle label ordering |
91
91
| `t/firehose.t` | audited local regression | repo subscription lifecycle, cursor, and CAR behavior |
92
92
| `t/identity.t` | local correctness/infrastructure | handle and DID identity flow coverage |
93
-
| `t/import-repo.t` | audited local regression | import/snapshot restore behavior, including perlsky's intentionally tolerant malformed-record import semantics |
93
+
| `t/import-repo.t` | audited local regression | import/snapshot restore behavior, including perlsky's intentionally tolerant malformed-record import semantics and explicit rollback to the imported snapshot |
94
94
| `t/invite-gating.t` | audited local regression | self-service invite flag behavior |
95
95
| `t/ipld-canonical.t` | local correctness/infrastructure | canonical IPLD encoding invariants |
96
96
| `t/ipld-codecs.t` | local correctness/infrastructure | DAG-CBOR and codec coverage |
···
135
135
2. extend `script/differential-validate` where automation is cheap and high value
136
136
3. add a written mapping from each local-only suite to the protocol or product invariant it is meant to protect
137
137
4. decide whether to tighten admin auth to reference semantics or document the bearer shortcut as a permanent extension
138
-
5. move the testing-friendly email confirmation path behind an explicit smoke/dev switch instead of ambient behavior
138
+
5. keep local testing-only toggles, like the email-confirmation bypass, pinned in focused suites instead of letting broad mixed suites depend on them implicitly
139
139
6. keep narrowing the local `ServiceProxy` surface until every locally answered `app.bsky.*` field is either authoritative or explicitly documented as a local-only extension
140
140
7. keep documenting broad suites like `t/extended-api.t`, `t/external-surface.t`, and `t/import-repo.t` as mixed conformance-plus-product coverage rather than over-claiming that every assertion is a pure reference check
141
141
+36
-10
t/extended-api.t
+36
-10
t/extended-api.t
···
271
271
272
272
$t->get_ok(Mojo::URL->new('/xrpc/com.atproto.label.queryLabels')->query(
273
273
uriPatterns => "at://$did*",
274
-
))->status_is(200)
275
-
->json_is('/labels/0/val', '!hide');
274
+
))->status_is(200);
275
+
ok(
276
+
_find_label($t->tx->res->json->{labels}, val => '!hide'),
277
+
'queryLabels includes the takedown label',
278
+
);
276
279
277
280
$t->get_ok('/xrpc/com.atproto.temp.fetchLabels?limit=10')
278
-
->status_is(200)
279
-
->json_is('/labels/0/val', '!hide');
281
+
->status_is(200);
282
+
ok(
283
+
_find_label($t->tx->res->json->{labels}, val => '!hide'),
284
+
'fetchLabels includes the takedown label',
285
+
);
280
286
281
287
$t->post_ok('/xrpc/com.atproto.admin.updateSubjectStatus' => {
282
288
Authorization => $admin_auth,
···
287
293
288
294
$t->get_ok(Mojo::URL->new('/xrpc/com.atproto.label.queryLabels')->query(
289
295
uriPatterns => "at://$did*",
290
-
))->status_is(200)
291
-
->json_is('/labels/0/val', '!hide')
292
-
->json_is('/labels/0/neg', JSON::PP::true);
296
+
))->status_is(200);
297
+
ok(
298
+
_find_label($t->tx->res->json->{labels}, val => '!hide', neg => JSON::PP::true),
299
+
'queryLabels includes the negated takedown label',
300
+
);
293
301
294
302
$t->get_ok('/xrpc/com.atproto.temp.fetchLabels?limit=10')
295
-
->status_is(200)
296
-
->json_is('/labels/0/val', '!hide')
297
-
->json_is('/labels/0/neg', JSON::PP::true);
303
+
->status_is(200);
304
+
ok(
305
+
_find_label($t->tx->res->json->{labels}, val => '!hide', neg => JSON::PP::true),
306
+
'fetchLabels includes the negated takedown label',
307
+
);
298
308
299
309
$t->post_ok('/xrpc/com.atproto.sync.requestCrawl' => json => {
300
310
hostname => 'relay.example.test',
···
310
320
->json_is('/hostname', 'relay.example.test');
311
321
312
322
done_testing;
323
+
324
+
sub _find_label {
325
+
my ($labels, %expected) = @_;
326
+
return 0 unless ref($labels) eq 'ARRAY';
327
+
for my $label (@$labels) {
328
+
next unless ref($label) eq 'HASH';
329
+
my $matches = 1;
330
+
for my $key (keys %expected) {
331
+
next if defined($label->{$key}) && "$label->{$key}" eq "$expected{$key}";
332
+
$matches = 0;
333
+
last;
334
+
}
335
+
return 1 if $matches;
336
+
}
337
+
return 0;
338
+
}
+21
-3
t/external-surface.t
+21
-3
t/external-surface.t
···
234
234
235
235
$t->get_ok(Mojo::URL->new('/xrpc/com.atproto.label.queryLabels')->query(
236
236
uriPatterns => $record_uri,
237
-
))->status_is(200)
238
-
->json_is('/labels/0/val' => '!hide')
239
-
->json_is('/labels/0/uri' => $record_uri);
237
+
))->status_is(200);
238
+
ok(
239
+
_find_label($t->tx->res->json->{labels}, val => '!hide', uri => $record_uri),
240
+
'queryLabels includes the record takedown label',
241
+
);
240
242
241
243
for my $cid ($blob_cid, $nested_blob_cid) {
242
244
$app->store->dbh->do(
···
277
279
->json_is('/cursor' => $missing_cids[1]);
278
280
279
281
done_testing;
282
+
283
+
sub _find_label {
284
+
my ($labels, %expected) = @_;
285
+
return 0 unless ref($labels) eq 'ARRAY';
286
+
for my $label (@$labels) {
287
+
next unless ref($label) eq 'HASH';
288
+
my $matches = 1;
289
+
for my $key (keys %expected) {
290
+
next if defined($label->{$key}) && "$label->{$key}" eq "$expected{$key}";
291
+
$matches = 0;
292
+
last;
293
+
}
294
+
return 1 if $matches;
295
+
}
296
+
return 0;
297
+
}