perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Validate DID-backed repo metadata surfaces
+163
-5
+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
-
- last full green result in the realigned Meridian worktree: `Files=44, Tests=2508`
16
+
- last full green result in the realigned Meridian worktree: `Files=44, Tests=2525`
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`
···
54
54
- Remote `did:web` DID docs, conservative `resolveIdentity` handle validation, and external handle adoption all need explicit coverage because small resolver-policy drifts turn into visible interop bugs quickly.
55
55
- `com.atproto.repo.getRecord` must honor `cid` when present, and `putRecord` / `deleteRecord` must actually enforce `swapRecord`; those negative edges are now covered directly.
56
56
- `com.atproto.server.requestPasswordReset` and `com.atproto.server.deleteAccount` now follow the reference form-token flow, with focused regression coverage for missing-account and bearerless deletion semantics.
57
+
- `com.atproto.server.checkAccountStatus` must validate the stored DID document against the PDS service endpoint and signing key, and `com.atproto.repo.describeRepo` must derive `didDoc` / `handleIsCorrect` from that document instead of hardcoding success.
57
58
- `com.atproto.sync.getBlob` should ship the same download-hardening headers as the reference PDS (`X-Content-Type-Options`, `Content-Disposition`, `Content-Security-Policy`).
58
59
59
60
## Known Intentional Divergences
+16
-2
lib/ATProto/PDS/API/Repo.pm
+16
-2
lib/ATProto/PDS/API/Repo.pm
···
18
18
oauth_scope_allows_permission
19
19
);
20
20
use ATProto::PDS::Constants qw(TOKEN_AUD_ACCESS);
21
+
use ATProto::PDS::Identity qw(account_did_doc normalize_handle resolve_handle_to_did);
21
22
use ATProto::PDS::Moderation qw(assert_record_readable assert_repo_readable assert_repo_writable is_record_takedown parse_at_uri);
23
+
use ATProto::PDS::PLC qw(is_plc_did refresh_plc_did_doc);
22
24
use ATProto::PDS::Repo::CID;
23
25
use ATProto::PDS::Repo::DagCbor qw(encode_dag_cbor);
24
26
···
27
29
sub register_repo_handlers ($registry, $app) {
28
30
$registry->register('com.atproto.repo.describeRepo', sub ($c, $endpoint) {
29
31
my $account = _readable_repo($c, $c->param('repo'));
32
+
my $did_doc = _describe_repo_did_doc($c, $account);
30
33
31
34
return {
32
35
handle => $account->{handle},
33
36
did => $account->{did},
34
-
didDoc => $account->{did_doc},
37
+
didDoc => $did_doc,
35
38
collections => $c->store->list_collections_for_did($account->{did}),
36
-
handleIsCorrect => JSON::PP::true,
39
+
handleIsCorrect => _describe_repo_handle_is_correct($c, $account, $did_doc)
40
+
? JSON::PP::true
41
+
: JSON::PP::false,
37
42
};
38
43
});
39
44
···
401
406
402
407
sub _record_uri ($did, $collection, $rkey) {
403
408
return "at://$did/$collection/$rkey";
409
+
}
410
+
411
+
sub _did_doc_handle ($did_doc) {
412
+
return undef unless ref($did_doc) eq 'HASH';
413
+
for my $aka (@{ $did_doc->{alsoKnownAs} || [] }) {
414
+
next unless defined $aka && $aka =~ m{\Aat://(.+)\z};
415
+
return $1;
416
+
}
417
+
return undef;
404
418
}
405
419
406
420
sub _record_view ($did, $row) {
+4
-2
lib/ATProto/PDS/API/Server.pm
+4
-2
lib/ATProto/PDS/API/Server.pm
···
29
29
TOKEN_AUD_ACCESS
30
30
TOKEN_AUD_REFRESH
31
31
);
32
-
use ATProto::PDS::Identity qw(account_did account_did_doc normalize_handle service_did);
32
+
use ATProto::PDS::Identity qw(account_did account_did_doc account_did_doc_valid_for_service normalize_handle service_did);
33
33
use ATProto::PDS::Moderation qw(assert_login_allowed is_repo_takedown);
34
34
use ATProto::PDS::PLC qw(account_did_method create_plc_account is_plc_did refresh_plc_did_doc);
35
35
use ATProto::PDS::Repo::CAR qw(read_car);
···
248
248
activated => (!defined($account->{deactivated_at}) && !defined($account->{deleted_at}))
249
249
? JSON::PP::true
250
250
: JSON::PP::false,
251
-
validDid => ($account->{did} // q()) =~ /^did:/ ? JSON::PP::true : JSON::PP::false,
251
+
validDid => account_did_doc_valid_for_service($c->app->settings, $account)
252
+
? JSON::PP::true
253
+
: JSON::PP::false,
252
254
repoCommit => $account->{repo_commit_cid} // q(),
253
255
repoRev => $account->{repo_rev} // q(),
254
256
repoBlocks => 0 + $block_count,
+33
lib/ATProto/PDS/Identity.pm
+33
lib/ATProto/PDS/Identity.pm
···
14
14
our @EXPORT_OK = qw(
15
15
account_did
16
16
account_did_doc
17
+
account_did_doc_valid_for_service
17
18
did_to_path
18
19
is_valid_handle
19
20
normalize_handle
···
96
97
$doc{assertionMethod} = ["$did#atproto"];
97
98
}
98
99
return \%doc;
100
+
}
101
+
102
+
sub account_did_doc_valid_for_service ($config_or_url, $account) {
103
+
return 0 unless ref($account) eq 'HASH';
104
+
my $config = _coerce_config($config_or_url);
105
+
my $did = $account->{did} // q();
106
+
return 0 unless length $did;
107
+
108
+
my $doc = $account->{did_doc} || account_did_doc($config, $account);
109
+
return 0 unless ref($doc) eq 'HASH';
110
+
111
+
my ($service) = grep {
112
+
ref($_) eq 'HASH'
113
+
&& (($_->{id} // q()) eq "$did#atproto_pds" || ($_->{type} // q()) eq 'AtprotoPersonalDataServer')
114
+
} @{ $doc->{service} || [] };
115
+
return 0 unless $service;
116
+
return 0 unless ($service->{type} // q()) eq 'AtprotoPersonalDataServer';
117
+
return 0 unless ($service->{serviceEndpoint} // q()) eq ($config->{base_url} // 'http://127.0.0.1:7755');
118
+
119
+
my $expected_multibase = $account->{public_key_multibase} // q();
120
+
return 1 unless length $expected_multibase;
121
+
122
+
my ($verification_method) = grep {
123
+
ref($_) eq 'HASH' && (($_->{id} // q()) eq "$did#atproto")
124
+
} @{ $doc->{verificationMethod} || [] };
125
+
return 0 unless $verification_method;
126
+
return 0 unless ($verification_method->{publicKeyMultibase} // q()) eq $expected_multibase;
127
+
128
+
my %assertion_methods = map { ($_ // q()) => 1 } @{ $doc->{assertionMethod} || [] };
129
+
return 0 unless $assertion_methods{"$did#atproto"};
130
+
131
+
return 1;
99
132
}
100
133
101
134
sub did_to_path ($did) {
+50
script/differential-validate
+50
script/differential-validate
···
955
955
'record takedown sync proof semantics match the official reference PDS',
956
956
);
957
957
958
+
note('Comparing describeRepo');
959
+
for my $name (sort keys %server) {
960
+
my $res = get_form($server{$name}{origin}, 'com.atproto.repo.describeRepo', {
961
+
repo => $server{$name}{did},
962
+
});
963
+
check($res->is_success, "$name describeRepo succeeds");
964
+
next unless $res->is_success;
965
+
my $json = $res->json || {};
966
+
$server{$name}{describe_repo} = {
967
+
handle_matches_account => (($json->{handle} // q()) eq ($server{$name}{handle} // q())) ? 1 : 0,
968
+
did_matches_account => (($json->{did} // q()) eq ($server{$name}{did} // q())) ? 1 : 0,
969
+
did_doc_id_matches_did => (($json->{didDoc}{id} // q()) eq ($server{$name}{did} // q())) ? 1 : 0,
970
+
handle_is_correct => $json->{handleIsCorrect} ? 1 : 0,
971
+
collections_nonempty => @{ $json->{collections} || [] } >= 1 ? 1 : 0,
972
+
};
973
+
}
974
+
975
+
check(
976
+
same_hash($server{reference}{describe_repo}, $server{perlsky}{describe_repo}),
977
+
'describeRepo matches the official reference PDS semantics',
978
+
);
979
+
958
980
note('Comparing listRecords');
959
981
for my $name (sort keys %server) {
960
982
my $res = get_form($server{$name}{origin}, 'com.atproto.repo.listRecords', {
···
1001
1023
check(
1002
1024
same_hash($server{reference}{latest_commit}, $server{perlsky}{latest_commit}),
1003
1025
'getLatestCommit matches the official reference PDS semantics',
1026
+
);
1027
+
1028
+
note('Comparing checkAccountStatus');
1029
+
for my $name (sort keys %server) {
1030
+
my $res = get_form(
1031
+
$server{$name}{origin},
1032
+
'com.atproto.server.checkAccountStatus',
1033
+
{},
1034
+
auth_header($server{$name}{access}),
1035
+
);
1036
+
check($res->is_success, "$name checkAccountStatus succeeds");
1037
+
next unless $res->is_success;
1038
+
my $json = $res->json || {};
1039
+
$server{$name}{check_account_status} = {
1040
+
activated => $json->{activated} ? 1 : 0,
1041
+
valid_did => $json->{validDid} ? 1 : 0,
1042
+
repo_commit_matches_head => (($json->{repoCommit} // q()) eq ($server{$name}{latest_commit_raw}{cid} // q())) ? 1 : 0,
1043
+
repo_rev_matches_head => (($json->{repoRev} // q()) eq ($server{$name}{latest_commit_raw}{rev} // q())) ? 1 : 0,
1044
+
repo_blocks_positive => ($json->{repoBlocks} // 0) > 0 ? 1 : 0,
1045
+
indexed_records_positive => ($json->{indexedRecords} // 0) > 0 ? 1 : 0,
1046
+
private_state_values => 0 + ($json->{privateStateValues} // 0),
1047
+
blob_counts_match => (($json->{expectedBlobs} // -1) == ($json->{importedBlobs} // -2)) ? 1 : 0,
1048
+
};
1049
+
}
1050
+
1051
+
check(
1052
+
same_hash($server{reference}{check_account_status}, $server{perlsky}{check_account_status}),
1053
+
'checkAccountStatus matches the official reference PDS semantics',
1004
1054
);
1005
1055
1006
1056
note('Comparing getHead');
+38
t/external-surface.t
+38
t/external-surface.t
···
205
205
Authorization => "Bearer $access",
206
206
})->status_is(200)
207
207
->json_has('/activated')
208
+
->json_is('/validDid' => JSON::PP::true)
208
209
->json_has('/repoCommit')
209
210
->json_has('/repoRev')
210
211
->json_has('/repoBlocks')
211
212
->json_has('/indexedRecords')
212
213
->json_has('/expectedBlobs')
213
214
->json_has('/importedBlobs');
215
+
216
+
my $account = $app->store->get_account_by_did($did);
217
+
my $original_did_doc = $account->{did_doc};
218
+
219
+
my %bad_endpoint_doc = %{$original_did_doc};
220
+
$bad_endpoint_doc{service} = [
221
+
map {
222
+
my %copy = %{$_};
223
+
$copy{serviceEndpoint} = 'https://elsewhere.example'
224
+
if ($copy{id} // q()) eq "$did#atproto_pds";
225
+
\%copy;
226
+
} @{ $original_did_doc->{service} || [] }
227
+
];
228
+
$app->store->update_account($did, did_doc => \%bad_endpoint_doc);
229
+
230
+
$t->get_ok('/xrpc/com.atproto.server.checkAccountStatus' => {
231
+
Authorization => "Bearer $access",
232
+
})->status_is(200)
233
+
->json_is('/validDid' => JSON::PP::false);
234
+
235
+
my %bad_key_doc = %{$original_did_doc};
236
+
$bad_key_doc{verificationMethod} = [
237
+
map {
238
+
my %copy = %{$_};
239
+
$copy{publicKeyMultibase} = 'zQmInvalidSigningKey'
240
+
if ($copy{id} // q()) eq "$did#atproto";
241
+
\%copy;
242
+
} @{ $original_did_doc->{verificationMethod} || [] }
243
+
];
244
+
$app->store->update_account($did, did_doc => \%bad_key_doc);
245
+
246
+
$t->get_ok('/xrpc/com.atproto.server.checkAccountStatus' => {
247
+
Authorization => "Bearer $access",
248
+
})->status_is(200)
249
+
->json_is('/validDid' => JSON::PP::false);
250
+
251
+
$app->store->update_account($did, did_doc => $original_did_doc);
214
252
215
253
$t->get_ok('/xrpc/com.atproto.server.checkAccountStatus' => {
216
254
Authorization => "Bearer $second_access",
+20
t/repo-api.t
+20
t/repo-api.t
···
83
83
my $access = $session->{accessJwt};
84
84
my $refresh = $session->{refreshJwt};
85
85
86
+
$t->get_ok("/xrpc/com.atproto.repo.describeRepo?repo=$did")
87
+
->status_is(200)
88
+
->json_is('/did' => $did)
89
+
->json_is('/didDoc/id' => $did)
90
+
->json_is('/handleIsCorrect' => JSON::PP::true);
91
+
92
+
my $account = $t->app->store->get_account_by_did($did);
93
+
my $original_did_doc = $account->{did_doc};
94
+
my %stale_did_doc = %{$original_did_doc};
95
+
$stale_did_doc{alsoKnownAs} = ['at://stale-handle.localhost'];
96
+
$t->app->store->update_account($did, did_doc => \%stale_did_doc);
97
+
98
+
$t->get_ok("/xrpc/com.atproto.repo.describeRepo?repo=$did")
99
+
->status_is(200)
100
+
->json_is('/did' => $did)
101
+
->json_is('/didDoc/alsoKnownAs/0' => 'at://stale-handle.localhost')
102
+
->json_is('/handleIsCorrect' => JSON::PP::false);
103
+
104
+
$t->app->store->update_account($did, did_doc => $original_did_doc);
105
+
86
106
$t->post_ok('/xrpc/com.atproto.repo.createRecord' => { Authorization => "Bearer $access" } => json => {
87
107
repo => $did,
88
108
collection => 'app.bsky.feed.post',