Initial commit.

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 <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;

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;
+}

l3tde.json.example

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

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;

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;

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;

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;

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;

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;

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;

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;

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';
+}
+