Initial commit.

This commit is contained in:
sergiotarxz 2023-01-13 23:41:10 +01:00
parent fbaefaa2d5
commit 21e918182c
13 changed files with 726 additions and 0 deletions

27
Build.PL Executable file
View File

@ -0,0 +1,27 @@
#!/usr/bin/env perl
use Module::Build;
my $home = $ENV{HOME};
my $build = Module::Build->new(
module_name => 'L3TDE',
license => 'AGPLv3',
dist_author => 'Sergio Iglesias <contact@owlcode.tech>',
dist_abstract => '.',
requires => {
'DBI' => 0,
'DBD::Pg' => 0,
'DBD::Mock' => 0,
'Moo' => 0,
'Types::Standard' => 0,
'JSON' => 0,
'Path::Tiny' => 0,
'List::AllUtils' => 0,
'Test::Most' => 0,
'Test::MockModule' => 0,
'Crypt::URandom' => 0,
'Future::AsyncAwait' => 0,
'IO::Socket::SSL' => 0,
},
);
$build->create_build_script;

21
bin/l3tde.pl Normal file
View File

@ -0,0 +1,21 @@
#!/usr/bin/env perl
use v5.34.1;
use strict;
use warnings;
use L3TDE::Bot;
use Future::AsyncAwait;
L3TDE::Bot->create_bots;
for my $bot (@{L3TDE::Bot->find}) {
main($bot);
say 'AAAAAAAAAAAAAAAAAAAAAAAH';
}
async sub main {
my $bot = shift;
return $bot->start;
}

13
l3tde.json.example Normal file
View File

@ -0,0 +1,13 @@
{
"db": {
"database": "database"
},
"bots": [
{
"type": "irc",
"hostname": "example.com",
"port": 6697,
"username": "user"
}
]
}

0
lib/L3TDE.pm Normal file
View File

99
lib/L3TDE/Bot.pm Normal file
View File

@ -0,0 +1,99 @@
package L3TDE::Bot;
use v5.34.0;
use strict;
use warnings;
use Crypt::URandom qw/urandom/;
use Moo;
use Types::Standard qw/Str/;
use Future::AsyncAwait;
use L3TDE::Bot::IRC;
use L3TDE::DB;
use L3TDE::Config;
with 'L3TDE::Model';
has [qw/id data/] => (
is => 'rw',
required => 1,
);
has type => (
is => 'ro',
required => 1,
);
sub table { 'bots' }
sub defaulted_fields { [] }
sub not_defaulted_fields { [qw/id type/] }
sub jsonb_fields { [qw/data/] }
sub find_fields { [qw/id/] }
sub id_fields { [qw/id/] }
sub get_instance {
my $self = shift;
if ( uc( $self->type ) eq 'IRC' ) {
return L3TDE::Bot::IRC->new( %{ $self->data } );
}
die "@{[$self->type]} not implemented.";
}
async sub start {
my $self = shift;
my $start_result = await $self->get_instance->start;
return $start_result;
}
sub create_bots {
my $class = shift;
for my $bot ( $class->_get_from_config_bot_hashes->@* ) {
eval {
my $bot = $class->create(%$bot);
say "Created @{[$bot->id]}.";
};
if ($@) {
# Duplicate keys are expected.
if ( $@ !~ /duplicate key value/ ) {
die $@;
}
}
}
}
sub _parse_irc {
my $class = shift;
my $bot = shift;
my ( $username, $hostname, $port ) = $bot->@{qw/username hostname port/};
$username //= 'l3tde';
$port //= 6697;
return {
id => "IRC(${username}\@${hostname}/${port})",
type => 'IRC',
data => {
username => $username,
hostname => $hostname,
port => $port,
password => unpack( 'H*', urandom(60) ),
}
};
}
sub _get_from_config_bot_hashes {
my $class = shift;
my $config = L3TDE::Config->new;
my @bots;
for my $bot ( @{ $config->{bots} } ) {
if ( uc( $bot->{type} ) eq 'IRC' ) {
push @bots, $class->_parse_irc($bot);
}
else {
die "The bot type @{[$bot->{type}]} is not implemented.";
}
}
return \@bots;
}
1;

