Adding help and join commands.

Build.PL

@@ -20,8 +20,8 @@ my $build = Module::Build->new(
         'Test::Most'       => 0,
         'Test::MockModule' => 0,
         'Crypt::URandom'   => 0,
-        'Future::AsyncAwait' => 0,
         'IO::Socket::SSL'  => 0,
+        'Promise::Me'      => 0,
     },
 );
 $build->create_build_script;

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);
+    my $pid = $bot->start;
-    say 'AAAAAAAAAAAAAAAAAAAAAAAH';
 }
-
+while ((my $pid = wait) != -1) {
-async sub main {
+    say "Reaped $pid";
-    my $bot = shift;
-    return $bot->start;
 }

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 (!defined $self->{instance}) {
             if ( uc( $self->type ) eq 'IRC' ) {
-        return L3TDE::Bot::IRC->new( %{ $self->data } );
+                $self->{instance} = L3TDE::Bot::IRC->new( %{ $self->data }, parent => $self );
+                next;
             }
             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;
+    $self->data->{registered} = 1;
-    return $start_result;
+    $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 <topic>.');
+                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) ),
         }
     };
 }

lib/L3TDE/Bot/IRC.pm

@@ -7,23 +7,24 @@ 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/] => (
+has [qw/password username hostname port parent/] => (
     is       => 'rw',
     required => 1,
 );
 
-has socket => (
+# 221 stands for mode.
-    is => 'rw',
+has once_221_login => ( is => 'rw' );
-);
+
+has socket => ( is => 'rw', );
 
 # Not lazy because we may do it more than once.
-async sub _generate_socket {
+sub _generate_socket {
     my $self        = shift;
     my $username    = $self->username;
     my $hostname    = $self->hostname;
@@ -37,44 +38,181 @@ async sub _generate_socket {
         Timeout  => 5
     ) or die $!;
     $self->socket($return);
-    $self->_send_message("USER $username 0 * :L3TDE Bot\r\n");
+    $self->_print_socket("USER $username 0 * :L3TDE Bot");
-    $self->_send_message("NICK ${username}_${random_nick}\r\n");
+
+    if ( $self->parent->is_registered ) {
+        $self->_print_socket("NICK ${username}_${random_nick}");
+    }
+    else {
+        $self->_print_socket("NICK ${username}");
+    }
+    return $self;
 }
 
-sub _send_message {
+sub _print_socket {
     my $self    = shift;
     my $message = shift;
     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;
+            $self->_generate_socket;
-            #while(defined(my $line = $self->_read)) {
+
-            #    #      print $line;
+            while ( defined( my $line = $self->_read ) ) {
-            #    $self->username('aaaaaaah');
+                {
-            #}
+                    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 $line;
-    return <$socket>;
 }
 
-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;

lib/L3TDE/Bot/Role.pm

@@ -9,4 +9,5 @@ use Moo::Role;
 
 requires 'msg';
 requires 'start';
+requires 'try_to_join';
 1;

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;

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;

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;