diff --git a/Build.PL b/Build.PL index dd50d56..a271777 100755 --- a/Build.PL +++ b/Build.PL @@ -9,19 +9,19 @@ my $build = Module::Build->new( 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, + '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, + 'IO::Socket::SSL' => 0, + 'Promise::Me' => 0, }, ); $build->create_build_script; diff --git a/bin/l3tde.pl b/bin/l3tde.pl index c33297a..5606451 100644 --- a/bin/l3tde.pl +++ b/bin/l3tde.pl @@ -6,16 +6,13 @@ use strict; use warnings; use L3TDE::Bot; -use Future::AsyncAwait; L3TDE::Bot->create_bots; +$SIG{CHLD} = 'IGNORE'; for my $bot (@{L3TDE::Bot->find}) { - main($bot); - say 'AAAAAAAAAAAAAAAAAAAAAAAH'; + my $pid = $bot->start; } - -async sub main { - my $bot = shift; - return $bot->start; +while ((my $pid = wait) != -1) { + say "Reaped $pid"; } diff --git a/lib/L3TDE/Bot.pm b/lib/L3TDE/Bot.pm index 29bf307..cf16e96 100644 --- a/lib/L3TDE/Bot.pm +++ b/lib/L3TDE/Bot.pm @@ -8,11 +8,12 @@ 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; +use L3TDE::Player; +use L3TDE::Help; with 'L3TDE::Model'; @@ -26,6 +27,11 @@ has type => ( required => 1, ); +my $help = L3TDE::Help::singleton(); +$help->install_help(join => 'This command allows to ask the bot to join a group in the server you are using, it may not be implemented for some backends.'); +$help->install_help(help => 'This command shows help.'); +$help->install_help(help1 => 'This does not exists.'); + sub table { 'bots' } sub defaulted_fields { [] } sub not_defaulted_fields { [qw/id type/] } @@ -35,16 +41,75 @@ sub id_fields { [qw/id/] } sub get_instance { my $self = shift; - if ( uc( $self->type ) eq 'IRC' ) { - return L3TDE::Bot::IRC->new( %{ $self->data } ); + { + if (!defined $self->{instance}) { + if ( uc( $self->type ) eq 'IRC' ) { + $self->{instance} = L3TDE::Bot::IRC->new( %{ $self->data }, parent => $self ); + next; + } + die "@{[$self->type]} not implemented."; + } } - die "@{[$self->type]} not implemented."; + return $self->{instance}; } -async sub start { +sub is_registered { + return !!shift->data->{registered}; +} + +sub mark_registered { my $self = shift; - my $start_result = await $self->get_instance->start; - return $start_result; + $self->data->{registered} = 1; + $self->update([qw/data/]); +} + +sub process_msg { + my $self = shift; + my $sender_username = shift; + my $prefered_reply_to = shift; + my $message = shift; + my $instance = $self->get_instance; + if ($message =~ s/^#(\S+)\s*// && defined $1) { + my $command = $1; + if ($command eq 'join') { + my ($where) = $message =~ /^(\S+)/; + if (!defined $where) { + $instance->msg($prefered_reply_to, 'You must choose a channel to join.'); + return; + } + eval { + $instance->try_to_join($prefered_reply_to, $where); + }; + if ($@) { + $instance->msg($prefered_reply_to, $@); + } + return; + } + if ($command eq 'help') { + my ($help_search) = $message =~ /^(\S+)/; + if (!defined $help_search) { + $instance->msg($prefered_reply_to, 'Usage #help .'); + return; + } + eval { + $instance->msg($prefered_reply_to, $help->search_help($help_search)); + }; + if ($@) { + $instance->msg($prefered_reply_to, $@); + } + return; + } + } +} + +sub start { + my $self = shift; + my $pid = fork; + if (!$pid) { + $self->get_instance->start; + exit; + } + return $pid; } sub create_bots { @@ -55,7 +120,6 @@ sub create_bots { say "Created @{[$bot->id]}."; }; if ($@) { - # Duplicate keys are expected. if ( $@ !~ /duplicate key value/ ) { die $@; @@ -77,7 +141,7 @@ sub _parse_irc { username => $username, hostname => $hostname, port => $port, - password => unpack( 'H*', urandom(60) ), + password => unpack( 'H*', urandom(20) ), } }; } diff --git a/lib/L3TDE/Bot/IRC.pm b/lib/L3TDE/Bot/IRC.pm index cecec80..48c9c02 100644 --- a/lib/L3TDE/Bot/IRC.pm +++ b/lib/L3TDE/Bot/IRC.pm @@ -7,74 +7,212 @@ use warnings; use Moo; -use Future::AsyncAwait; use IO::Socket::SSL; use Crypt::URandom qw/urandom/; +use List::AllUtils qw/none any/; with 'L3TDE::Bot::Role'; -has [qw/password username hostname port/] => ( - is => 'rw', +has [qw/password username hostname port parent/] => ( + is => 'rw', required => 1, ); -has socket => ( - is => 'rw', -); +# 221 stands for mode. +has once_221_login => ( is => 'rw' ); + +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( +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"); + $self->_print_socket("USER $username 0 * :L3TDE Bot"); + + if ( $self->parent->is_registered ) { + $self->_print_socket("NICK ${username}_${random_nick}"); + } + else { + $self->_print_socket("NICK ${username}"); + } + return $self; } -sub _send_message { - my $self = shift; +sub _print_socket { + my $self = shift; my $message = shift; - my $socket = $self->socket; + my $socket = $self->socket; + $message =~ s/\s+$//; + say "SENT ($message)"; print $socket "$message\r\n"; } -async sub start { +sub _try_reply_ping { my $self = shift; + my $line = shift; + if ( $line =~ /^PING (.+?)\s+$/ ) { + $self->_print_socket("PONG $1"); + return 1; + } + return 0; +} + +sub _try_reply_user_interaction { + my $self = shift; + my $line = shift; + if ( ( my $params_line = $line =~ s/^:(\S+?)(?:!\S+)?@(?:\S+) (\w+)\s+//r ) + && $1 ) + { + my $sender_username = $1; + my $command = $2; + say "Received interaction ($sender_username -> $command)"; + if ( $command eq 'PRIVMSG' ) { + my ( $dest, $message ) = $params_line =~ /^(\S+) :(.*?)\s+$/; + my $prefered_reply_to = $sender_username; + if ( $dest =~ /^#/ ) { + $prefered_reply_to = $dest; + } + $self->parent->process_msg( $sender_username, + $prefered_reply_to, $message ); + } + return 1; + + } + return 0; + +} + +sub _try_reply_server_action { + my $self = shift; + my $line = shift; + if ( my ( $server, $protocol_message ) = $line =~ /^:(\S+) (\d+)/ ) { + + # We silence the annoying motd. + if ( $protocol_message == 221 ) { + if ( !$self->once_221_login ) { + $self->once_221_login(1); + if ( $self->parent->is_registered ) { + $self->login; + } + else { + $self->register; + } + $self->_join_saved_channels; + } + } + return 1; + } + return 0; + +} + +sub start { + my $self = shift; + $self->once_221_login(0); while (1) { eval { - await $self->_generate_socket; - #while(defined(my $line = $self->_read)) { - # # print $line; - # $self->username('aaaaaaah'); - #} + $self->_generate_socket; + + while ( defined( my $line = $self->_read ) ) { + { + next if !$self->once_221_login; + print $line; + } + !$self->_try_reply_ping($line) + && !$self->_try_reply_user_interaction($line) + && $self->_try_reply_server_action($line); + } }; if ($@) { - warn($@); + die($@); } } - return; + return 1; +} + +sub login { + my $self = shift; + $self->msg( + NickServ => "identify @{[$self->username]} @{[$self->password]}" ); + +} + +sub register { + my $self = shift; + $self->msg( + NickServ => "register @{[$self->password]} @{[$self->password]}" ); + $self->parent->mark_registered; } sub _read { my $self = shift; - $/ = "\r\n"; + local $/ = "\r\n"; my $socket = $self->socket; - my $line = <$socket>; - $/ = "\n"; - return <$socket>; + my $line = <$socket>; + return $line; } -async sub msg { - ... +sub try_to_join { + my $self = shift; + my $class = $self->get_class; + my $prefered_reply_to = shift; + my $channel = shift; + my $parent = $self->parent; + $parent->data->{channels} //= []; + my $channels = $parent->data->{channels}; + if ( none { $_ eq $channel } @$channels ) { + $self->_join_channel($channel); + push @{ $parent->data->{channels} }, $channel; + $parent->update( [qw/data/] ); + $self->msg( $prefered_reply_to, "Succesfully joined $channel" ); + } + else { + die "I am already in $channel."; + } +} + +sub _join_saved_channels { + my $self = shift; + my $parent = $self->parent; + my $channels = $parent->data->{channels}; + return if !defined $channels; + for my $channel (@$channels) { + eval { $self->_join_channel($channel); }; + if ($@) { + say STDERR $@; + } + } +} + +sub _join_channel { + my $self = shift; + my $channel = shift // die("Channel not defined"); + die "$channel should start by #." if $channel !~ /^#/; + $self->_print_socket("JOIN $channel"); +} + +sub get_class { + my $self = shift; + return $self if !ref $self; + return ref $self; +} + +sub msg { + my $self = shift; + my $username = shift; + my $message = shift; + warn "Bad username $username", return if $username =~ /\s+|:/; + $self->_print_socket("PRIVMSG $username :$message"); } 1; diff --git a/lib/L3TDE/Bot/Role.pm b/lib/L3TDE/Bot/Role.pm index 5ada6d9..9d075d2 100644 --- a/lib/L3TDE/Bot/Role.pm +++ b/lib/L3TDE/Bot/Role.pm @@ -9,4 +9,5 @@ use Moo::Role; requires 'msg'; requires 'start'; +requires 'try_to_join'; 1; diff --git a/lib/L3TDE/Help.pm b/lib/L3TDE/Help.pm new file mode 100644 index 0000000..b2e7e77 --- /dev/null +++ b/lib/L3TDE/Help.pm @@ -0,0 +1,59 @@ +package L3TDE::Help; + +use v5.34.1; + +use strict; +use warnings; + +use List::AllUtils qw/one/; + +use Moo; + +has _help => ( + is => 'rw', +); + +# We have to be sure every file which installs help gets loaded. +require L3TDE::Player; +require L3TDE::Bot; + +my $single_instance; + +sub singleton { + if (!$single_instance) { + $single_instance = __PACKAGE__->new; + } + return $single_instance; +} + +sub BUILD { + my $self = shift; + $self->_help({}); +} + +sub search_help { + my $self = shift; + my $search_string = shift; + my $help_text = $self->_help->{$search_string}; + if (defined $help_text) { + return $help_text; + } + my @matches = map { index($_, $search_string) != -1 ? ($_) : () } keys %{$self->_help}; + if (!@matches) { + die "No match."; + } + if (@matches > 1) { + die "More than a match " . (join ', ', @matches); + } + return $self->_help->{$matches[0]}; +} + +sub install_help { + my $self = shift; + my ($key, $help_text) = @_; + if (defined $self->_help->{$key}) { + warn "Overwriting key $key. ¡This is an error!"; + } + $self->_help->{$key} = $help_text; +} +1; diff --git a/lib/L3TDE/Model.pm b/lib/L3TDE/Model.pm index 51e1c7c..ecbad68 100644 --- a/lib/L3TDE/Model.pm +++ b/lib/L3TDE/Model.pm @@ -29,7 +29,7 @@ sub _dbh { } sub create { - my $class = shift->_get_class; + my $class = shift->get_class; my $dbh = $class->_dbh; my %params = @_; my $not_defaulted_fields = $class->not_defaulted_fields; @@ -72,14 +72,14 @@ sub create { } sub _generate_returning { - my $class = shift->_get_class; + 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 $class = shift->get_class; my $not_defaulted_fields = $class->not_defaulted_fields; my $jsonb_fields = $class->jsonb_fields; my $defaulted_fields = $class->defaulted_fields; @@ -90,7 +90,7 @@ sub _to_select_fields { } sub _is_field_to_update { - my $class = shift->_get_class; + my $class = shift->get_class; my $field = shift; my $jsonb_fields = $class->jsonb_fields; my $not_defaulted_fields = $class->not_defaulted_fields; @@ -110,9 +110,9 @@ sub update { 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]}" + 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]}" + die "$field_to_update is not a method in @{[$self->get_class]}" if !$self->can($field_to_update); } my $query = "UPDATE $table SET "; @@ -128,12 +128,12 @@ sub update { $query .= $self->_generate_returning; $query .= ";"; my $result = $dbh->selectrow_hashref( $query, {}, - ( map { $self->$_ } ( @$fields_to_update, @$id_fields ) ) ); + ( map { my $return = $self->$_; $return = encode_json($return) if $self->_is_jsonb($_); $return; } ( @$fields_to_update, @$id_fields ) ) ); return $self->_result_to_object($result); } sub _is_jsonb { - my $class = shift->_get_class; + my $class = shift->get_class; my $key = shift; my $jsonb_fields = $class->jsonb_fields; return any { $key eq $_ } @$jsonb_fields; @@ -141,7 +141,7 @@ sub _is_jsonb { sub _result_to_object { my $self = shift; - my $class = $self->_get_class; + my $class = $self->get_class; my $result = shift; for my $key ( keys %$result ) { $result->{$key} = decode_json $result->{$key} if $self->_is_jsonb($key); @@ -149,14 +149,14 @@ sub _result_to_object { return $class->new(%$result); } -sub _get_class { +sub get_class { my $self = shift; return $self if !ref $self; return ref $self; } sub _validate_find_fields { - my $class = shift->_get_class; + my $class = shift->get_class; my $fields_to_search = shift; my $find_fields = $class->find_fields; for my $field_to_search (@$fields_to_search) { @@ -169,7 +169,7 @@ sub _validate_find_fields { } sub _generate_select { - my $class = shift->_get_class; + my $class = shift->get_class; my $fields_to_search = shift; my $table = $class->table; my $query = "SELECT @{[$class->_to_select_fields]} FROM $table"; @@ -181,7 +181,7 @@ sub _generate_select { } sub find_one { - my $class = shift->_get_class; + my $class = shift->get_class; my %params = @_; my $dbh = $class->_dbh; my @fields_to_search = sort { $a cmp $b } keys %params; @@ -194,7 +194,7 @@ sub find_one { } sub find { - my $class = shift->_get_class; + my $class = shift->get_class; my %params = @_; my $page = delete $params{page} // 0; my $dbh = $class->_dbh; diff --git a/lib/L3TDE/Player.pm b/lib/L3TDE/Player.pm new file mode 100644 index 0000000..cdacf35 --- /dev/null +++ b/lib/L3TDE/Player.pm @@ -0,0 +1,67 @@ +package L3TDE::Player; + +use v5.34.1; + +use strict; +use warnings; + +use Moo; +use L3TDE::Help; + +with 'L3TDE::Model'; + +# TODO: Help texts installation. +my %RACES = ( + aldimor => { + base => { + body => 1, + magic => 5, + strength => 3, + quickness => 2, + wisdom => 4, + intelligence => 4, + charisma => 4, + attack => 2, + luck => 0 + }, + extra => { magic => 3, wisdom => 3 }, + help => +'The aldimors are the race of the magic, they are sightly greenish and love the nature. Damaging a tree is a crime punished with death for them.', + } +); + +for my $key ( keys %RACES ) { + my $sum_base = 0; + my $sum_extra = 0; + my $base = $RACES{$key}{base}; + my $extra = $RACES{$key}{extra}; + for my $key ( keys %$base ) { + $sum_base += $base->{$key}; + } + for my $key ( keys %$extra ) { + $sum_extra += $extra->{$key}; + } + warn("$key base is unbalanced") if $sum_base != 25; + warn("$key extra is unbalanced") if $sum_extra != 6; + my $help = L3TDE::Help::singleton(); + $help->install_help( $key, $RACES{$key}{help} ); +} + +sub table { 'players' } +sub not_defaulted_fields { [qw/username bot_id party_uuid/] } +sub defaulted_fields { [qw/uuid/] } +sub jsonb_fields { [qw/data/] } +sub find_fields { [qw/uuid username bot_id party_uuid/] } +sub id_fields { [qw/uuid/] } + +has [qw/uuid username bot_id party_uuid data/] => ( is => 'rw' ); + +sub bot { + my $self = shift; + if ( !exists $self->{bot} ) { + require L3TDE::Bot; + $self->{bot} = L3TDE::Bot->find_one( id => $self->bot_id ); + } + return $self->{bot}; +} +1;