diff --git a/.github/workflows/linux.yml b/.github/workflows/linux.yml index 3970ea77a..a3067628e 100644 --- a/.github/workflows/linux.yml +++ b/.github/workflows/linux.yml @@ -36,7 +36,7 @@ jobs: run: | cpanm -n EV~"!= 4.28" cpanm -n https://github.com/jhthorsen/linkembedder/archive/main.tar.gz - cpanm -n DBD::SQLite Hailo Math::Calc::Parser + cpanm -n DBD::SQLite Hailo Math::Calc::Parser Mojo::SQLite cpanm -n Test::Pod Test::Pod::Coverage cpanm -n --installdeps . - name: Run perl tests diff --git a/lib/Convos/Core/Backend/SQLite.pm b/lib/Convos/Core/Backend/SQLite.pm new file mode 100644 index 000000000..2408c9eaa --- /dev/null +++ b/lib/Convos/Core/Backend/SQLite.pm @@ -0,0 +1,262 @@ +package Convos::Core::Backend::SQLite; +use Mojo::Base 'Convos::Core::Backend'; + +use Mojo::SQLite; +use Convos::Date qw(dt); +use Mojo::JSON qw(false true); + +has home => sub { Carp::confess('home() cannot be built') }; +has sqlite => sub { + my $self = shift; + $self->home->make_path unless -d $self->home; + + my $sqlite = Mojo::SQLite->new('sqlite:' . $self->home->child('convos.sqlite')); + $sqlite->migrations->from_file(...)->migrate; + return $sqlite; +}; + +sub connections_p { + my ($self, $user) = @_; + + return $self->_db->select_p('convos_connections')->then(sub { + return shift->hashes->to_array; + }); +} + +sub delete_messages_p { + my ($self, $obj) = @_; + return Mojo::Promise->reject('Unknown target.') unless $obj and $obj->connection; + return $self->_db->delete_p(convos_messages => {conversation_id => $obj->id})->then(sub {$obj}); +} + +sub delete_object_p { + my ($self, $obj) = @_; + + if ($obj->isa('Convos::Core::Connection')) { + $obj->unsubscribe($_) for qw(conversation message state); + } + + return $self->_db->delete_p($self->_obj_to_table($obj), {id => $obj->id})->then(sub {$obj}); +} + +sub load_object_p { + my ($self, $obj) = @_; + + return $self->_db->select_p($self->_obj_to_table($obj), {id => $obj->id})->then(sub { + return shift->hash; + }); +} + +sub messages_p { + my ($self, $obj, $query) = @_; + + if ($query->{around}) { + my %query_before = (%$query, around => undef, before => $query->{around}); + my %query_after = (%$query, around => undef, after => $query->{around}, include => 1); + + return Mojo::Promise->all( + $self->messages_p($obj, \%query_before), + $self->messages_p($obj, \%query_after), + )->then(sub { + my ($before, $after) = map { $_->[0] } @_; + return {%$before, %$after, messages => [map { @{$_->{messages}} } ($before, $after)]}; + }); + } + + my %extra = (limit => $query->{limit} || 60); + $extra{order_by} = {-desc => 'ts'}; + + my %where = (id => $obj->id); + $where{from} = $query->{from} if $query->{from}; + + my $lt = $query->{include} ? '<=' : '<'; + my $gt = $query->{include} ? '>=' : '>'; + push @{$where{ts}}, {$gt => dt $query->{after}} if $query->{after}; + push @{$where{ts}}, {$lt => dt $query->{before}} if $query->{before}; + + return $self->_db->select_p(convos_messages => \%where, \%extra)->then(sub { + return shift->hashes->to_array; + }); +} + +sub notifications_p { + my ($self, $user, $query) = @_; + + my %extra = (limit => $query->{limit} || 60); + $extra{order_by} = {-desc => 'ts'}; + + return $self->_db->select_p(convos_notifications => {}, \%extra)->then(sub { + return shift->hashes->to_array; + }); +} + +sub save_object_p { + my ($self, $obj) = @_; + + return $self->_db->insert_p($self->_obj_to_table($obj), $obj->TO_JSON('private')) + ->then(sub {$obj}); +} + +sub users_p { + my $self = shift; + + return $self->_db->select_p('convos_users')->then(sub { + return shift->hashes->sort(sub { + $a->{registered} cmp $b->{registered} || $a->{email} cmp $b->{email}; + })->to_array; + }); +} + +sub _add_message_p { + my ($self, $target, $msg) = @_; + + return $self->_db->insert_p( + convos_notifications => { + connection_id => $target->connection->id, + conversation_id => $target->id, + from => $msg->{from}, + highlight => $msg->{highlight} ? 1 : 0, + message => $msg->{message}, + ts => dt($msg->{ts})->to_datetime, + type => $msg->{type} || 'normal', + } + ); +} + +sub _add_notification_p { + my ($self, $target, $msg) = @_; + + return $self->_db->insert_p( + convos_notifications => { + connection_id => $target->connection->id, + conversation_id => $target->id, + from => $msg->{from}, + message => $msg->{message}, + ts => dt($msg->{ts})->to_datetime, + type => $msg->{type} || 'normal', + } + ); +} + +sub _db { shift->sqlite->db } + +sub _obj_to_table { + my ($self, $obj) = @_; + return 'convos_connections' if $obj->isa('Convos::Core::Connection'); + return 'convos_conversations' if $obj->isa('Convos::Core::Conversation'); + return 'convos_settings' if $obj->isa('Convos::Core::Settings'); + return 'convos_users' if $obj->isa('Convos::Core::User'); + return 'convos_unknown_object'; +} + +sub _setup { + my $self = shift; + + Scalar::Util::weaken($self); + my $catch = sub { $self->emit(error => shift) }; + + $self->on( + connection => sub { + my ($self, $connection) = @_; + my $cid = $connection->id; + my $uid = $connection->user->id; + + Scalar::Util::weaken($self); + $connection->on( + message => sub { + my ($connection, $target, $msg) = @_; + + if ($msg->{highlight} and $target->id and !$target->is_private) { + $self->_add_notification_p($target, $msg)->catch($catch); + $connection->user->save_p->catch($catch); + } + + $self->_add_message_p($target, $msg)->catch($catch); + } + ); + } + ); + + return $self->SUPER::_setup; +} + +1; + +=encoding utf8 + +=head1 NAME + +Convos::Core::Backend::SQLite - Backend for storing objects to SQLite + +=head1 DESCRIPTION + +L contains methods which is useful for objects +that want to be persisted to an SQLite database. + +=head2 Where is data stored + +C can be set to specify the root location for where to save store +the SQLite database. The default directory on *nix systems is something like +this: + + $HOME/.local/share/convos/ + +C<$HOME> is figured out from L. + +=head1 ATTRIBUTES + +L inherits all attributes from +L and implements the following new ones. + +=head2 home + +See L. + +=head2 sqlite + + $sqlite = $backend->sqlite; + +Returns a L object. + +=head1 METHODS + +L inherits all methods from +L and implements the following new ones. + +=head2 connections_p + +See L. + +=head2 delete_messages_p + +See L. + +=head2 delete_object_p + +See L. + +=head2 load_object_p + +See L. + +=head2 messages_p + +See L. + +=head2 notifications_p + +See L. + +=head2 save_object_p + +See L. + +=head2 users_p + +See L. + +=head1 SEE ALSO + +L. + +=cut diff --git a/t/backend-sqlite-basic.t b/t/backend-sqlite-basic.t new file mode 100644 index 000000000..722d9ac91 --- /dev/null +++ b/t/backend-sqlite-basic.t @@ -0,0 +1,42 @@ +#!perl +use lib '.'; +use t::Helper; +use Convos::Core::Backend::SQLite; +use Convos::Core::User; + +my $backend = Convos::Core::Backend::SQLite->new(home => Mojo::File->new($ENV{CONVOS_HOME})); +my $user = Convos::Core::User->new(email => 'jhthorsen@cpan.org', uid => 42); + +my $users; +$backend->users_p->then(sub { $users = shift })->$wait_success('users_p'); +is_deeply $users, [], 'no users'; + +my $saved; +$backend->save_object_p($user)->then(sub { $saved = shift })->$wait_success('save_object_p'); +is $saved, $user, 'save_object_p'; + +my $connections; +$backend->connections_p($user)->then(sub { $connections = shift })->$wait_success('connections_p'); +is_deeply $connections, [], 'no connections'; + +my $loaded; +$backend->load_object_p($user)->then(sub { $loaded = shift; $loaded->{registered} = 'ts', }) + ->$wait_success('load_object_p'); +is_deeply $loaded, + { + email => 'jhthorsen@cpan.org', + highlight_keywords => [], + password => '', + registered => 'ts', + remote_address => '127.0.0.1', + roles => [], + uid => 42, + unread => 0 + }, + 'load_object_p'; + +my $deleted; +$backend->delete_object_p($user)->then(sub { $deleted = shift })->$wait_success('delete_object_p'); +is $deleted, $user, 'delete_object_p'; + +done_testing;