perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Add identity helpers and IPLD primitives
+1175
-22
+18
-17
lib/ATProto/PDS.pm
+18
-17
lib/ATProto/PDS.pm
···
5
5
6
6
use Mojo::Base 'Mojolicious', -signatures;
7
7
use Mojo::JSON ();
8
+
use ATProto::PDS::API::Builtins qw(register_builtin_handlers);
8
9
use ATProto::PDS::API::Registry;
10
+
use ATProto::PDS::Identity qw(service_did);
9
11
use ATProto::PDS::LexiconCatalog qw(endpoint_catalog);
12
+
use ATProto::PDS::LexiconRegistry;
10
13
use ATProto::PDS::XRPC::Dispatcher;
11
14
12
15
has project_root => '';
···
20
23
$self->helper(api_registry => sub { state $registry = ATProto::PDS::API::Registry->new });
21
24
$self->helper(endpoint_catalog => sub ($c) { endpoint_catalog($root) });
22
25
$self->helper(config_value => sub ($c, $key, $default = undef) { $c->app->settings->{$key} // $default });
26
+
$self->helper(lexicons => sub ($c) { state $registry = ATProto::PDS::LexiconRegistry->new(root => $root) });
23
27
24
28
my $routes = $self->routes;
25
29
$routes->get('/')->to(cb => sub ($c) {
26
30
$c->render(json => {
27
31
service => 'perlds',
28
32
status => 'booting',
33
+
did => service_did($c->app->settings),
29
34
endpoints => scalar @{ $c->endpoint_catalog },
30
35
});
31
36
});
···
38
43
});
39
44
});
40
45
41
-
$self->_register_builtin_handlers;
46
+
$routes->get('/.well-known/did.json')->to(cb => sub ($c) {
47
+
$c->render(json => {
48
+
'@context' => ['https://www.w3.org/ns/did/v1'],
49
+
id => service_did($c->app->settings),
50
+
service => [{
51
+
id => service_did($c->app->settings) . '#atproto_pds',
52
+
type => 'AtprotoPersonalDataServer',
53
+
serviceEndpoint => $c->config_value('base_url', 'http://127.0.0.1:7755'),
54
+
}],
55
+
});
56
+
});
57
+
58
+
register_builtin_handlers($self->api_registry, $self);
42
59
ATProto::PDS::XRPC::Dispatcher->new(
43
60
app => $self,
44
61
routes => $routes,
45
62
catalog => endpoint_catalog($root),
46
63
)->register_routes;
47
-
}
48
-
49
-
sub _register_builtin_handlers ($self) {
50
-
$self->api_registry->register('com.atproto.server.describeServer', sub ($c, $endpoint) {
51
-
my $domain = $c->config_value('service_handle_domain', 'localhost');
52
-
my $base = $c->config_value('base_url', 'http://127.0.0.1:7755');
53
-
(my $host = $base) =~ s{\Ahttps?://}{};
54
-
$host =~ s{/.*\z}{};
55
-
56
-
$c->render(json => {
57
-
inviteCodeRequired => Mojo::JSON->false,
58
-
phoneVerificationRequired => Mojo::JSON->false,
59
-
availableUserDomains => [$domain],
60
-
did => "did:web:$host",
61
-
});
62
-
});
63
64
}
64
65
65
66
1;
+91
lib/ATProto/PDS/API/Builtins.pm
+91
lib/ATProto/PDS/API/Builtins.pm
···
1
+
package ATProto::PDS::API::Builtins;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use Mojo::JSON qw(false true);
10
+
11
+
use ATProto::PDS::Identity qw(service_did service_did_doc);
12
+
13
+
our @EXPORT_OK = qw(register_builtin_handlers);
14
+
15
+
sub register_builtin_handlers ($registry, $app) {
16
+
$registry->register('com.atproto.server.describeServer', sub ($c, $endpoint) {
17
+
return {
18
+
inviteCodeRequired => false,
19
+
phoneVerificationRequired => false,
20
+
availableUserDomains => [ $c->config_value('service_handle_domain', 'localhost') ],
21
+
did => service_did($c->app->settings),
22
+
};
23
+
});
24
+
25
+
$registry->register('com.atproto.identity.resolveDid', sub ($c, $endpoint) {
26
+
my $did = $c->param('did') // '';
27
+
my $service_did = service_did($c->app->settings);
28
+
die {
29
+
status => 404,
30
+
error => 'DidNotFound',
31
+
message => "No DID document found for $did",
32
+
} unless _same_did($did, $service_did);
33
+
34
+
return {
35
+
didDoc => service_did_doc($c->app->settings),
36
+
};
37
+
});
38
+
39
+
$registry->register('com.atproto.identity.resolveHandle', sub ($c, $endpoint) {
40
+
my $handle = lc($c->param('handle') // '');
41
+
my $service_handle = lc($c->config_value('service_handle_domain', 'localhost'));
42
+
die {
43
+
status => 404,
44
+
error => 'HandleNotFound',
45
+
message => "No DID found for handle $handle",
46
+
} unless $handle eq $service_handle;
47
+
48
+
return {
49
+
did => service_did($c->app->settings),
50
+
};
51
+
});
52
+
53
+
$registry->register('com.atproto.identity.resolveIdentity', sub ($c, $endpoint) {
54
+
my $identifier = lc($c->param('identifier') // '');
55
+
my $service_did = lc(service_did($c->app->settings));
56
+
my $service_handle = lc($c->config_value('service_handle_domain', 'localhost'));
57
+
die {
58
+
status => 404,
59
+
error => ($identifier =~ /^did:/ ? 'DidNotFound' : 'HandleNotFound'),
60
+
message => "No identity found for $identifier",
61
+
} unless _same_did($identifier, $service_did) || $identifier eq $service_handle;
62
+
63
+
return {
64
+
did => service_did($c->app->settings),
65
+
handle => $c->config_value('service_handle_domain', 'localhost'),
66
+
didDoc => service_did_doc($c->app->settings),
67
+
};
68
+
});
69
+
70
+
$registry->register('com.atproto.temp.checkHandleAvailability', sub ($c, $endpoint) {
71
+
my $payload = $c->req->json || {};
72
+
my $handle = lc($payload->{handle} // '');
73
+
my $service_handle = lc($c->config_value('service_handle_domain', 'localhost'));
74
+
return {
75
+
handle => $handle,
76
+
available => ($handle ne '' && $handle ne $service_handle ? true : false),
77
+
};
78
+
});
79
+
}
80
+
81
+
sub _same_did ($left, $right) {
82
+
return lc(_relaxed_did($left)) eq lc(_relaxed_did($right));
83
+
}
84
+
85
+
sub _relaxed_did ($did) {
86
+
$did //= '';
87
+
$did =~ s/%3a/:/ig;
88
+
return $did;
89
+
}
90
+
91
+
1;
+95
lib/ATProto/PDS/Auth/JWT.pm
+95
lib/ATProto/PDS/Auth/JWT.pm
···
1
+
package ATProto::PDS::Auth::JWT;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use Digest::SHA qw(hmac_sha256);
10
+
use JSON::PP qw(decode_json encode_json);
11
+
use MIME::Base64 qw(decode_base64 encode_base64);
12
+
13
+
our @EXPORT_OK = qw(decode_jwt encode_jwt);
14
+
15
+
sub encode_jwt ($claims, $secret, $header = undef) {
16
+
die 'claims must be a hashref' unless ref($claims) eq 'HASH';
17
+
die 'secret is required' unless defined $secret && length $secret;
18
+
19
+
my $jwt_header = {
20
+
alg => 'HS256',
21
+
typ => 'JWT',
22
+
%{ $header // {} },
23
+
};
24
+
25
+
my $header_b64 = _b64url_encode(encode_json($jwt_header));
26
+
my $claims_b64 = _b64url_encode(encode_json($claims));
27
+
my $signing_str = join('.', $header_b64, $claims_b64);
28
+
my $sig = _b64url_encode(hmac_sha256($signing_str, $secret));
29
+
30
+
return join('.', $signing_str, $sig);
31
+
}
32
+
33
+
sub decode_jwt ($token, $secret, %opts) {
34
+
die 'token is required' unless defined $token && length $token;
35
+
die 'secret is required' unless defined $secret && length $secret;
36
+
37
+
my ($header_b64, $claims_b64, $sig_b64) = split(/\./, $token, 3);
38
+
die 'token must contain three sections' unless defined $sig_b64;
39
+
40
+
my $signing_str = join('.', $header_b64, $claims_b64);
41
+
my $expected = _b64url_encode(hmac_sha256($signing_str, $secret));
42
+
die 'invalid signature' unless _timing_safe_eq($expected, $sig_b64);
43
+
44
+
my $header = decode_json(_b64url_decode($header_b64));
45
+
my $claims = decode_json(_b64url_decode($claims_b64));
46
+
47
+
die 'unsupported jwt alg' unless ($header->{alg} // '') eq 'HS256';
48
+
my $now = $opts{now} // time;
49
+
50
+
die 'token not yet valid' if defined $claims->{nbf} && $claims->{nbf} > $now;
51
+
die 'token expired' if defined $claims->{exp} && $claims->{exp} <= $now;
52
+
53
+
if (defined $opts{audience}) {
54
+
my $aud = $claims->{aud};
55
+
if (ref($aud) eq 'ARRAY') {
56
+
die 'unexpected audience' unless grep { defined($_) && $_ eq $opts{audience} } @$aud;
57
+
} else {
58
+
die 'unexpected audience' unless defined($aud) && $aud eq $opts{audience};
59
+
}
60
+
}
61
+
62
+
return {
63
+
header => $header,
64
+
claims => $claims,
65
+
};
66
+
}
67
+
68
+
sub _b64url_encode ($bytes) {
69
+
my $b64 = encode_base64($bytes, q());
70
+
$b64 =~ tr{+/}{-_};
71
+
$b64 =~ s/=+\z//;
72
+
return $b64;
73
+
}
74
+
75
+
sub _b64url_decode ($text) {
76
+
my $b64 = $text;
77
+
$b64 =~ tr{-_}{+/};
78
+
my $pad = length($b64) % 4;
79
+
$b64 .= '=' x (4 - $pad) if $pad;
80
+
return decode_base64($b64);
81
+
}
82
+
83
+
sub _timing_safe_eq ($left, $right) {
84
+
return 0 unless defined $left && defined $right;
85
+
return 0 unless length($left) == length($right);
86
+
87
+
my $diff = 0;
88
+
for my $index (0 .. length($left) - 1) {
89
+
$diff |= ord(substr($left, $index, 1)) ^ ord(substr($right, $index, 1));
90
+
}
91
+
92
+
return $diff == 0 ? 1 : 0;
93
+
}
94
+
95
+
1;
+60
lib/ATProto/PDS/IPLD/Base32.pm
+60
lib/ATProto/PDS/IPLD/Base32.pm
···
1
+
package ATProto::PDS::IPLD::Base32;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
10
+
our @EXPORT_OK = qw(encode_base32 decode_base32);
11
+
12
+
my $ALPHABET = 'abcdefghijklmnopqrstuvwxyz234567';
13
+
my %DECODE = map { substr($ALPHABET, $_, 1) => $_ } 0 .. length($ALPHABET) - 1;
14
+
15
+
sub encode_base32 ($bytes) {
16
+
return '' unless length $bytes;
17
+
18
+
my $bits = 0;
19
+
my $buffer = 0;
20
+
my $out = '';
21
+
22
+
for my $byte (unpack('C*', $bytes)) {
23
+
$buffer = ($buffer << 8) | $byte;
24
+
$bits += 8;
25
+
while ($bits >= 5) {
26
+
$bits -= 5;
27
+
$out .= substr($ALPHABET, ($buffer >> $bits) & 0x1f, 1);
28
+
}
29
+
}
30
+
31
+
if ($bits > 0) {
32
+
$out .= substr($ALPHABET, ($buffer << (5 - $bits)) & 0x1f, 1);
33
+
}
34
+
35
+
return $out;
36
+
}
37
+
38
+
sub decode_base32 ($text) {
39
+
return '' unless length $text;
40
+
41
+
my $bits = 0;
42
+
my $buffer = 0;
43
+
my @bytes;
44
+
45
+
for my $char (split //, lc $text) {
46
+
die "invalid base32 character: $char" unless exists $DECODE{$char};
47
+
$buffer = ($buffer << 5) | $DECODE{$char};
48
+
$bits += 5;
49
+
while ($bits >= 8) {
50
+
$bits -= 8;
51
+
push @bytes, ($buffer >> $bits) & 0xff;
52
+
}
53
+
}
54
+
55
+
die 'invalid base32 tail bits' if $bits && (($buffer & ((1 << $bits) - 1)) != 0);
56
+
57
+
return pack('C*', @bytes);
58
+
}
59
+
60
+
1;
+53
lib/ATProto/PDS/IPLD/Base58.pm
+53
lib/ATProto/PDS/IPLD/Base58.pm
···
1
+
package ATProto::PDS::IPLD::Base58;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use Math::BigInt try => 'GMP';
10
+
11
+
our @EXPORT_OK = qw(encode_base58btc decode_base58btc);
12
+
13
+
my $ALPHABET = '123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz';
14
+
my %DECODE = map { substr($ALPHABET, $_, 1) => $_ } 0 .. length($ALPHABET) - 1;
15
+
16
+
sub encode_base58btc ($bytes) {
17
+
return '' unless length $bytes;
18
+
19
+
my $num = Math::BigInt->from_hex('0x' . unpack('H*', $bytes));
20
+
my $out = '';
21
+
22
+
while ($num > 0) {
23
+
my ($q, $r) = $num->copy->bdiv(58);
24
+
$out = substr($ALPHABET, $r->numify, 1) . $out;
25
+
$num = $q;
26
+
}
27
+
28
+
my $leading = 0;
29
+
$leading++ while $leading < length($bytes) && substr($bytes, $leading, 1) eq "\x00";
30
+
return ('1' x $leading) . ($out || '');
31
+
}
32
+
33
+
sub decode_base58btc ($text) {
34
+
return '' unless length $text;
35
+
36
+
my $num = Math::BigInt->new(0);
37
+
for my $char (split //, $text) {
38
+
die "invalid base58btc character: $char" unless exists $DECODE{$char};
39
+
$num->bmul(58);
40
+
$num->badd($DECODE{$char});
41
+
}
42
+
43
+
my $hex = $num->as_hex;
44
+
$hex =~ s/^0x//;
45
+
$hex = "0$hex" if length($hex) % 2;
46
+
my $bytes = $hex eq '00' && $num == 0 ? '' : pack('H*', $hex);
47
+
48
+
my $leading = 0;
49
+
$leading++ while $leading < length($text) && substr($text, $leading, 1) eq '1';
50
+
return ("\x00" x $leading) . $bytes;
51
+
}
52
+
53
+
1;
+28
lib/ATProto/PDS/IPLD/Base64.pm
+28
lib/ATProto/PDS/IPLD/Base64.pm
···
1
+
package ATProto::PDS::IPLD::Base64;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use MIME::Base64 qw(encode_base64 decode_base64);
10
+
11
+
our @EXPORT_OK = qw(encode_base64url decode_base64url);
12
+
13
+
sub encode_base64url ($bytes) {
14
+
my $text = encode_base64($bytes, '');
15
+
$text =~ tr{+/}{-_};
16
+
$text =~ s/=+\z//;
17
+
return $text;
18
+
}
19
+
20
+
sub decode_base64url ($text) {
21
+
my $copy = $text;
22
+
$copy =~ tr{-_}{+/};
23
+
my $pad = length($copy) % 4;
24
+
$copy .= '=' x (4 - $pad) if $pad;
25
+
return decode_base64($copy);
26
+
}
27
+
28
+
1;
+18
lib/ATProto/PDS/IPLD/Bytes.pm
+18
lib/ATProto/PDS/IPLD/Bytes.pm
···
1
+
package ATProto::PDS::IPLD::Bytes;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use overload '""' => sub ($self, @) { $self->{bytes} }, fallback => 1;
9
+
10
+
sub new ($class, $bytes) {
11
+
return bless { bytes => $bytes // '' }, $class;
12
+
}
13
+
14
+
sub bytes ($self) {
15
+
return $self->{bytes};
16
+
}
17
+
18
+
1;
+122
lib/ATProto/PDS/IPLD/CID.pm
+122
lib/ATProto/PDS/IPLD/CID.pm
···
1
+
package ATProto::PDS::IPLD::CID;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use Scalar::Util qw(blessed);
10
+
11
+
use ATProto::PDS::IPLD::Base32 qw(encode_base32 decode_base32);
12
+
use ATProto::PDS::IPLD::Base58 qw(encode_base58btc decode_base58btc);
13
+
use ATProto::PDS::IPLD::Multihash qw(sha256_multihash decode_multihash);
14
+
use ATProto::PDS::IPLD::Varint qw(encode_uvarint decode_uvarint);
15
+
16
+
our @EXPORT_OK = qw(CODEC_DAG_CBOR CODEC_RAW cid_from_bytes cid_from_data);
17
+
18
+
use constant CODEC_DAG_CBOR => 0x71;
19
+
use constant CODEC_RAW => 0x55;
20
+
21
+
sub new ($class, %args) {
22
+
die 'CIDv1 only' unless ($args{version} // 1) == 1;
23
+
die 'missing multihash bytes' unless defined $args{multihash};
24
+
25
+
return bless {
26
+
version => 1,
27
+
codec => $args{codec},
28
+
multihash => $args{multihash},
29
+
}, $class;
30
+
}
31
+
32
+
sub parse ($class, $text) {
33
+
my $bytes;
34
+
if ($text =~ /\Ab([a-z2-7]+)\z/i) {
35
+
$bytes = decode_base32($1);
36
+
} elsif ($text =~ /\Az([1-9A-HJ-NP-Za-km-z]+)\z/) {
37
+
$bytes = decode_base58btc($1);
38
+
} else {
39
+
die "unsupported CID multibase: $text";
40
+
}
41
+
42
+
return $class->from_bytes($bytes);
43
+
}
44
+
45
+
sub from_bytes ($class, $bytes) {
46
+
my ($version, $after_version) = decode_uvarint($bytes, 0);
47
+
die 'CIDv1 only' unless $version == 1;
48
+
my ($codec, $after_codec) = decode_uvarint($bytes, $after_version);
49
+
my ($multihash, $end) = decode_multihash($bytes, $after_codec);
50
+
die 'trailing bytes after CID' unless $end == length $bytes;
51
+
52
+
return $class->new(
53
+
codec => $codec,
54
+
multihash => $multihash->{bytes},
55
+
);
56
+
}
57
+
58
+
sub from_data ($class, $codec, $bytes) {
59
+
return $class->new(
60
+
codec => $codec,
61
+
multihash => sha256_multihash($bytes),
62
+
);
63
+
}
64
+
65
+
sub cid_from_bytes ($codec, $bytes) {
66
+
return __PACKAGE__->from_data($codec, $bytes);
67
+
}
68
+
69
+
sub cid_from_data ($codec, $bytes) {
70
+
return __PACKAGE__->from_data($codec, $bytes);
71
+
}
72
+
73
+
sub version ($self) {
74
+
return $self->{version};
75
+
}
76
+
77
+
sub codec ($self) {
78
+
return $self->{codec};
79
+
}
80
+
81
+
sub multihash ($self) {
82
+
return $self->{multihash};
83
+
}
84
+
85
+
sub digest ($self) {
86
+
my ($parts) = decode_multihash($self->{multihash}, 0);
87
+
return $parts->{digest};
88
+
}
89
+
90
+
sub hash_code ($self) {
91
+
my ($parts) = decode_multihash($self->{multihash}, 0);
92
+
return $parts->{code};
93
+
}
94
+
95
+
sub to_bytes ($self) {
96
+
return encode_uvarint($self->{version}) . encode_uvarint($self->{codec}) . $self->{multihash};
97
+
}
98
+
99
+
sub to_string ($self, $base = 'base32') {
100
+
my $bytes = $self->to_bytes;
101
+
return 'b' . encode_base32($bytes) if $base eq 'base32';
102
+
return 'z' . encode_base58btc($bytes) if $base eq 'base58btc';
103
+
die "unsupported CID base: $base";
104
+
}
105
+
106
+
sub link_bytes ($self) {
107
+
return "\x00" . $self->to_bytes;
108
+
}
109
+
110
+
sub equals ($self, $other) {
111
+
return blessed($other) && $other->isa(__PACKAGE__) && $self->to_bytes eq $other->to_bytes;
112
+
}
113
+
114
+
use overload
115
+
'""' => sub ($self, @) { $self->to_string },
116
+
'eq' => sub ($left, $right, $swap) {
117
+
my ($a, $b) = $swap ? ($right, $left) : ($left, $right);
118
+
return blessed($b) && $b->isa(__PACKAGE__) ? $a->equals($b) : "$a" eq "$b";
119
+
},
120
+
fallback => 1;
121
+
122
+
1;
+223
lib/ATProto/PDS/IPLD/DAGCBOR.pm
+223
lib/ATProto/PDS/IPLD/DAGCBOR.pm
···
1
+
package ATProto::PDS::IPLD::DAGCBOR;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use Encode qw(encode decode FB_CROAK);
10
+
use JSON::PP ();
11
+
use Scalar::Util qw(blessed looks_like_number);
12
+
13
+
use ATProto::PDS::IPLD::Bytes;
14
+
use ATProto::PDS::IPLD::CID qw(CODEC_DAG_CBOR cid_from_bytes);
15
+
16
+
our @EXPORT_OK = qw(encode_dag_cbor decode_dag_cbor cid_for_dag_cbor);
17
+
18
+
sub encode_dag_cbor ($value) {
19
+
return _encode_item($value);
20
+
}
21
+
22
+
sub decode_dag_cbor ($bytes) {
23
+
my ($value, $offset) = _decode_item($bytes, 0);
24
+
die 'trailing data after DAG-CBOR item' unless $offset == length $bytes;
25
+
return $value;
26
+
}
27
+
28
+
sub cid_for_dag_cbor ($value) {
29
+
my $bytes = encode_dag_cbor($value);
30
+
return cid_from_bytes(CODEC_DAG_CBOR, $bytes);
31
+
}
32
+
33
+
sub _encode_item ($value) {
34
+
if (!defined $value) {
35
+
return "\xf6";
36
+
}
37
+
38
+
if (blessed($value) && $value->isa('ATProto::PDS::IPLD::CID')) {
39
+
return _encode_tag(42) . _encode_bytes($value->link_bytes);
40
+
}
41
+
42
+
if (blessed($value) && $value->isa('ATProto::PDS::IPLD::Bytes')) {
43
+
return _encode_bytes($value->bytes);
44
+
}
45
+
46
+
if (blessed($value) && ref($value) eq 'JSON::PP::Boolean') {
47
+
return $$value ? "\xf5" : "\xf4";
48
+
}
49
+
50
+
if (ref($value) eq 'ARRAY') {
51
+
my $out = _encode_type_and_length(4, scalar @$value);
52
+
$out .= _encode_item($_) for @$value;
53
+
return $out;
54
+
}
55
+
56
+
if (ref($value) eq 'HASH') {
57
+
my @pairs;
58
+
for my $key (keys %$value) {
59
+
die 'DAG-CBOR map keys must be strings' if ref $key;
60
+
my $encoded_key = _encode_text($key);
61
+
push @pairs, [$encoded_key, $key];
62
+
}
63
+
64
+
@pairs = sort {
65
+
length($a->[0]) <=> length($b->[0]) || $a->[0] cmp $b->[0]
66
+
} @pairs;
67
+
68
+
my $out = _encode_type_and_length(5, scalar @pairs);
69
+
for my $pair (@pairs) {
70
+
$out .= $pair->[0];
71
+
$out .= _encode_item($value->{ $pair->[1] });
72
+
}
73
+
return $out;
74
+
}
75
+
76
+
if (!ref($value) && _is_integer($value)) {
77
+
return $value >= 0 ? _encode_type_and_length(0, $value) : _encode_type_and_length(1, -1 - $value);
78
+
}
79
+
80
+
if (!ref($value)) {
81
+
return _encode_text($value);
82
+
}
83
+
84
+
die 'unsupported DAG-CBOR value';
85
+
}
86
+
87
+
sub _decode_item ($bytes, $offset) {
88
+
die 'unexpected end of DAG-CBOR input' if $offset >= length $bytes;
89
+
90
+
my $lead = unpack('C', substr($bytes, $offset, 1));
91
+
my $major = $lead >> 5;
92
+
my $info = $lead & 0x1f;
93
+
$offset++;
94
+
95
+
die 'indefinite-length CBOR is not supported' if $info == 31;
96
+
97
+
if ($major == 0) {
98
+
my ($value, $next) = _decode_length($bytes, $offset, $info);
99
+
return ($value, $next);
100
+
}
101
+
if ($major == 1) {
102
+
my ($value, $next) = _decode_length($bytes, $offset, $info);
103
+
return (-1 - $value, $next);
104
+
}
105
+
if ($major == 2) {
106
+
my ($length, $next) = _decode_length($bytes, $offset, $info);
107
+
my $data = substr($bytes, $next, $length);
108
+
die 'truncated byte string' unless length($data) == $length;
109
+
return (ATProto::PDS::IPLD::Bytes->new($data), $next + $length);
110
+
}
111
+
if ($major == 3) {
112
+
my ($length, $next) = _decode_length($bytes, $offset, $info);
113
+
my $data = substr($bytes, $next, $length);
114
+
die 'truncated text string' unless length($data) == $length;
115
+
return (decode('UTF-8', $data, FB_CROAK), $next + $length);
116
+
}
117
+
if ($major == 4) {
118
+
my ($length, $next) = _decode_length($bytes, $offset, $info);
119
+
my @items;
120
+
my $pos = $next;
121
+
for (1 .. $length) {
122
+
my ($item, $after) = _decode_item($bytes, $pos);
123
+
push @items, $item;
124
+
$pos = $after;
125
+
}
126
+
return (\@items, $pos);
127
+
}
128
+
if ($major == 5) {
129
+
my ($length, $next) = _decode_length($bytes, $offset, $info);
130
+
my %hash;
131
+
my $pos = $next;
132
+
for (1 .. $length) {
133
+
my ($key, $after_key) = _decode_item($bytes, $pos);
134
+
die 'DAG-CBOR map keys must decode as text strings' if ref $key;
135
+
die "duplicate DAG-CBOR map key: $key" if exists $hash{$key};
136
+
my ($value, $after_value) = _decode_item($bytes, $after_key);
137
+
$hash{$key} = $value;
138
+
$pos = $after_value;
139
+
}
140
+
return (\%hash, $pos);
141
+
}
142
+
if ($major == 6) {
143
+
my ($tag, $next) = _decode_length($bytes, $offset, $info);
144
+
die "unsupported CBOR tag: $tag" unless $tag == 42;
145
+
my ($value, $after) = _decode_item($bytes, $next);
146
+
die 'CID tag 42 must wrap a byte string' unless blessed($value) && $value->isa('ATProto::PDS::IPLD::Bytes');
147
+
my $bytes_value = $value->bytes;
148
+
die 'invalid CID tag payload' unless length($bytes_value) && substr($bytes_value, 0, 1) eq "\x00";
149
+
return (ATProto::PDS::IPLD::CID->from_bytes(substr($bytes_value, 1)), $after);
150
+
}
151
+
if ($major == 7) {
152
+
return (JSON::PP::false, $offset) if $info == 20;
153
+
return (JSON::PP::true, $offset) if $info == 21;
154
+
return (undef, $offset) if $info == 22;
155
+
die 'floating point values are not supported by AT DAG-CBOR';
156
+
}
157
+
158
+
die 'unsupported CBOR major type';
159
+
}
160
+
161
+
sub _encode_tag ($tag) {
162
+
return _encode_type_and_length(6, $tag);
163
+
}
164
+
165
+
sub _encode_bytes ($bytes) {
166
+
return _encode_type_and_length(2, length($bytes)) . $bytes;
167
+
}
168
+
169
+
sub _encode_text ($text) {
170
+
my $bytes = encode('UTF-8', $text, FB_CROAK);
171
+
return _encode_type_and_length(3, length($bytes)) . $bytes;
172
+
}
173
+
174
+
sub _encode_type_and_length ($major, $value) {
175
+
die 'negative CBOR length' if $value < 0;
176
+
177
+
if ($value < 24) {
178
+
return pack('C', ($major << 5) | $value);
179
+
}
180
+
if ($value < 256) {
181
+
return pack('CC', ($major << 5) | 24, $value);
182
+
}
183
+
if ($value < 65536) {
184
+
return pack('Cn', ($major << 5) | 25, $value);
185
+
}
186
+
if ($value < 4294967296) {
187
+
return pack('CN', ($major << 5) | 26, $value);
188
+
}
189
+
190
+
return pack('CQ>', ($major << 5) | 27, $value);
191
+
}
192
+
193
+
sub _decode_length ($bytes, $offset, $info) {
194
+
return ($info, $offset) if $info < 24;
195
+
196
+
if ($info == 24) {
197
+
die 'truncated CBOR uint8' if $offset + 1 > length $bytes;
198
+
return (unpack('C', substr($bytes, $offset, 1)), $offset + 1);
199
+
}
200
+
if ($info == 25) {
201
+
die 'truncated CBOR uint16' if $offset + 2 > length $bytes;
202
+
return (unpack('n', substr($bytes, $offset, 2)), $offset + 2);
203
+
}
204
+
if ($info == 26) {
205
+
die 'truncated CBOR uint32' if $offset + 4 > length $bytes;
206
+
return (unpack('N', substr($bytes, $offset, 4)), $offset + 4);
207
+
}
208
+
if ($info == 27) {
209
+
die 'truncated CBOR uint64' if $offset + 8 > length $bytes;
210
+
return (unpack('Q>', substr($bytes, $offset, 8)), $offset + 8);
211
+
}
212
+
213
+
die 'unsupported CBOR additional info';
214
+
}
215
+
216
+
sub _is_integer ($value) {
217
+
return 0 unless defined $value;
218
+
return 1 if $value =~ /\A-?(?:0|[1-9][0-9]*)\z/;
219
+
return 0 unless looks_like_number($value);
220
+
return int($value) == $value;
221
+
}
222
+
223
+
1;
+39
lib/ATProto/PDS/IPLD/Multihash.pm
+39
lib/ATProto/PDS/IPLD/Multihash.pm
···
1
+
package ATProto::PDS::IPLD::Multihash;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use Crypt::Digest::SHA256 qw(sha256);
10
+
11
+
use ATProto::PDS::IPLD::Varint qw(encode_uvarint decode_uvarint);
12
+
13
+
our @EXPORT_OK = qw(sha256_multihash decode_multihash);
14
+
15
+
use constant SHA256_CODE => 0x12;
16
+
17
+
sub sha256_multihash ($bytes) {
18
+
my $digest = sha256($bytes);
19
+
return encode_uvarint(SHA256_CODE) . encode_uvarint(length($digest)) . $digest;
20
+
}
21
+
22
+
sub decode_multihash ($bytes, $offset = 0) {
23
+
my ($code, $after_code) = decode_uvarint($bytes, $offset);
24
+
my ($length, $after_len) = decode_uvarint($bytes, $after_code);
25
+
my $digest = substr($bytes, $after_len, $length);
26
+
die 'truncated multihash digest' unless length($digest) == $length;
27
+
28
+
return (
29
+
{
30
+
code => $code,
31
+
length => $length,
32
+
digest => $digest,
33
+
bytes => substr($bytes, $offset, $after_len - $offset + $length),
34
+
},
35
+
$after_len + $length,
36
+
);
37
+
}
38
+
39
+
1;
+47
lib/ATProto/PDS/IPLD/Varint.pm
+47
lib/ATProto/PDS/IPLD/Varint.pm
···
1
+
package ATProto::PDS::IPLD::Varint;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
10
+
our @EXPORT_OK = qw(encode_uvarint decode_uvarint);
11
+
12
+
sub encode_uvarint ($value) {
13
+
die 'varint must be non-negative' if !defined($value) || $value < 0;
14
+
15
+
my $out = '';
16
+
while (1) {
17
+
my $byte = $value & 0x7f;
18
+
$value >>= 7;
19
+
if ($value) {
20
+
$out .= pack('C', $byte | 0x80);
21
+
} else {
22
+
$out .= pack('C', $byte);
23
+
last;
24
+
}
25
+
}
26
+
27
+
return $out;
28
+
}
29
+
30
+
sub decode_uvarint ($bytes, $offset = 0) {
31
+
my $shift = 0;
32
+
my $value = 0;
33
+
my $pos = $offset;
34
+
35
+
while ($pos < length $bytes) {
36
+
my $byte = unpack('C', substr($bytes, $pos, 1));
37
+
$value |= ($byte & 0x7f) << $shift;
38
+
$pos++;
39
+
return ($value, $pos) if ($byte & 0x80) == 0;
40
+
$shift += 7;
41
+
die 'varint overflow' if $shift > 63;
42
+
}
43
+
44
+
die 'unterminated varint';
45
+
}
46
+
47
+
1;
+108
lib/ATProto/PDS/Identity.pm
+108
lib/ATProto/PDS/Identity.pm
···
1
+
package ATProto::PDS::Identity;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
use feature 'signatures';
6
+
no warnings 'experimental::signatures';
7
+
8
+
use Exporter 'import';
9
+
use Mojo::URL;
10
+
11
+
our @EXPORT_OK = qw(
12
+
account_did
13
+
did_to_path
14
+
is_valid_handle
15
+
normalize_handle
16
+
service_did
17
+
service_did_doc
18
+
service_host
19
+
);
20
+
21
+
sub service_host ($config_or_url) {
22
+
my $config = _coerce_config($config_or_url);
23
+
my $url = Mojo::URL->new($config->{base_url} // 'http://127.0.0.1:7755');
24
+
my $host = lc($url->host // 'localhost');
25
+
my $scheme = $url->scheme // 'http';
26
+
my $port = $url->port;
27
+
my $default = $scheme eq 'https' ? 443 : 80;
28
+
$host .= ':' . $port if defined $port && $port != $default;
29
+
return $host;
30
+
}
31
+
32
+
sub service_did ($config_or_url) {
33
+
my $config = _coerce_config($config_or_url);
34
+
my $method = $config->{service_did_method} // 'did:web';
35
+
die "unsupported service DID method: $method" unless $method eq 'did:web';
36
+
37
+
my $host = service_host($config);
38
+
$host =~ s/:/%3A/g;
39
+
return "did:web:$host";
40
+
}
41
+
42
+
sub account_did ($config_or_url, $account_id) {
43
+
die 'account id is required' unless defined $account_id && length $account_id;
44
+
my $did = service_did($config_or_url);
45
+
return "$did:users:$account_id";
46
+
}
47
+
48
+
sub did_to_path ($did) {
49
+
die 'did is required' unless defined $did && length $did;
50
+
die "unsupported DID: $did" unless $did =~ s/\Adid:web://;
51
+
52
+
my @parts = split /:/, $did;
53
+
shift @parts;
54
+
return '/.well-known/did.json' unless @parts;
55
+
return '/' . join('/', map { s/%3A/:/gr } @parts) . '/did.json';
56
+
}
57
+
58
+
sub service_did_doc ($config_or_url) {
59
+
my $config = _coerce_config($config_or_url);
60
+
my $did = service_did($config);
61
+
my $base_url = $config->{base_url} // 'http://127.0.0.1:7755';
62
+
63
+
return {
64
+
'@context' => ['https://www.w3.org/ns/did/v1'],
65
+
id => $did,
66
+
service => [{
67
+
id => "$did#atproto_pds",
68
+
type => 'AtprotoPersonalDataServer',
69
+
serviceEndpoint => $base_url,
70
+
}],
71
+
};
72
+
}
73
+
74
+
sub is_valid_handle ($handle, $allowed_domain = undef) {
75
+
return 0 unless defined $handle && length $handle;
76
+
$handle = normalize_handle($handle, $allowed_domain, { no_append => 1 });
77
+
return defined $handle ? 1 : 0;
78
+
}
79
+
80
+
sub normalize_handle ($handle, $allowed_domain = undef, $opts = {}) {
81
+
return undef unless defined $handle && length $handle;
82
+
83
+
$handle =~ s/\A@+//;
84
+
$handle = lc $handle;
85
+
$handle .= ".$allowed_domain"
86
+
if defined $allowed_domain && !$opts->{no_append} && $handle !~ /\./;
87
+
88
+
return undef if $handle =~ /\A\.|\.\z/;
89
+
return undef if $handle =~ /\.\./;
90
+
return undef unless $handle =~ /\A[a-z0-9](?:[a-z0-9-]*[a-z0-9])?(?:\.[a-z0-9](?:[a-z0-9-]*[a-z0-9])?)+\z/;
91
+
92
+
if (defined $allowed_domain) {
93
+
my $suffix = lc $allowed_domain;
94
+
return undef unless $handle eq $suffix || $handle =~ /\.\Q$suffix\E\z/;
95
+
}
96
+
97
+
return $handle;
98
+
}
99
+
100
+
sub _coerce_config ($config_or_url) {
101
+
return $config_or_url if ref($config_or_url) eq 'HASH';
102
+
return {
103
+
base_url => $config_or_url,
104
+
service_did_method => 'did:web',
105
+
};
106
+
}
107
+
108
+
1;
+2
-1
lib/ATProto/PDS/LexiconRegistry.pm
+2
-1
lib/ATProto/PDS/LexiconRegistry.pm
···
35
35
}
36
36
37
37
sub _load_lexicons ($self) {
38
-
my $root = path($self->root);
38
+
my $candidate = File::Spec->catdir($self->root, 'share', 'lexicons');
39
+
my $root = path(-d $candidate ? $candidate : $self->root);
39
40
return unless -d $root;
40
41
41
42
for my $file ($root->list_tree->grep(qr/\.json$/)->each) {
+18
-3
lib/ATProto/PDS/XRPC/Dispatcher.pm
+18
-3
lib/ATProto/PDS/XRPC/Dispatcher.pm
···
18
18
return $handler->($c, $endpoint) if $handler;
19
19
20
20
$c->send({ json => {
21
-
error => 'NotYetImplemented',
21
+
error => 'NotImplemented',
22
22
message => "No subscription handler registered for $endpoint->{id}",
23
23
nsid => $endpoint->{id},
24
24
}});
···
33
33
34
34
$route->to(cb => sub ($c) {
35
35
my $handler = $c->app->api_registry->handler_for($endpoint->{id});
36
-
return $handler->($c, $endpoint) if $handler;
36
+
if ($handler) {
37
+
my $result = eval { $handler->($c, $endpoint) };
38
+
if (my $err = $@) {
39
+
if (ref($err) eq 'HASH' && $err->{error}) {
40
+
return $c->render(
41
+
status => $err->{status} // 400,
42
+
json => {
43
+
error => $err->{error},
44
+
message => $err->{message} // $err->{error},
45
+
},
46
+
);
47
+
}
48
+
die $err;
49
+
}
50
+
return $c->render(json => $result);
51
+
}
37
52
38
53
$c->render(
39
54
status => 501,
40
55
json => {
41
-
error => 'NotYetImplemented',
56
+
error => 'NotImplemented',
42
57
message => "No handler registered for $endpoint->{id}",
43
58
nsid => $endpoint->{id},
44
59
type => $endpoint->{type},
+1
-1
t/app-routes.t
+1
-1
t/app-routes.t
···
41
41
42
42
$t->post_ok('/xrpc/com.atproto.repo.createRecord' => json => {})
43
43
->status_is(501)
44
-
->json_is('/error' => 'NotYetImplemented')
44
+
->json_is('/error' => 'NotImplemented')
45
45
->json_is('/nsid' => 'com.atproto.repo.createRecord');
46
46
47
47
$t->websocket_ok('/xrpc/com.atproto.sync.subscribeRepos')
+55
t/app.t
+55
t/app.t
···
1
+
use v5.34;
2
+
use warnings;
3
+
4
+
use Config ();
5
+
use FindBin qw($Bin);
6
+
use File::Spec;
7
+
use Test2::V0;
8
+
9
+
BEGIN {
10
+
require lib;
11
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
12
+
lib->import(
13
+
File::Spec->catdir($root, 'lib'),
14
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
15
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
16
+
);
17
+
}
18
+
19
+
use Test::Mojo;
20
+
use ATProto::PDS;
21
+
22
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
23
+
my $config = File::Spec->catfile($root, 'etc', 'perlds.example.json');
24
+
my $t = Test::Mojo->new(ATProto::PDS->new(
25
+
project_root => $root,
26
+
settings => {
27
+
base_url => 'http://127.0.0.1:7755',
28
+
service_did_method => 'did:web',
29
+
service_handle_domain => 'localhost',
30
+
jwt_secret => 'test-secret',
31
+
},
32
+
));
33
+
34
+
$t->get_ok('/_health')
35
+
->status_is(200)
36
+
->json_has('/ok');
37
+
38
+
$t->get_ok('/xrpc/com.atproto.server.describeServer')
39
+
->status_is(200)
40
+
->json_is('/did' => 'did:web:127.0.0.1%3A7755')
41
+
->json_is('/availableUserDomains/0' => 'localhost');
42
+
43
+
$t->get_ok('/xrpc/com.atproto.identity.resolveHandle?handle=localhost')
44
+
->status_is(200)
45
+
->json_is('/did' => 'did:web:127.0.0.1%3A7755');
46
+
47
+
$t->get_ok('/xrpc/com.atproto.identity.resolveDid?did=did:web:127.0.0.1%3A7755')
48
+
->status_is(200)
49
+
->json_is('/didDoc/id' => 'did:web:127.0.0.1%3A7755');
50
+
51
+
$t->post_ok('/xrpc/com.atproto.server.createSession' => json => { identifier => 'alice', password => 'pw' })
52
+
->status_is(501)
53
+
->json_is('/error' => 'NotImplemented');
54
+
55
+
done_testing;
+48
t/auth-jwt.t
+48
t/auth-jwt.t
···
1
+
use v5.34;
2
+
use warnings;
3
+
4
+
use Config ();
5
+
use File::Spec;
6
+
use FindBin qw($Bin);
7
+
use Test2::V0;
8
+
9
+
BEGIN {
10
+
require lib;
11
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
12
+
lib->import(
13
+
File::Spec->catdir($root, 'lib'),
14
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
15
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
16
+
);
17
+
}
18
+
19
+
use ATProto::PDS::Auth::JWT qw(decode_jwt encode_jwt);
20
+
21
+
my $token = encode_jwt(
22
+
{
23
+
sub => 'did:web:example.com:users:alice',
24
+
aud => 'perlds',
25
+
exp => 1_900_000_000,
26
+
},
27
+
'super-secret',
28
+
);
29
+
30
+
my $decoded = decode_jwt($token, 'super-secret', audience => 'perlds', now => 1_800_000_000);
31
+
32
+
is($decoded->{claims}{sub}, 'did:web:example.com:users:alice', 'subject round-trips');
33
+
is($decoded->{header}{alg}, 'HS256', 'algorithm preserved');
34
+
35
+
like(
36
+
dies { decode_jwt($token, 'wrong-secret', now => 1_800_000_000) },
37
+
qr/invalid signature/,
38
+
'signature mismatches are rejected',
39
+
);
40
+
41
+
my $expired = encode_jwt({ exp => 10 }, 'super-secret');
42
+
like(
43
+
dies { decode_jwt($expired, 'super-secret', now => 10) },
44
+
qr/token expired/,
45
+
'expiration is enforced',
46
+
);
47
+
48
+
done_testing;
+38
t/identity.t
+38
t/identity.t
···
1
+
use v5.34;
2
+
use warnings;
3
+
4
+
use Config ();
5
+
use File::Spec;
6
+
use FindBin qw($Bin);
7
+
use Test2::V0;
8
+
9
+
BEGIN {
10
+
require lib;
11
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
12
+
lib->import(
13
+
File::Spec->catdir($root, 'lib'),
14
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
15
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
16
+
);
17
+
}
18
+
19
+
use ATProto::PDS::Identity qw(
20
+
account_did
21
+
did_to_path
22
+
is_valid_handle
23
+
normalize_handle
24
+
service_did
25
+
service_host
26
+
);
27
+
28
+
is(service_host('http://127.0.0.1:7755'), '127.0.0.1:7755', 'non-default ports are preserved');
29
+
is(service_did('http://127.0.0.1:7755'), 'did:web:127.0.0.1%3A7755', 'service did encodes the port');
30
+
is(account_did('https://pds.example.com', 'alice01'), 'did:web:pds.example.com:users:alice01', 'account did nests under service did');
31
+
is(did_to_path('did:web:pds.example.com:users:alice01'), '/users/alice01/did.json', 'account did maps back to a did.json path');
32
+
33
+
ok(is_valid_handle('alice.example.com'), 'handles validate');
34
+
ok(!is_valid_handle('alice', 'example.com'), 'bare handles do not validate');
35
+
ok(is_valid_handle('alice.example.com', 'example.com'), 'allowed domains are enforced');
36
+
is(normalize_handle('@Alice', 'example.com'), 'alice.example.com', 'handles are normalized');
37
+
38
+
done_testing;
+46
t/ipld-canonical.t
+46
t/ipld-canonical.t
···
1
+
use v5.34;
2
+
use warnings;
3
+
4
+
use Config ();
5
+
use FindBin qw($Bin);
6
+
use File::Spec;
7
+
use Test2::V0;
8
+
9
+
BEGIN {
10
+
require lib;
11
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
12
+
lib->import(
13
+
File::Spec->catdir($root, 'lib'),
14
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
15
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
16
+
);
17
+
}
18
+
19
+
use ATProto::PDS::IPLD::CID qw(CODEC_RAW);
20
+
use ATProto::PDS::IPLD::DAGCBOR qw(encode_dag_cbor decode_dag_cbor);
21
+
22
+
my $cid = ATProto::PDS::IPLD::CID->from_data(CODEC_RAW, 'abc');
23
+
24
+
my $encoded = encode_dag_cbor({
25
+
aa => 2,
26
+
b => 1,
27
+
link => $cid,
28
+
});
29
+
30
+
my $expected_hex = join '', (
31
+
'a3',
32
+
'61', '62', '01',
33
+
'62', '6161', '02',
34
+
'64', '6c696e6b',
35
+
'd82a',
36
+
'58', '25',
37
+
'00',
38
+
unpack('H*', $cid->to_bytes),
39
+
);
40
+
41
+
is(unpack('H*', $encoded), $expected_hex, 'maps are encoded in canonical order and CID uses tag 42');
42
+
43
+
my $decoded = decode_dag_cbor($encoded);
44
+
ok($decoded->{link}->equals($cid), 'CID link decodes back to CID object');
45
+
46
+
done_testing;
+65
t/ipld-codecs.t
+65
t/ipld-codecs.t
···
1
+
use v5.34;
2
+
use warnings;
3
+
4
+
use Config ();
5
+
use FindBin qw($Bin);
6
+
use File::Spec;
7
+
use Test2::V0;
8
+
9
+
BEGIN {
10
+
require lib;
11
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
12
+
lib->import(
13
+
File::Spec->catdir($root, 'lib'),
14
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
15
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
16
+
);
17
+
}
18
+
19
+
use ATProto::PDS::IPLD::Base32 qw(encode_base32 decode_base32);
20
+
use ATProto::PDS::IPLD::Base58 qw(encode_base58btc decode_base58btc);
21
+
use ATProto::PDS::IPLD::Base64 qw(encode_base64url decode_base64url);
22
+
use ATProto::PDS::IPLD::CID qw(CODEC_DAG_CBOR CODEC_RAW);
23
+
use ATProto::PDS::IPLD::DAGCBOR qw(encode_dag_cbor decode_dag_cbor cid_for_dag_cbor);
24
+
use ATProto::PDS::IPLD::Bytes;
25
+
use JSON::PP ();
26
+
27
+
my $sample = "hello world\x00\xff";
28
+
29
+
is(decode_base32(encode_base32($sample)), $sample, 'base32 round-trips bytes');
30
+
is(decode_base58btc(encode_base58btc($sample)), $sample, 'base58btc round-trips bytes');
31
+
is(decode_base64url(encode_base64url($sample)), $sample, 'base64url round-trips bytes');
32
+
33
+
my $raw_cid = ATProto::PDS::IPLD::CID->from_data(CODEC_RAW, $sample);
34
+
is("$raw_cid", $raw_cid->to_string, 'CID stringification uses multibase form');
35
+
ok($raw_cid->equals(ATProto::PDS::IPLD::CID->parse($raw_cid->to_string)), 'CID base32 parse round-trips');
36
+
ok($raw_cid->equals(ATProto::PDS::IPLD::CID->from_bytes($raw_cid->to_bytes)), 'CID byte parse round-trips');
37
+
ok($raw_cid->equals(ATProto::PDS::IPLD::CID->parse($raw_cid->to_string('base58btc'))), 'CID base58btc parse round-trips');
38
+
39
+
my $value = {
40
+
zed => 7,
41
+
alpha => [JSON::PP::true, JSON::PP::false, undef],
42
+
blob => ATProto::PDS::IPLD::Bytes->new("\x01\x02\x03"),
43
+
link => $raw_cid,
44
+
text => 'jalapeno',
45
+
};
46
+
47
+
my $encoded = encode_dag_cbor($value);
48
+
my $decoded = decode_dag_cbor($encoded);
49
+
50
+
is($decoded->{zed}, 7, 'decoded integer preserved');
51
+
ok($decoded->{alpha}[0], 'decoded boolean true preserved');
52
+
ok(!$decoded->{alpha}[1], 'decoded boolean false preserved');
53
+
is($decoded->{alpha}[2], undef, 'decoded null preserved');
54
+
is($decoded->{blob}->bytes, "\x01\x02\x03", 'decoded bytes preserved');
55
+
ok($decoded->{link}->equals($raw_cid), 'decoded CID preserved');
56
+
is($decoded->{text}, 'jalapeno', 'decoded text preserved');
57
+
58
+
my $dag_cid = cid_for_dag_cbor({ hello => 'world' });
59
+
is($dag_cid->codec, CODEC_DAG_CBOR, 'DAG-CBOR CID uses dag-cbor codec');
60
+
ok($dag_cid->equals(ATProto::PDS::IPLD::CID->from_data(CODEC_DAG_CBOR, encode_dag_cbor({ hello => 'world' }))), 'CID matches encoded bytes');
61
+
62
+
like(dies { decode_dag_cbor("\x9f\x01\x02\xff") }, qr/indefinite-length/, 'rejects indefinite-length CBOR');
63
+
like(dies { decode_dag_cbor("\xfb\x7f\xf8\x00\x00\x00\x00\x00\x00") }, qr/floating point/, 'rejects floats');
64
+
65
+
done_testing;