perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Align repo write precondition semantics
+164
-14
+1
-1
docs/TEST_AUDIT.md
+1
-1
docs/TEST_AUDIT.md
···
55
55
- 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.
56
56
- Remote `did:plc` DID docs should resolve through the PLC directory defaults even when `plc_url` is not explicitly configured; gating that path on local config silently breaks federated identity lookups.
57
57
- `com.atproto.repo.getRecord` must honor `cid` when present, and `putRecord` / `deleteRecord` must actually enforce `swapRecord`; those negative edges are now covered directly.
58
-
- `com.atproto.repo.createRecord` follows the reference runtime by ignoring a stray `swapRecord` field, while `swapCommit` mismatches still need direct negative coverage on write paths instead of relying on indirect `applyWrites` behavior.
58
+
- `com.atproto.repo.createRecord` follows the reference runtime by ignoring a stray `swapRecord` field, and direct reference coverage now pins `putRecord` / `deleteRecord` `swapCommit` and `swapRecord` mismatch semantics explicitly.
59
59
- `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.
60
60
- `com.atproto.server.createAccount` with an explicit `did` must behave like an authenticated migration flow: require auth from that same DID, keep the existing DID document, and start the new account deactivated until activation catches the DID document up to the new PDS.
61
61
- `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.
+14
lib/ATProto/PDS/API/Repo.pm
+14
lib/ATProto/PDS/API/Repo.pm
···
284
284
}
285
285
286
286
sub _apply_single_write ($c, $body, $write, %args) {
287
+
_assert_optional_cid_string($body, 'swapCommit');
287
288
my ($claims, $account) = _require_repo_owner($c, $body->{repo});
288
289
_assert_oauth_write_permissions($claims, [$write]);
289
290
my $commit = $c->repo_manager->apply_writes(
···
305
306
}
306
307
307
308
sub _put_record ($c, $body) {
309
+
_assert_optional_cid_string($body, 'swapCommit');
310
+
_assert_optional_cid_string($body, 'swapRecord');
308
311
my ($claims, $account) = _require_repo_owner($c, $body->{repo});
309
312
my $did = $account->{did};
310
313
my $collection = $body->{collection};
···
355
358
}
356
359
357
360
sub _delete_record ($c, $body) {
361
+
_assert_optional_cid_string($body, 'swapCommit');
362
+
_assert_optional_cid_string($body, 'swapRecord');
358
363
my ($claims, $account) = _require_repo_owner($c, $body->{repo});
359
364
my $current = $c->store->get_record($account->{did}, $body->{collection}, $body->{rkey});
360
365
return {} unless $current;
···
527
532
return @found;
528
533
}
529
534
return ();
535
+
}
536
+
537
+
sub _assert_optional_cid_string ($body, $field) {
538
+
return unless exists $body->{$field};
539
+
my $value = $body->{$field};
540
+
return unless defined $value && length $value;
541
+
eval { ATProto::PDS::Repo::CID->from_string($value) };
542
+
return unless $@;
543
+
xrpc_error(400, 'InvalidRequest', "Input/$field must be a cid string");
530
544
}
531
545
532
546
sub _normalize_apply_writes_input ($write) {
+4
-4
lib/ATProto/PDS/Repo/Manager.pm
+4
-4
lib/ATProto/PDS/Repo/Manager.pm
···
63
63
die {
64
64
status => 400,
65
65
error => 'InvalidSwap',
66
-
message => 'swapCommit did not match the current repo head',
66
+
message => 'Commit was at ' . (defined($current) ? $current : 'null'),
67
67
} unless defined $current && $current eq $opts{swap_commit};
68
68
}
69
69
···
97
97
die {
98
98
status => 400,
99
99
error => 'InvalidSwap',
100
-
message => 'swapRecord did not match the current record',
100
+
message => 'Record was at ' . (defined($current_cid) ? $current_cid : 'null'),
101
101
} if $action eq 'create' && defined $swap_record;
102
102
die {
103
103
status => 400,
104
104
error => 'InvalidSwap',
105
-
message => 'swapRecord did not match the current record',
105
+
message => 'Record was at ' . (defined($current_cid) ? $current_cid : 'null'),
106
106
} if ($action eq 'update' || $action eq 'delete') && !defined $swap_record;
107
107
my $mismatch = (defined($current_cid) || defined($swap_record))
108
108
&& (!defined($current_cid) || !defined($swap_record) || $current_cid ne $swap_record);
109
109
die {
110
110
status => 400,
111
111
error => 'InvalidSwap',
112
-
message => 'swapRecord did not match the current record',
112
+
message => 'Record was at ' . (defined($current_cid) ? $current_cid : 'null'),
113
113
} if $mismatch;
114
114
}
115
115
+6
-1
lib/ATProto/PDS/Store/SQLite.pm
+6
-1
lib/ATProto/PDS/Store/SQLite.pm
···
805
805
if (defined $cursor && length $cursor) {
806
806
@rows = grep { $_->{cid} gt $cursor } @rows;
807
807
}
808
-
return _paginate(\@rows, $limit, 'cid');
808
+
my @items = @rows;
809
+
splice @items, $limit if @items > $limit;
810
+
return {
811
+
items => \@items,
812
+
cursor => @items ? $items[-1]{cid} : undef,
813
+
};
809
814
}
810
815
811
816
sub count_blobs_by_did ($self, $did) {
+89
-5
script/differential-validate
+89
-5
script/differential-validate
···
46
46
post_json
47
47
);
48
48
49
+
sub normalize_swap_message ($message) {
50
+
return 'record-at-cid' if ($message // q()) =~ /\ARecord was at b/i;
51
+
return 'record-at-null' if ($message // q()) eq 'Record was at null';
52
+
return 'commit-at-cid' if ($message // q()) =~ /\ACommit was at b/i;
53
+
return 'commit-at-null' if ($message // q()) eq 'Commit was at null';
54
+
return $message // q();
55
+
}
56
+
49
57
my $root = File::Spec->rel2abs(File::Spec->catdir(dirname(__FILE__), '..'));
50
58
my $tmp = tempdir(CLEANUP => 1);
51
59
my @children;
···
828
836
created_record_reads => $created_record->is_success ? 1 : 0,
829
837
created_text_ok => (($created_record->json || {})->{value}{text} // q()) =~ /^put create validation / ? 1 : 0,
830
838
};
839
+
$server{$name}{updated_record_cid} = ($update_res->json || {})->{cid};
831
840
}
832
841
833
842
check(
834
843
same_hash($server{reference}{put_record}, $server{perlsky}{put_record}),
835
844
'putRecord create-or-update semantics match the official reference PDS',
836
845
);
846
+
847
+
note('Comparing repo write swap preconditions');
848
+
for my $name (sort keys %server) {
849
+
my $put_swap_commit = post_json($server{$name}{origin}, 'com.atproto.repo.putRecord', {
850
+
repo => $server{$name}{did},
851
+
collection => 'app.bsky.feed.post',
852
+
rkey => 'diffpost',
853
+
swapCommit => 'bafyreifakeheadmismatch',
854
+
record => {
855
+
'$type' => 'app.bsky.feed.post',
856
+
text => "put swapCommit mismatch for $name",
857
+
createdAt => '2026-03-11T00:00:02Z',
858
+
},
859
+
}, auth_header($server{$name}{access}));
860
+
861
+
my $put_swap_record = post_json($server{$name}{origin}, 'com.atproto.repo.putRecord', {
862
+
repo => $server{$name}{did},
863
+
collection => 'app.bsky.feed.post',
864
+
rkey => 'diffpost',
865
+
swapRecord => 'bafyreifakecidmismatch',
866
+
record => {
867
+
'$type' => 'app.bsky.feed.post',
868
+
text => "put swapRecord mismatch for $name",
869
+
createdAt => '2026-03-11T00:00:03Z',
870
+
},
871
+
}, auth_header($server{$name}{access}));
872
+
873
+
my $delete_swap_commit = post_json($server{$name}{origin}, 'com.atproto.repo.deleteRecord', {
874
+
repo => $server{$name}{did},
875
+
collection => 'app.bsky.feed.post',
876
+
rkey => 'diffpost',
877
+
swapCommit => 'bafyreifakeheadmismatch',
878
+
}, auth_header($server{$name}{access}));
879
+
880
+
my $delete_swap_record = post_json($server{$name}{origin}, 'com.atproto.repo.deleteRecord', {
881
+
repo => $server{$name}{did},
882
+
collection => 'app.bsky.feed.post',
883
+
rkey => 'diffpost',
884
+
swapRecord => $server{$name}{record_cid},
885
+
}, auth_header($server{$name}{access}));
886
+
887
+
$server{$name}{swap_preconditions} = {
888
+
put_swap_commit => {
889
+
status => $put_swap_commit->code // 0,
890
+
error => ($put_swap_commit->json || {})->{error} // q(),
891
+
message => normalize_swap_message(($put_swap_commit->json || {})->{message}),
892
+
},
893
+
put_swap_record => {
894
+
status => $put_swap_record->code // 0,
895
+
error => ($put_swap_record->json || {})->{error} // q(),
896
+
message => normalize_swap_message(($put_swap_record->json || {})->{message}),
897
+
},
898
+
delete_swap_commit => {
899
+
status => $delete_swap_commit->code // 0,
900
+
error => ($delete_swap_commit->json || {})->{error} // q(),
901
+
message => normalize_swap_message(($delete_swap_commit->json || {})->{message}),
902
+
},
903
+
delete_swap_record => {
904
+
status => $delete_swap_record->code // 0,
905
+
error => ($delete_swap_record->json || {})->{error} // q(),
906
+
message => normalize_swap_message(($delete_swap_record->json || {})->{message}),
907
+
},
908
+
};
909
+
}
910
+
911
+
if (!same_hash($server{reference}{swap_preconditions}, $server{perlsky}{swap_preconditions})) {
912
+
note('reference swap preconditions: ' . encode_json($server{reference}{swap_preconditions}));
913
+
note('perlsky swap preconditions: ' . encode_json($server{perlsky}{swap_preconditions}));
914
+
fail_check('repo write swap preconditions match the official reference PDS');
915
+
} else {
916
+
pass('repo write swap preconditions match the official reference PDS');
917
+
}
837
918
838
919
note('Comparing moderation takedown behavior');
839
920
for my $name (sort keys %server) {
···
1318
1399
my $blob_cid = $blob->{ref}{'$link'};
1319
1400
$server{$name}{list_blobs_since} = {
1320
1401
ok => $res->is_success ? 1 : 0,
1321
-
returns_blob => grep { $_ eq $blob_cid } @{ $json->{cids} || [] } ? 1 : 0,
1402
+
returns_blob => (scalar grep { $_ eq $blob_cid } @{ $json->{cids} || [] }) ? 1 : 0,
1322
1403
cursor_matches_tail => (($json->{cursor} // q()) eq (($json->{cids} || [])->[-1] // q())) ? 1 : 0,
1323
1404
};
1324
1405
}
1325
1406
1326
-
check(
1327
-
same_hash($server{reference}{list_blobs_since}, $server{perlsky}{list_blobs_since}),
1328
-
'listBlobs since semantics match the official reference PDS',
1329
-
);
1407
+
if (!same_hash($server{reference}{list_blobs_since}, $server{perlsky}{list_blobs_since})) {
1408
+
note('reference listBlobs since: ' . encode_json($server{reference}{list_blobs_since}));
1409
+
note('perlsky listBlobs since: ' . encode_json($server{perlsky}{list_blobs_since}));
1410
+
fail_check('listBlobs since semantics match the official reference PDS');
1411
+
} else {
1412
+
pass('listBlobs since semantics match the official reference PDS');
1413
+
}
1330
1414
1331
1415
note('Comparing listMissingBlobs empty-state semantics');
1332
1416
for my $name (sort keys %server) {
+1
-1
t/external-surface.t
+1
-1
t/external-surface.t
+49
-2
t/repo-api.t
+49
-2
t/repo-api.t
···
116
116
},
117
117
})->status_is(200)
118
118
->json_like('/cid' => qr/\Ab/);
119
+
my $first_post_cid = $t->tx->res->json->{cid};
119
120
120
121
$t->post_ok('/xrpc/com.atproto.repo.createRecord' => { Authorization => "Bearer $access" } => json => {
121
122
repo => $did,
···
179
180
repo => $did,
180
181
collection => 'app.bsky.feed.post',
181
182
rkey => 'first-post',
182
-
swapCommit => 'bafyreifakeheadmismatch',
183
+
swapCommit => $first_post_cid,
183
184
record => {
184
185
'$type' => 'app.bsky.feed.post',
185
186
text => 'swapCommit mismatch should fail',
···
192
193
repo => $did,
193
194
collection => 'app.bsky.feed.post',
194
195
rkey => 'first-post',
196
+
swapCommit => 'not-a-cid',
197
+
record => {
198
+
'$type' => 'app.bsky.feed.post',
199
+
text => 'swapCommit syntax should fail',
200
+
createdAt => '2026-03-10T00:02:16Z',
201
+
},
202
+
})->status_is(400)
203
+
->json_is('/error' => 'InvalidRequest')
204
+
->json_like('/message' => qr{Input/swapCommit must be a cid string});
205
+
206
+
$t->post_ok('/xrpc/com.atproto.repo.putRecord' => { Authorization => "Bearer $access" } => json => {
207
+
repo => $did,
208
+
collection => 'app.bsky.feed.post',
209
+
rkey => 'first-post',
195
210
record => {
196
211
'$type' => 'app.bsky.feed.post',
197
212
text => 'hello from updated perl',
···
225
240
repo => $did,
226
241
collection => 'app.bsky.feed.post',
227
242
rkey => 'first-post',
228
-
swapRecord => 'bafyreifakecidmismatch',
243
+
swapRecord => $first_post_cid,
229
244
record => {
230
245
'$type' => 'app.bsky.feed.post',
231
246
text => 'swap mismatch should fail',
···
238
253
repo => $did,
239
254
collection => 'app.bsky.feed.post',
240
255
rkey => 'first-post',
256
+
swapRecord => 'not-a-cid',
257
+
record => {
258
+
'$type' => 'app.bsky.feed.post',
259
+
text => 'swapRecord syntax should fail',
260
+
createdAt => '2026-03-10T00:03:01Z',
261
+
},
262
+
})->status_is(400)
263
+
->json_is('/error' => 'InvalidRequest')
264
+
->json_like('/message' => qr{Input/swapRecord must be a cid string});
265
+
266
+
$t->post_ok('/xrpc/com.atproto.repo.putRecord' => { Authorization => "Bearer $access" } => json => {
267
+
repo => $did,
268
+
collection => 'app.bsky.feed.post',
269
+
rkey => 'first-post',
241
270
swapRecord => $updated_cid,
242
271
record => {
243
272
'$type' => 'app.bsky.feed.post',
···
359
388
$t->get_ok("/xrpc/com.atproto.sync.getHead?did=$did")
360
389
->status_is(200)
361
390
->json_like('/root' => qr/\Ab/);
391
+
392
+
$t->post_ok('/xrpc/com.atproto.repo.deleteRecord' => { Authorization => "Bearer $access" } => json => {
393
+
repo => $did,
394
+
collection => 'app.bsky.feed.post',
395
+
rkey => 'first-post',
396
+
swapCommit => 'not-a-cid',
397
+
})->status_is(400)
398
+
->json_is('/error' => 'InvalidRequest')
399
+
->json_like('/message' => qr{Input/swapCommit must be a cid string});
400
+
401
+
$t->post_ok('/xrpc/com.atproto.repo.deleteRecord' => { Authorization => "Bearer $access" } => json => {
402
+
repo => $did,
403
+
collection => 'app.bsky.feed.post',
404
+
rkey => 'first-post',
405
+
swapRecord => 'not-a-cid',
406
+
})->status_is(400)
407
+
->json_is('/error' => 'InvalidRequest')
408
+
->json_like('/message' => qr{Input/swapRecord must be a cid string});
362
409
363
410
$t->post_ok('/xrpc/com.atproto.repo.deleteRecord' => { Authorization => "Bearer $access" } => json => {
364
411
repo => $did,