80
lib/L3TDE/Bot/IRC.pm Normal file
View File

@ -0,0 +1,80 @@
package L3TDE::Bot::IRC;
use v5.34.1;
use strict;
use warnings;
use Moo;
use Future::AsyncAwait;
use IO::Socket::SSL;
use Crypt::URandom qw/urandom/;
with 'L3TDE::Bot::Role';
has [qw/password username hostname port/] => (
is => 'rw',
required => 1,
);
has socket => (
is => 'rw',
);
# Not lazy because we may do it more than once.
async sub _generate_socket {
my $self = shift;
my $username = $self->username;
my $hostname = $self->hostname;
my $password = $self->password;
my $port = $self->port;
my $random_nick = unpack('H*', urandom(10));
my $return = IO::Socket::SSL->new(
PeerHost => $hostname,
PeerPort => $port,
Proto => 'tcp',
Timeout => 5
) or die $!;
$self->socket($return);
$self->_send_message("USER $username 0 * :L3TDE Bot\r\n");
$self->_send_message("NICK ${username}_${random_nick}\r\n");
}
sub _send_message {
my $self = shift;
my $message = shift;
my $socket = $self->socket;
print $socket "$message\r\n";
}
async sub start {
my $self = shift;
while (1) {
eval {
await $self->_generate_socket;
#while(defined(my $line = $self->_read)) {
# # print $line;
# $self->username('aaaaaaah');
#}
};
if ($@) {
warn($@);
}
}
return;
}
sub _read {
my $self = shift;
$/ = "\r\n";
my $socket = $self->socket;
my $line = <$socket>;
$/ = "\n";
return <$socket>;
}
async sub msg {
...
}
1;

12
lib/L3TDE/Bot/Role.pm Normal file
View File

@ -0,0 +1,12 @@
package L3TDE::Bot::Role;
use v5.34.1;
use strict;
use warnings;
use Moo::Role;
requires 'msg';
requires 'start';
1;

17
lib/L3TDE/Config.pm Normal file
View File

@ -0,0 +1,17 @@
package L3TDE::Config;
use v5.34.1;
use strict;
use warnings;
use JSON;
use Path::Tiny;
sub new {
my $class = shift;
bless decode_json(
path(__FILE__)->parent->parent->parent->child('l3tde.json')->slurp_utf8 ),
$class;
}
1;

91
lib/L3TDE/DB.pm Normal file
View File

