perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
Add lexicon-driven Mojolicious app skeleton
+309
+52
lib/ATProto/PDS.pm
+52
lib/ATProto/PDS.pm
···
1
+
package ATProto::PDS;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
6
+
use Mojo::Base 'Mojolicious', -signatures;
7
+
use Mojo::JSON ();
8
+
use ATProto::PDS::API::Registry;
9
+
use ATProto::PDS::LexiconCatalog qw(endpoint_catalog);
10
+
11
+
has project_root => '';
12
+
has settings => sub { {} };
13
+
14
+
sub startup ($self) {
15
+
my $config = $self->settings;
16
+
my $root = $self->project_root;
17
+
18
+
$self->secrets([$config->{jwt_secret} // 'perlds-dev-secret']);
19
+
$self->helper(api_registry => sub { state $registry = ATProto::PDS::API::Registry->new });
20
+
$self->helper(config_value => sub ($c, $key, $default = undef) { $c->app->settings->{$key} // $default });
21
+
22
+
my $routes = $self->routes;
23
+
$routes->get('/_health')->to(cb => sub ($c) {
24
+
$c->render(json => {
25
+
ok => Mojo::JSON->true,
26
+
service => 'perlds',
27
+
endpoints => scalar @{ endpoint_catalog($root) },
28
+
});
29
+
});
30
+
31
+
for my $endpoint (@{ endpoint_catalog($root) }) {
32
+
my $route = $endpoint->{type} eq 'query'
33
+
? $routes->get($endpoint->{path})
34
+
: $routes->post($endpoint->{path});
35
+
36
+
$route->to(cb => sub ($c) {
37
+
my $handler = $c->app->api_registry->handler_for($endpoint->{id});
38
+
return $handler->($c, $endpoint) if $handler;
39
+
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
+
);
48
+
});
49
+
}
50
+
}
51
+
52
+
1;
+24
lib/ATProto/PDS/API/Registry.pm
+24
lib/ATProto/PDS/API/Registry.pm
···
1
+
package ATProto::PDS::API::Registry;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
6
+
sub new {
7
+
my ($class, %args) = @_;
8
+
return bless {
9
+
handlers => $args{handlers} || {},
10
+
}, $class;
11
+
}
12
+
13
+
sub register {
14
+
my ($self, $nsid, $code) = @_;
15
+
$self->{handlers}{$nsid} = $code;
16
+
return $self;
17
+
}
18
+
19
+
sub handler_for {
20
+
my ($self, $nsid) = @_;
21
+
return $self->{handlers}{$nsid};
22
+
}
23
+
24
+
1;
+33
lib/ATProto/PDS/Bootstrap.pm
+33
lib/ATProto/PDS/Bootstrap.pm
···
1
+
package ATProto::PDS::Bootstrap;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
6
+
use Exporter 'import';
7
+
use Config ();
8
+
use FindBin ();
9
+
use File::Spec;
10
+
use lib ();
11
+
12
+
our @EXPORT_OK = qw(apply_local_lib project_root);
13
+
14
+
sub project_root {
15
+
state $root = do {
16
+
my $bin = $FindBin::RealBin || '.';
17
+
File::Spec->rel2abs(File::Spec->catdir($bin, '..'));
18
+
};
19
+
}
20
+
21
+
sub apply_local_lib {
22
+
my $root = project_root();
23
+
my @paths = (
24
+
File::Spec->catdir($root, 'lib'),
25
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
26
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
27
+
);
28
+
29
+
lib->import(@paths);
30
+
return \@paths;
31
+
}
32
+
33
+
1;
+33
lib/ATProto/PDS/Config.pm
+33
lib/ATProto/PDS/Config.pm
···
1
+
package ATProto::PDS::Config;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
6
+
use Exporter 'import';
7
+
use File::Basename qw(dirname);
8
+
use File::Path qw(make_path);
9
+
use File::Spec;
10
+
use JSON::PP qw(decode_json);
11
+
12
+
our @EXPORT_OK = qw(load_config);
13
+
14
+
sub load_config {
15
+
my ($path) = @_;
16
+
open(my $fh, '<', $path) or die "open($path): $!";
17
+
local $/;
18
+
my $config = decode_json(<$fh>);
19
+
close($fh);
20
+
21
+
my $root = dirname(File::Spec->rel2abs($path));
22
+
for my $key (qw(data_dir db_path)) {
23
+
next unless defined $config->{$key};
24
+
next if File::Spec->file_name_is_absolute($config->{$key});
25
+
$config->{$key} = File::Spec->rel2abs($config->{$key}, $root);
26
+
}
27
+
28
+
make_path($config->{data_dir}) if $config->{data_dir};
29
+
30
+
return $config;
31
+
}
32
+
33
+
1;
+54
lib/ATProto/PDS/LexiconCatalog.pm
+54
lib/ATProto/PDS/LexiconCatalog.pm
···
1
+
package ATProto::PDS::LexiconCatalog;
2
+
3
+
use v5.34;
4
+
use warnings;
5
+
6
+
use Exporter 'import';
7
+
use File::Spec;
8
+
use JSON::PP qw(decode_json);
9
+
10
+
our @EXPORT_OK = qw(load_catalog endpoint_catalog);
11
+
12
+
sub load_catalog {
13
+
my ($root) = @_;
14
+
my $base = File::Spec->catdir($root, 'share', 'lexicons', 'com', 'atproto');
15
+
my @namespaces = qw(server identity repo sync admin moderation label lexicon temp);
16
+
my @catalog;
17
+
18
+
for my $namespace (@namespaces) {
19
+
my $dir = File::Spec->catdir($base, $namespace);
20
+
next unless -d $dir;
21
+
22
+
opendir(my $dh, $dir) or die "opendir($dir): $!";
23
+
for my $entry (sort grep { /\.json\z/ } readdir($dh)) {
24
+
my $path = File::Spec->catfile($dir, $entry);
25
+
open(my $fh, '<', $path) or die "open($path): $!";
26
+
local $/;
27
+
my $json = decode_json(<$fh>);
28
+
close($fh);
29
+
30
+
my $main = $json->{defs}{main};
31
+
next unless ref($main) eq 'HASH';
32
+
next unless ($main->{type} // '') =~ /\A(?:query|procedure|subscription)\z/;
33
+
34
+
push @catalog, {
35
+
id => $json->{id},
36
+
namespace => $namespace,
37
+
type => $main->{type},
38
+
path => "/xrpc/$json->{id}",
39
+
lexicon => $path,
40
+
};
41
+
}
42
+
closedir($dh);
43
+
}
44
+
45
+
return \@catalog;
46
+
}
47
+
48
+
sub endpoint_catalog {
49
+
my ($root) = @_;
50
+
state %cache;
51
+
return $cache{$root} ||= load_catalog($root);
52
+
}
53
+
54
+
1;
+48
lib/ATProto/PDS/LexiconRegistry.pm
+48
lib/ATProto/PDS/LexiconRegistry.pm
···
1
+
package ATProto::PDS::LexiconRegistry;
2
+
3
+
use strict;
4
+
use warnings;
5
+
6
+
use Mojo::Base -base, -signatures;
7
+
use JSON::PP qw(decode_json);
8
+
use File::Basename qw(dirname);
9
+
use File::Spec;
10
+
use Mojo::File qw(path);
11
+
12
+
has root => sub {
13
+
my $base = dirname(__FILE__);
14
+
return File::Spec->catdir($base, '..', '..', '..', 'share', 'lexicons');
15
+
};
16
+
17
+
has lexicons => sub { {} };
18
+
19
+
sub new ($class, @args) {
20
+
my $self = $class->SUPER::new(@args);
21
+
$self->_load_lexicons;
22
+
return $self;
23
+
}
24
+
25
+
sub ids ($self) {
26
+
return [ sort keys %{ $self->lexicons } ];
27
+
}
28
+
29
+
sub count ($self) {
30
+
return scalar keys %{ $self->lexicons };
31
+
}
32
+
33
+
sub get ($self, $id) {
34
+
return $self->lexicons->{$id};
35
+
}
36
+
37
+
sub _load_lexicons ($self) {
38
+
my $root = path($self->root);
39
+
return unless -d $root;
40
+
41
+
for my $file ($root->list_tree->grep(qr/\.json$/)->each) {
42
+
my $json = decode_json($file->slurp);
43
+
next unless ref($json) eq 'HASH' && $json->{id};
44
+
$self->lexicons->{ $json->{id} } = $json;
45
+
}
46
+
}
47
+
48
+
1;
+32
script/perlds
+32
script/perlds
···
1
+
#!/usr/bin/env perl
2
+
use v5.34;
3
+
use warnings;
4
+
5
+
use Config ();
6
+
use FindBin ();
7
+
use File::Spec;
8
+
9
+
BEGIN {
10
+
require File::Spec;
11
+
require lib;
12
+
my $root = File::Spec->rel2abs(File::Spec->catdir($FindBin::RealBin, '..'));
13
+
lib->import(
14
+
File::Spec->catdir($root, 'lib'),
15
+
File::Spec->catdir($root, 'local', 'lib', 'perl5'),
16
+
File::Spec->catdir($root, 'local', 'lib', 'perl5', $Config::Config{archname}),
17
+
);
18
+
}
19
+
20
+
use ATProto::PDS;
21
+
use ATProto::PDS::Config qw(load_config);
22
+
23
+
my $root = File::Spec->rel2abs(File::Spec->catdir($FindBin::RealBin, '..'));
24
+
my $config_path = $ENV{PERLDS_CONFIG} || File::Spec->catfile($root, 'etc', 'perlds.example.json');
25
+
my $config = load_config($config_path);
26
+
27
+
my $app = ATProto::PDS->new(
28
+
project_root => $root,
29
+
settings => $config,
30
+
);
31
+
32
+
$app->start(@ARGV);
+33
t/catalog.t
+33
t/catalog.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::LexiconCatalog qw(endpoint_catalog);
20
+
21
+
my $root = File::Spec->rel2abs(File::Spec->catdir($Bin, '..'));
22
+
my $catalog = endpoint_catalog($root);
23
+
24
+
ok(@$catalog >= 70, 'loaded the upstream endpoint inventory');
25
+
26
+
my %by_id = map { $_->{id} => $_ } @$catalog;
27
+
28
+
ok($by_id{'com.atproto.server.createAccount'}, 'createAccount exists');
29
+
ok($by_id{'com.atproto.repo.applyWrites'}, 'applyWrites exists');
30
+
ok($by_id{'com.atproto.sync.subscribeRepos'}, 'subscribeRepos exists');
31
+
is($by_id{'com.atproto.sync.subscribeRepos'}{type}, 'subscription', 'subscription type preserved');
32
+
33
+
done_testing;