diff --git a/Build.PL b/Build.PL new file mode 100755 index 0000000..dd50d56 --- /dev/null +++ b/Build.PL @@ -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 ', + 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; diff --git a/bin/l3tde.pl b/bin/l3tde.pl new file mode 100644 index 0000000..c33297a --- /dev/null +++ b/bin/l3tde.pl @@ -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; +} diff --git a/l3tde.json.example b/l3tde.json.example new file mode 100644 index 0000000..5db0553 --- /dev/null +++ b/l3tde.json.example @@ -0,0 +1,13 @@ +{ + "db": { + "database": "database" + }, + "bots": [ + { + "type": "irc", + "hostname": "example.com", + "port": 6697, + "username": "user" + } + ] +} diff --git a/lib/L3TDE.pm b/lib/L3TDE.pm new file mode 100644 index 0000000..e69de29 diff --git a/lib/L3TDE/Bot.pm b/lib/L3TDE/Bot.pm new file mode 100644 index 0000000..29bf307 --- /dev/null +++ b/lib/L3TDE/Bot.pm @@ -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; diff --git a/lib/L3TDE/Bot/IRC.pm b/lib/L3TDE/Bot/IRC.pm new file mode 100644 index 0000000..cecec80 --- /dev/null +++ b/lib/L3TDE/Bot/IRC.pm @@ -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; diff --git a/lib/L3TDE/Bot/Role.pm b/lib/L3TDE/Bot/Role.pm new file mode 100644 index 0000000..5ada6d9 --- /dev/null +++ b/lib/L3TDE/Bot/Role.pm @@ -0,0 +1,12 @@ +package L3TDE::Bot::Role; + +use v5.34.1; + +use strict; +use warnings; + +use Moo::Role; + +requires 'msg'; +requires 'start'; +1; diff --git a/lib/L3TDE/Config.pm b/lib/L3TDE/Config.pm new file mode 100644 index 0000000..cbdde9d --- /dev/null +++ b/lib/L3TDE/Config.pm @@ -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; diff --git a/lib/L3TDE/DB.pm b/lib/L3TDE/DB.pm new file mode 100644 index 0000000..9c136f6 --- /dev/null +++ b/lib/L3TDE/DB.pm @@ -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; diff --git a/lib/L3TDE/DB/Migrations.pm b/lib/L3TDE/DB/Migrations.pm new file mode 100644 index 0000000..10943b8 --- /dev/null +++ b/lib/L3TDE/DB/Migrations.pm @@ -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; diff --git a/lib/L3TDE/Model.pm b/lib/L3TDE/Model.pm new file mode 100644 index 0000000..51e1c7c --- /dev/null +++ b/lib/L3TDE/Model.pm @@ -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; diff --git a/lib/L3TDE/Test/DB.pm b/lib/L3TDE/Test/DB.pm new file mode 100644 index 0000000..7be9d41 --- /dev/null +++ b/lib/L3TDE/Test/DB.pm @@ -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; diff --git a/t/00000001-model.t b/t/00000001-model.t new file mode 100644 index 0000000..e292671 --- /dev/null +++ b/t/00000001-model.t @@ -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'; +} +