@ -0,0 +1,91 @@
package L3TDE::DB;
use v5.34.1;
use strict;
use warnings;
use DBI;
use DBD::Pg;
use L3TDE::DB::Migrations;
use Data::Dumper;
my $dbh;
sub connect {
if (defined $dbh) {
return $dbh;
}
my $class = shift;
my $config = L3TDE::Config->new;
my $database = $config->{db}{database};
$dbh = DBI->connect(
"dbi:Pg:dbname=$database",
, undef, undef, { PrintError=>0, RaiseError => 1, Callbacks => {
connected => sub {
shift->do('set timezone = UTC');
return;
}
}},
);
$class->_migrate($dbh);
return $dbh;
}
sub _migrate {
my $class = shift;
my $dbh = shift;
local $dbh->{RaiseError} = 0;
local $dbh->{PrintError} = 0;
my @migrations = MyRedland::DB::Migrations::MIGRATIONS();
if ( $class->get_current_migration($dbh) > @migrations ) {
warn "Something happened there, wrong migration number.";
}
if ( $class->get_current_migration($dbh) >= @migrations ) {
say STDERR "Migrations already applied.";
return;
}
$class->_apply_migrations($dbh, \@migrations);
}
sub _apply_migrations {
my $class = shift;
my $dbh = shift;
my $migrations = shift;
for (
my $i = $class->get_current_migration($dbh);
$i < @$migrations ;
$i++
)
{
local $dbh->{RaiseError} = 1;
my $current_migration = $migrations->[$i];
my $migration_number = $i + 1;
$class->_apply_migration($dbh, $current_migration, $migration_number);
}
}
sub _apply_migration {
my $class = shift;
my $dbh = shift;
my $current_migration = shift;
my $migration_number = shift;
say $current_migration;
$dbh->do($current_migration);
$dbh->do(<<'EOF', undef, 'current_migration', $migration_number);
INSERT INTO options
VALUES ($1, $2)
ON CONFLICT (name) DO
UPDATE SET value = $2;
EOF
}
sub get_current_migration {
my $class = shift;
my $dbh = shift;
my $result = $dbh->selectrow_hashref( <<'EOF', undef, 'current_migration' );
select value from options where name = ?;
EOF
return int( $result->{value} // 0 );
}
1;

View File

@ -0,0 +1,38 @@
package MyRedland::DB::Migrations;
use v5.34.1;
use strict;
use warnings;
sub MIGRATIONS {
return (
'CREATE TABLE options (
name TEXT PRIMARY KEY,
value TEXT
)',
'CREATE EXTENSION IF NOT EXISTS "uuid-ossp"',
'CREATE TABLE bots (
-- Id is a unique identifier whose format varies from server type to server type.
id TEXT NOT NULL PRIMARY KEY,
type TEXT NOT NULL,
data jsonb DEFAULT \'{}\'::jsonb
)',
'CREATE TABLE parties (
uuid UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,
name TEXT NULL UNIQUE,
data jsonb DEFAULT \'{}\'::jsonb
)',
'CREATE TABLE players (
uuid UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,
username TEXT NOT NULL,
bot_id TEXT NOT NULL,
party_uuid UUID NULL,
data jsonb DEFAULT \'{}\'::jsonb,
FOREIGN KEY(bot_id) REFERENCES bots(id),
FOREIGN KEY(party_uuid) REFERENCES parties(uuid),
UNIQUE(username, bot_id)
)',
);
}
1;

213
lib/L3TDE/Model.pm Normal file
View File

