perlsky is a Perl 5 implementation of an AT Protocol Personal Data Server.
13
fork

Configure Feed

Select the types of activity you want to include in your feed.

Add lexicon-driven Mojolicious app skeleton

alice 797a15cd 3700962e

+309
+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
··· 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
··· 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
··· 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
··· 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
··· 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
··· 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
··· 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;