perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Build Mojolicious app shell from vendored lexicons
+170
-30
+8
-1
.gitignore
+8
-1
.gitignore
···
1
1
.build/
2
2
.cpanm/
3
3
.local/
4
-
.tools/
5
4
.prove
6
5
blib/
7
6
cover_db/
7
+
data/
8
8
data/runtime/
9
9
local/
10
10
nytprof.out
11
11
pm_to_blib
12
+
Makefile
13
+
MYMETA.json
14
+
MYMETA.yml
12
15
*.sqlite
13
16
*.sqlite-shm
14
17
*.sqlite-wal
18
+
*.db
19
+
*.db-shm
20
+
*.db-wal
15
21
*.tar.gz
16
22
*.tmp
17
23
*.swp
18
24
.DS_Store
25
+
.tools/
19
26
.vendor/
+21
Makefile.PL
+21
Makefile.PL
···
1
+
use strict;
2
+
use warnings;
3
+
4
+
use ExtUtils::MakeMaker;
5
+
6
+
WriteMakefile(
7
+
NAME => 'ATProto::PDS',
8
+
VERSION_FROM => 'lib/ATProto/PDS.pm',
9
+
ABSTRACT => 'Perl 5 implementation of an AT Protocol PDS',
10
+
AUTHOR => 'aliceisjustplaying',
11
+
EXE_FILES => ['script/perlds'],
12
+
PREREQ_PM => {
13
+
'CBOR::XS' => '1.87',
14
+
'Crypt::PK::Ed25519' => '0',
15
+
'DBD::SQLite' => '1.64',
16
+
'DBI' => '1.643',
17
+
'Mojolicious' => '9.42',
18
+
'Test::Deep' => '1.204',
19
+
'Test2::V0' => '0.000162',
20
+
},
21
+
);
+7
-11
README.md
+7
-11
README.md
···
1
1
# perlds
2
2
3
-
`perlds` is a Perl 5 Personal Data Server for the AT Protocol / Bluesky ecosystem.
3
+
`perlds` is a Perl 5 implementation of an AT Protocol Personal Data Server.
4
4
5
-
The project goal is to expose the current external `com.atproto.*` PDS-facing XRPC
6
-
surface from the official lexicons, with a local SQLite-backed implementation for:
5
+
Current direction:
7
6
8
-
- account and session management
9
-
- DID/handle identity resolution
10
-
- record and blob storage
11
-
- DAG-CBOR block storage
12
-
- Merkle Search Tree repository state
13
-
- CAR export/import and sync endpoints
7
+
- Official `com.atproto.*` lexicons are vendored into `share/lexicons`.
8
+
- The external XRPC surface is loaded from those lexicons at runtime.
9
+
- Account, repo, blob, sync, CAR, DAG-CBOR, CID, and MST support are being implemented in native Perl.
10
+
- The app is designed to run self-contained with SQLite and filesystem blob storage.
14
11
15
-
The codebase intentionally keeps protocol metadata close to the source by deriving
16
-
its route inventory from the upstream lexicons vendored during development.
12
+
The immediate goal is a PDS that is pleasant to hack on and interoperable enough to be exercised with real AT Protocol clients and repo sync tooling.
+4
-2
cpanfile
+4
-2
cpanfile
···
1
-
requires 'Mojolicious', '9.39';
2
-
requires 'CBOR::XS', '1.86';
1
+
requires 'CBOR::XS', '1.87';
3
2
requires 'CryptX', '0.087';
3
+
requires 'DBD::SQLite', '1.64';
4
+
requires 'DBI', '1.643';
5
+
requires 'Mojolicious', '9.42';
4
6
requires 'Test::Deep', '1.204';
5
7
6
8
on 'test' => sub {
+29
-16
lib/ATProto/PDS.pm
+29
-16
lib/ATProto/PDS.pm
···
7
7
use Mojo::JSON ();
8
8
use ATProto::PDS::API::Registry;
9
9
use ATProto::PDS::LexiconCatalog qw(endpoint_catalog);
10
+
use ATProto::PDS::XRPC::Dispatcher;
10
11
11
12
has project_root => '';
12
13
has settings => sub { {} };
···
17
18
18
19
$self->secrets([$config->{jwt_secret} // 'perlds-dev-secret']);
19
20
$self->helper(api_registry => sub { state $registry = ATProto::PDS::API::Registry->new });
21
+
$self->helper(endpoint_catalog => sub ($c) { endpoint_catalog($root) });
20
22
$self->helper(config_value => sub ($c, $key, $default = undef) { $c->app->settings->{$key} // $default });
21
23
22
24
my $routes = $self->routes;
25
+
$routes->get('/')->to(cb => sub ($c) {
26
+
$c->render(json => {
27
+
service => 'perlds',
28
+
status => 'booting',
29
+
endpoints => scalar @{ $c->endpoint_catalog },
30
+
});
31
+
});
32
+
23
33
$routes->get('/_health')->to(cb => sub ($c) {
24
34
$c->render(json => {
25
35
ok => Mojo::JSON->true,
···
28
38
});
29
39
});
30
40
31
-
for my $endpoint (@{ endpoint_catalog($root) }) {
32
-
my $route = $endpoint->{type} eq 'query'
33
-
? $routes->get($endpoint->{path})
34
-
: $routes->post($endpoint->{path});
41
+
$self->_register_builtin_handlers;
42
+
ATProto::PDS::XRPC::Dispatcher->new(
43
+
app => $self,
44
+
routes => $routes,
45
+
catalog => endpoint_catalog($root),
46
+
)->register_routes;
47
+
}
35
48
36
-
$route->to(cb => sub ($c) {
37
-
my $handler = $c->app->api_registry->handler_for($endpoint->{id});
38
-
return $handler->($c, $endpoint) if $handler;
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}{};
39
55
40
-
$c->render(
41
-
status => 501,
42
-
json => {
43
-
error => 'NotYetImplemented',
44
-
message => "No handler registered for $endpoint->{id}",
45
-
nsid => $endpoint->{id},
46
-
},
47
-
);
56
+
$c->render(json => {
57
+
inviteCodeRequired => Mojo::JSON->false,
58
+
phoneVerificationRequired => Mojo::JSON->false,
59
+
availableUserDomains => [$domain],
60
+
did => "did:web:$host",
48
61
});
49
-
}
62
+
});
50
63
}
51
64
52
65
1;
+51
lib/ATProto/PDS/XRPC/Dispatcher.pm
+51
lib/ATProto/PDS/XRPC/Dispatcher.pm
···
1
+
package ATProto::PDS::XRPC::Dispatcher;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
6
+
use Mojo::Base -base, -signatures;
7
+
use Mojo::JSON ();
8
+
9
+
has app => undef;
10
+
has routes => undef;
11
+
has catalog => sub { [] };
12
+
13
+
sub register_routes ($self) {
14
+
for my $endpoint (@{ $self->catalog }) {
15
+
if ($endpoint->{type} eq 'subscription') {
16
+
$self->routes->websocket($endpoint->{path})->to(cb => sub ($c) {
17
+
my $handler = $c->app->api_registry->handler_for($endpoint->{id});
18
+
return $handler->($c, $endpoint) if $handler;
19
+
20
+
$c->send({ json => {
21
+
error => 'NotYetImplemented',
22
+
message => "No subscription handler registered for $endpoint->{id}",
23
+
nsid => $endpoint->{id},
24
+
}});
25
+
$c->finish(1000);
26
+
});
27
+
next;
28
+
}
29
+
30
+
my $route = $endpoint->{type} eq 'query'
31
+
? $self->routes->get($endpoint->{path})
32
+
: $self->routes->post($endpoint->{path});
33
+
34
+
$route->to(cb => sub ($c) {
35
+
my $handler = $c->app->api_registry->handler_for($endpoint->{id});
36
+
return $handler->($c, $endpoint) if $handler;
37
+
38
+
$c->render(
39
+
status => 501,
40
+
json => {
41
+
error => 'NotYetImplemented',
42
+
message => "No handler registered for $endpoint->{id}",
43
+
nsid => $endpoint->{id},
44
+
type => $endpoint->{type},
45
+
},
46
+
);
47
+
});
48
+
}
49
+
}
50
+
51
+
1;
+50
t/app-routes.t
+50
t/app-routes.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 Test::Mojo;
20
+
use ATProto::PDS;
21
+
use ATProto::PDS::Config qw(load_config);
22
+
23
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
24
+
my $config = load_config(File::Spec->catfile($root, 'etc', 'perlds.example.json'));
25
+
my $t = Test::Mojo->new(
26
+
ATProto::PDS->new(
27
+
project_root => $root,
28
+
settings => $config,
29
+
),
30
+
);
31
+
32
+
$t->get_ok('/_health')
33
+
->status_is(200)
34
+
->json_is('/service' => 'perlds')
35
+
->json_has('/ok');
36
+
37
+
$t->get_ok('/xrpc/com.atproto.server.describeServer')
38
+
->status_is(200)
39
+
->json_is('/availableUserDomains/0' => 'localhost')
40
+
->json_like('/did' => qr/\Adid:web:/);
41
+
42
+
$t->post_ok('/xrpc/com.atproto.repo.createRecord' => json => {})
43
+
->status_is(501)
44
+
->json_is('/error' => 'NotYetImplemented')
45
+
->json_is('/nsid' => 'com.atproto.repo.createRecord');
46
+
47
+
$t->websocket_ok('/xrpc/com.atproto.sync.subscribeRepos')
48
+
->finish_ok;
49
+
50
+
done_testing;