@ -0,0 +1,213 @@
package L3TDE::Model;
use v5.34.1;
use strict;
use warnings;
use List::AllUtils qw/none any/;
use JSON;
use L3TDE::DB;
use Moo::Role;
requires 'table';
requires 'not_defaulted_fields';
requires 'defaulted_fields';
requires 'jsonb_fields';
requires 'find_fields';
requires 'id_fields';
sub _dbh {
return L3TDE::DB->connect;
}
sub create {
my $class = shift->_get_class;
my $dbh = $class->_dbh;
my %params = @_;
my $not_defaulted_fields = $class->not_defaulted_fields;
my $jsonb_fields = $class->jsonb_fields;
my $defaulted_fields = $class->defaulted_fields;
my @insert_fields = ( @$not_defaulted_fields, @$jsonb_fields );
my @fields = ( @insert_fields, @$defaulted_fields );
my $table = $class->table;
my $query = "INSERT INTO @{[$class->table]} (";
$query .= join ',', @insert_fields;
$query .= ") VALUES (";
$query .= join ',',
(
( map { '?' } @$not_defaulted_fields ),
( map { '?::jsonb' } @$jsonb_fields )
);
$query .= ") ";
$query .= $class->_generate_returning;
$query .= ';';
my $result = $dbh->selectrow_hashref(
$query,
{},
(
map {
my $param = $params{$_};
die "No $_ in @{['%params']} for $class" if !defined $param;
if ( $class->_is_jsonb($_) ) {
$param = encode_json($param);
}
$param;
} @insert_fields
)
);
if ( !defined $result ) {
die "Unable to create $class with args "
. Data::Dumper::Dumper \%params;
}
return $class->_result_to_object($result);
}
sub _generate_returning {
my $class = shift->_get_class;
my $returning = "RETURNING ";
$returning .= $class->_to_select_fields;
return $returning;
}
sub _to_select_fields {
my $class = shift->_get_class;
my $not_defaulted_fields = $class->not_defaulted_fields;
my $jsonb_fields = $class->jsonb_fields;
my $defaulted_fields = $class->defaulted_fields;
my @insert_fields = ( @$not_defaulted_fields, @$jsonb_fields );
my @fields = ( @insert_fields, @$defaulted_fields );
my $select .= join ',', @fields;
return $select;
}
sub _is_field_to_update {
my $class = shift->_get_class;
my $field = shift;
my $jsonb_fields = $class->jsonb_fields;
my $not_defaulted_fields = $class->not_defaulted_fields;
my $defaulted_fields = $class->defaulted_fields;
my @fields = ( @$not_defaulted_fields, @$defaulted_fields, @$jsonb_fields );
return any { $field eq $_ } (@fields);
}
sub update {
my $self = shift;
my $fields_to_update = shift;
my $table = $self->table;
my $dbh = $self->_dbh;
my $not_defaulted_fields = $self->not_defaulted_fields;
my $jsonb_fields = $self->jsonb_fields;
my $defaulted_fields = $self->defaulted_fields;
my $id_fields = $self->id_fields;
for my $field_to_update (@$fields_to_update) {
die "$field_to_update does not exists in @{[$self->_get_class]}"
if !$self->_is_field_to_update($field_to_update);
die "$field_to_update is not a method in @{[$self->_get_class]}"
if !$self->can($field_to_update);
}
my $query = "UPDATE $table SET ";
$query .= join ',', map {
my $key = $_;
my $return = "$key=?";
$return .= '::jsonb' if $self->_is_jsonb($key);
$return
} @$fields_to_update;
$query .= " WHERE ";
$query .= join 'AND', map { "$_=?" } @$id_fields;
$query .= " ";
$query .= $self->_generate_returning;
$query .= ";";
my $result = $dbh->selectrow_hashref( $query, {},
( map { $self->$_ } ( @$fields_to_update, @$id_fields ) ) );
return $self->_result_to_object($result);
}
sub _is_jsonb {
my $class = shift->_get_class;
my $key = shift;
my $jsonb_fields = $class->jsonb_fields;
return any { $key eq $_ } @$jsonb_fields;
}
sub _result_to_object {
my $self = shift;
my $class = $self->_get_class;
my $result = shift;
for my $key ( keys %$result ) {
$result->{$key} = decode_json $result->{$key} if $self->_is_jsonb($key);
}
return $class->new(%$result);
}
sub _get_class {
my $self = shift;
return $self if !ref $self;
return ref $self;
}
sub _validate_find_fields {
my $class = shift->_get_class;
my $fields_to_search = shift;
my $find_fields = $class->find_fields;
for my $field_to_search (@$fields_to_search) {
if ( none { return $_ eq $field_to_search } @$find_fields ) {
die
"$field_to_search is not declared in the list of searchable fields for $class.";
}
}
return 1;
}
sub _generate_select {
my $class = shift->_get_class;
my $fields_to_search = shift;
my $table = $class->table;
my $query = "SELECT @{[$class->_to_select_fields]} FROM $table";
if (@$fields_to_search) {
$query .= " WHERE ";
$query .= join 'AND', map { '$_=?' } @$fields_to_search;
}
return $query;
}
sub find_one {
my $class = shift->_get_class;
my %params = @_;
my $dbh = $class->_dbh;
my @fields_to_search = sort { $a cmp $b } keys %params;
$class->_validate_find_fields(\@fields_to_search);
my $query = $class->_generate_select( \@fields_to_search );
$query .= ' LIMIT 1;';
my $result =
$dbh->selectrow_hashref( $query, {}, @params{@fields_to_search} );
return $class->_result_to_object($result);
}
sub find {
my $class = shift->_get_class;
my %params = @_;
my $page = delete $params{page} // 0;
my $dbh = $class->_dbh;
my @fields_to_search = sort { $a cmp $b } keys %params;
$class->_validate_find_fields(\@fields_to_search);
my $query = $class->_generate_select( \@fields_to_search );
$query .= ' OFFSET ? * 10 LIMIT 10;';
my $result =
$dbh->selectall_arrayref( $query, {Slice => {}}, @params{@fields_to_search}, $page );
my @return;
for my $row (@$result) {
push @return, $class->_result_to_object($row);
}
return \@return;
}
1;

