Permalink
Fetching contributors…
Cannot retrieve contributors at this time
476 lines (371 sloc) 13.6 KB
package Convos::Core::Backend::File;
use Mojo::Base 'Convos::Core::Backend';
use Convos::Util qw(next_tick spurt DEBUG);
use Fcntl ':flock';
use File::ReadBackwards;
use Mojo::File;
use Mojo::IOLoop::ForkCall ();
use Mojo::JSON;
use Mojo::Util;
use Symbol;
use Time::Piece;
use Time::Seconds;
use constant FLAG_OFFSET => 48; # chr 48 == "0"
use constant FLAG_NONE => 0;
use constant FLAG_HIGHLIGHT => 1;
use constant FLAG_X => 2; # not yet in use
use constant FLAG_Y => 4; # not yet in use
use constant FLAG_Z => 8; # not yet in use
my %FORMAT = (
action => ['* %s %s', qw(from message)],
kick => ['-!- %s kicked %s. %s', qw(kicker part message)],
nick_change => ['-!- %s changed nick to %s', qw(nick new_nick)],
notice => ['-%s- %s', qw(from message)],
part => ['-!- %s parted. %s', qw(nick message)],
private => ['<%s> %s', qw(from message)],
);
has home => sub { Carp::confess('home() cannot be built') };
has _fc => sub {
my $fc = Mojo::IOLoop::ForkCall->new;
$fc->on(error => sub { warn "[fc] $_[1]" });
$fc;
};
sub connections {
my ($self, $user, $cb) = @_;
my $user_dir = $self->home->child(@{$user->uri})->dirname;
my ($CONNECTIONS, @connections);
unless (opendir $CONNECTIONS, $user_dir) {
return next_tick $self, $cb, $!, [] if $cb;
die $!;
}
while (my $id = readdir $CONNECTIONS) {
next unless $id =~ /^\w+/;
my $settings = $user_dir->child($id, 'connection.json');
next unless -e $settings;
push @connections, Mojo::JSON::decode_json($settings->slurp);
delete $connections[-1]{state}; # should not be stored in connection.json
}
return next_tick $self, $cb, '', \@connections if $cb;
return \@connections;
}
sub delete_object {
my ($self, $obj, $cb) = @_;
if ($obj->isa('Convos::Core::Connection')) {
$obj->unsubscribe($_) for qw(dialog message state);
}
Mojo::IOLoop->delay(
sub {
$self->_fc->run(
sub {
my $path = $self->home->child(@{$obj->uri});
$path = $path->dirname
if grep { $obj->isa($_) } qw(Convos::Core::Connection Convos::Core::User);
if (-d $path) {
$path->remove_tree({verbose => DEBUG});
}
else {
unlink $path or die "unlink $path: $!";
}
},
shift->begin,
);
},
sub {
my ($delay, $err) = @_;
warn "[@{[$obj->id]}] Delete object: @{[$err || 'Success']}\n" if DEBUG;
$self->$cb($err || '');
},
);
return $self;
}
sub load_object {
my ($self, $obj, $cb) = @_;
my $storage_file = $self->home->child(@{$obj->uri});
my $data = {};
my $err = '';
if (-e $storage_file) {
eval { $data = Mojo::JSON::decode_json($storage_file->slurp); };
$err = $@ || 'Unknown error' unless $data;
}
return next_tick $self, $cb, $err, $data if $cb;
return $data unless $err;
die $err;
}
sub messages {
my ($self, $obj, $query, $cb) = @_;
my $re = $query->{match} || qr{.};
my %args;
$re = qr{\Q$re\E}i unless ref $re;
$re = qr/^(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}) (\d?)\s*(.*$re.*)$/;
$args{limit} = $query->{limit} || 60;
$args{messages} = [];
$args{re} = $re;
# If both "before" and "after" are provided
if ($query->{before} and $query->{after}) {
$args{before} = _strptime($query->{before}, '%Y-%m-%dT%H:%M:%S');
$args{after} = _strptime($query->{after}, '%Y-%m-%dT%H:%M:%S');
}
# If "before" is provided but not "after"
# Set "after" to 12 months before "before"
elsif ($query->{before} and !$query->{after}) {
$args{before} = _strptime($query->{before}, '%Y-%m-%dT%H:%M:%S');
$args{after} = $args{before}->add_months(-12);
}
# If "after" is provided but not "before"
# Set "before" to 12 months after "after"
elsif (!$query->{before} and $query->{after}) {
$args{after} = _strptime($query->{after}, '%Y-%m-%dT%H:%M:%S');
$args{before} = $args{after}->add_months(12);
}
# If neither "before" nor "after" are provided
# Set "before" to now and "after" to 12 months before "before"
else {
$args{before} = 60 + gmtime; # make sure we get the message sent right now as well
$args{after} = $args{before}->add_months(-12);
}
# Do not search if the difference between "before" and "after" is more than 12 months
# This limits the amount of time that could be spent searching and it also prevents DoS attacks
return $self if $args{before} - $args{after} > $args{before} - $args{before}->add_months(-12);
# The {cursor} is used to walk through the month-hashed log files
$args{cursor} = $args{before};
warn "[@{[$obj->id]}] Searching $args{after} - $args{before}\n" if DEBUG;
Mojo::IOLoop->delay(
sub {
$self->_fc->run(sub { $self->_messages($obj, \%args) }, shift->begin);
},
sub {
my ($delay, $err, $messages) = @_;
$self->$cb($err, $messages || []);
},
);
return $self;
}
sub notifications {
my ($self, $user, $query, $cb) = @_;
my $file = $self->_notifications_file($user);
my ($FH, $re, @notifications);
$query->{limit} ||= 40;
unless ($FH = File::ReadBackwards->new($file)) {
warn "[@{[$user->id]}] Read $file: $!\n" if DEBUG;
return next_tick $self, $cb, '', [];
}
$re = $query->{match} || qr{.};
$re = qr{\Q$re\E}i unless ref $re;
$re = qr/^(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}) (\S+) (\S+) (.*$re.*)$/;
warn "[@{[$user->id]}] Gettings notifications from $file...\n" if DEBUG;
while (my $line = $FH->getline) {
next unless $line =~ $re;
my $message = {connection_id => $2, dialog_id => $3, message => $4, ts => $1};
my $ts = _strptime($message->{ts}, '%Y-%m-%dT%H:%M:%S');
$self->_message_type_from($message);
unshift @notifications, $message;
last if @notifications == $query->{limit};
}
return next_tick $self, $cb, '', \@notifications;
}
sub save_object {
my ($self, $obj, $cb) = @_;
my $storage_file = $self->home->child(@{$obj->uri});
my $err = '';
eval {
my $dir = $storage_file->dirname;
$dir->make_path($dir) unless -d $dir;
$storage_file->spurt(Mojo::JSON::encode_json($obj->TO_JSON('private')));
warn "[@{[$obj->id]}] Save success. ($storage_file)\n" if DEBUG;
1;
} or do {
$err = $@;
warn "[@{[$obj->id]}] Save $err ($storage_file)\n" if DEBUG;
};
return next_tick $self, $cb, $err if $cb;
return $self unless $err;
die $err;
}
sub users {
my ($self, $cb) = @_;
my $home = $self->home;
my @users;
if (opendir(my $USERS, $home)) {
while (my $email = readdir $USERS) {
my $settings = $home->child($email, 'user.json');
next unless $email =~ /.\@./ and -e $settings; # poor mans regex
push @users, Mojo::JSON::decode_json($settings->slurp);
}
}
return next_tick $self, $cb, '', \@users if $cb;
return \@users;
}
sub _format {
my ($self, $key) = @_;
my $format = $FORMAT{$key};
return @$format if $format;
warn "[Convos::Core::Backend::File] No format defined for $key\n" if DEBUG;
return;
}
sub _log {
my ($self, $obj, $ts, $message) = @_;
my $t = gmtime $ts;
my $ym = sprintf '%s/%02s', $t->year, $t->mon;
my $file = $self->_log_file($obj, $ym);
my $dir = $file->dirname;
$message = Mojo::Util::encode('UTF-8', $message) if utf8::is_utf8($message);
$dir->make_path unless -d $dir;
open my $FH, '>>', $file or die "Can't open log file $file: $!";
warn "[@{[$obj->id]}:@{[$t->datetime]}] $file <<< ($message)\n" if DEBUG == 2;
flock $FH, LOCK_EX;
$FH->syswrite($t->datetime . " $message\n") or die "Write $file: $!";
flock $FH, LOCK_UN;
}
sub _log_file {
my ($self, $obj, $t) = @_;
my @path = ($obj->connection->user->id, $obj->connection->id);
push @path, ref $t ? sprintf '%s/%02s', $t->year, $t->mon : $t;
push @path, $obj->id if $obj->id;
my $leaf = pop @path;
return $self->home->child(@path, "$leaf.log");
}
sub _message_type_from {
my ($self, $message) = @_;
return @$message{qw(type from)} = (private => $1) if $message->{message} =~ s/^<([^\s\>]+)>\s//;
return @$message{qw(type from)} = (notice => $1) if $message->{message} =~ s/^-([^\s\>]+)-\s//;
return @$message{qw(type from)} = (action => $1) if $message->{message} =~ s/^\* (\S+)\s//;
return @$message{qw(type from)} = (server => '') if $message->{message} =~ s/^(?:-!-\s)?//;
return @$message{qw(type from)} = (unknown => '');
}
# blocking method
sub _messages {
my ($self, $obj, $args) = @_;
my $cursor = $args->{cursor};
return [] if $args->{after} > $args->{before};
return $args->{messages} if $cursor < $args->{after};
$args->{cursor} = $args->{cursor}->add_months(-1) while $cursor->mon == $args->{cursor}->mon;
my $file = $self->_log_file($obj, $cursor);
my $FH = File::ReadBackwards->new($file);
unless ($FH) {
warn "[@{[$obj->id]}] $!: $file\n" if DEBUG >= 2;
return $self->_messages($obj, $args);
}
warn "[@{[$obj->id]}] Gettings messages from $file...\n" if DEBUG;
while (my $line = $FH->getline) {
$line = Mojo::Util::decode('UTF-8', $line);
next unless $line =~ $args->{re};
my $flag = $2 || '0';
my $message = {message => $3, ts => $1};
my $ts = _strptime($message->{ts}, '%Y-%m-%dT%H:%M:%S');
next unless $ts < $args->{before} and $ts > $args->{after};
$self->_message_type_from($message);
$message->{highlight}
= (ord($flag) - FLAG_OFFSET) & FLAG_HIGHLIGHT ? Mojo::JSON->true : Mojo::JSON->false;
unshift @{$args->{messages}}, $message;
return $args->{messages} if int @{$args->{messages}} == $args->{limit};
}
return $self->_messages($obj, $args);
}
sub _notifications_file {
$_[0]->home->child($_[1]->id, 'notifications.log');
}
sub _save_notification {
my ($self, $obj, $ts, $message) = @_;
my $file = $self->_notifications_file($obj->connection->user);
my $t = gmtime $ts;
open my $FH, '>>', $file or die "Can't open notifications file $file: $!";
warn "[@{[$obj->id]}] $file <<< ($message)\n" if DEBUG == 2;
flock $FH, LOCK_EX;
printf $FH "%s %s %s %s\n", $t->datetime, $obj->connection->id, $obj->id, $message;
flock $FH, LOCK_UN;
}
sub _setup {
my $self = shift;
Scalar::Util::weaken($self);
$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) = @_;
my ($format, @keys) = $self->_format($msg->{type}) or return;
my $message = sprintf $format, map { $msg->{$_} } @keys;
my $flag = FLAG_NONE;
if ($msg->{highlight} and $target->id and !$target->is_private) {
$self->_save_notification($target, $msg->{ts}, $message);
$connection->user->{unread}++;
$connection->user->save;
$flag |= FLAG_HIGHLIGHT;
}
$self->emit("user:$uid",
message =>
{connection_id => $cid, dialog_id => $target->id, name => $target->name, %$msg});
$message = sprintf "%c %s", $flag + FLAG_OFFSET, $message;
$self->_log($target, $msg->{ts}, $message);
}
);
$connection->on(
state => sub {
my ($connection, $type, $args) = @_;
$self->emit("user:$uid", state => {connection_id => $cid, %$args, type => $type});
}
);
}
);
}
sub _strptime {
local $_ = shift;
$_ =~ s!\.?0*Z$!!;
Time::Piece->strptime($_, '%Y-%m-%dT%H:%M:%S');
}
1;
=encoding utf8
=head1 NAME
Convos::Core::Backend::File - Backend for storing object to file
=head1 DESCRIPTION
L<Convos::Core::Backend::File> contains methods which is useful for objects
that want to be persisted to disk or store state to disk.
=head2 Where is data stored
C<CONVOS_HOME> can be set to specify the root location for where to save
data from objects. The default directory on *nix systems is something like this:
$HOME/.local/share/convos/
C<$HOME> is figured out from L<File::HomeDir/my_home>.
=head2 Directory structure
$CONVOS_HOME/
$CONVOS_HOME/joe@example.com/ # one directory per user
$CONVOS_HOME/joe@example.com/user.json # user settings
$CONVOS_HOME/joe@example.com/irc-freenode/connection.json # connection settings
$CONVOS_HOME/joe@example.com/irc-freenode/2015/02.log # connection log
$CONVOS_HOME/joe@example.com/irc-freenode/2015/10/marcus.log # dialog log
$CONVOS_HOME/joe@example.com/irc-freenode/2015/12/#convos.log # dialog log
Notes about the structure:
=over 2
=item * Easy to delete a user and all associated data.
=item * Easy to delete a connection and all associated data.
=item * One log file per month should not cause too big files.
=item * Hard to delete a dialog thread. Ex: all dialogs with "marcus".
=item * Hard to search for messages between connections for a given date.
=back
=head1 ATTRIBUTES
L<Convos::Core::Backend::File> inherits all attributes from
L<Convos::Core::Backend> and implements the following new ones.
=head2 home
See L<Convos::Core/home>.
=head1 METHODS
L<Convos::Core::Backend::File> inherits all methods from
L<Convos::Core::Backend> and implements the following new ones.
=head2 connections
See L<Convos::Core::Backend/connections>.
=head2 delete_object
See L<Convos::Core::Backend/delete_object>.
=head2 load_object
See L<Convos::Core::Backend/load_object>.
=head2 messages
See L<Convos::Core::Backend/messages>.
=head2 notifications
See L<Convos::Core::Backend/notifications>.
=head2 save_object
See L<Convos::Core::Backend/save_object>.
=head2 users
See L<Convos::Core::Backend/users>.
=head1 AUTHOR
Jan Henning Thorsen - C<jhthorsen@cpan.org>
=cut