23
lib/L3TDE/Test/DB.pm Normal file
View File

@ -0,0 +1,23 @@
package L3TDE::Test::DB;
use Test::MockModule;
use DBI;
sub mock {
my $class = shift;
my $self = bless {}, $class;
my $dbh = DBI->connect('DBI:Mock:', '', '');
my $mock_module = Test::MockModule->new('L3TDE::DB');
$mock_module->mock(connect => sub {
return $dbh;
});
$self->{mock} = $mock_module;
$self->{dbh} = $dbh;
return $self;
}
sub dbh {
my $self = shift;
return $self->{dbh};
}
1;

92
t/00000001-model.t Normal file
View File

@ -0,0 +1,92 @@
#!/usr/bin/env perl
use v5.34.1;
use strict;
use warnings;
use Data::Dumper;
use Test::Most tests => 9;
use JSON;
use L3TDE::Test::DB;
BEGIN {
use_ok 'L3TDE::Model';
}
package L3TDE::Test::1::Model {
use v5.34.1;
use strict;
use warnings;
use Moo;
with 'L3TDE::Model';
sub table { 'dummy_model' }
sub not_defaulted_fields { [qw/dummy1 dummy2 dummy3/] }
sub defaulted_fields { [qw/id/] }
sub jsonb_fields { [qw/data/] }
sub find_fields { [qw/dummy2 id/] }
sub id_fields { [qw/id/] }
has [qw/dummy1 dummy2 dummy3 id data/] => (
is => 'rw'
);
}
{
my $test_db = L3TDE::Test::DB->mock;
my $dbh = $test_db->dbh;
my $result = {
id => 1,
dummy1 => 'foo',
dummy2 => 'bar',
dummy3 => 'foobar',
data => encode_json( { foobar => 'json' } ),
};
my @keys = sort { $a cmp $b } keys %$result;
$dbh->{mock_add_resultset} = [ [@keys], [ $result->@{@keys} ] ];
my $dummy = L3TDE::Test::1::Model->create(
dummy1 => 'foo',
dummy2 => 'bar',
dummy3 => 'foobar',
data => { foobar => 'json' }
);
ok $dummy->isa('L3TDE::Test::1::Model'), 'This dummy is made of dummy';
my $history = $dbh->{mock_all_history};
is scalar @$history, 1, 'A create statement executed';
my $st = $history->[0];
is $st->statement,
'INSERT INTO dummy_model (dummy1,dummy2,dummy3,data) VALUES (?,?,?,?::jsonb) RETURNING dummy1,dummy2,dummy3,data,id;',
'Expected create query matches';
is_deeply [ 'foo', 'bar', 'foobar', '{"foobar":"json"}' ],
$st->bound_params, 'Bound create params match';
}
{
my $test_db = L3TDE::Test::DB->mock;
my $dbh = $test_db->dbh;
my $result = {
id => 1,
dummy1 => 'hola',
dummy2 => 'bar',
dummy3 => 'foobar',
data => encode_json( { foobar => 'json' } ),
};
my @keys = sort { $a cmp $b } keys %$result;
$dbh->{mock_add_resultset} = [ [@keys], [ $result->@{@keys} ] ];
my $dummy = L3TDE::Test::1::Model->new(%$result);
$dummy->dummy1('hola');
$dummy = $dummy->update([qw/dummy1/]);
ok $dummy->isa('L3TDE::Test::1::Model'), 'This dummy is made of dummy';
my $history = $dbh->{mock_all_history};
is scalar @$history, 1, 'A update statement executed';
my $st = $history->[0];
is $st->statement,
'UPDATE dummy_model SET dummy1=? WHERE id=? RETURNING dummy1,dummy2,dummy3,data,id;',
'Expected update query matches';
is_deeply [ 'hola', '1' ],
$st->bound_params, 'Bound update params match';
}