parcimonie 0.8-1 / usr / share / perl5 / App / Parcimonie / Daemon.pm

=head1 NAME

App::Parcimonie::Daemon - parcimonie daemon class

=head1 SYNOPSIS

Have a look to bin/parcimonie for a full-blown real life usage example.

=cut

package App::Parcimonie::Daemon;
use Moo;
use MooX::late;

with 'App::Parcimonie::Role::HasEncoding';
use MooX::Options;

use 5.10.1;
use namespace::autoclean;
use App::Parcimonie;
use App::Parcimonie::DBus::Object;
use Encode;
use English qw{-no_match_vars};
use File::Spec;
use List::MoreUtils qw{any};
use Net::DBus;
use Net::DBus::Reactor;
use Net::DBus::Service;
use Net::DBus::Test::MockObject;
use Tie::Cache;
use Time::Duration::Parse qw(parse_duration);
use Try::Tiny;
use Type::Utils qw{declare as where coerce from};
use Types::Path::Tiny qw{Dir};
use Types::Standard qw{Str Num};

=head1 TYPES

=cut

my $DurationInSeconds = declare as Num, where { $_ > 0 };
coerce $DurationInSeconds, from Str, sub { parse_duration($_) };

=head1 ATTRIBUTES

=cut

option 'verbose'  => (
    documentation => q{Use this option to get more output.},
    isa => 'Bool', is => 'ro', default => 0
);

option 'gnupg_homedir' => (
    documentation => q{GnuPG homedir.},
    isa           => Dir,
    is            => 'ro',
    format        => 's',
    coerce        => Dir->coercion,
);

option 'gnupg_extra_args' => (
    documentation => q{Extra argument passed to GnuPG. Use this option once per needed argument.},
    cmd_flag      => 'gnupg-extra-arg',
    isa           => 'ArrayRef[Str]',
    is            => 'ro',
    default       => sub { [] },
    format        => 's@',
);

has 'gnupg_options' => (
    isa           => 'HashRef',
    is            => 'ro',
    lazy_build    => 1,
);

option 'average_lapse_time' => (
    documentation => q{Average lapse time between two key fetches. Can be expressed in any way understood by Time::Duration::Parse.},
    isa           => $DurationInSeconds,
    is            => 'ro',
    predicate     => 'has_average_lapse_time',
    format        => 's',
    coerce        => $DurationInSeconds->coercion,
);

option 'minimum_lapse_time' => (
    documentation => q{Minimum lapse time between two key fetches. Can be expressed in any way understood by Time::Duration::Parse. Defaults to 600 seconds.},
    isa           => $DurationInSeconds,
    is            => 'ro',
    default       => sub { 600 },
    predicate     => 'has_minimum_lapse_time',
    format        => 's',
    coerce        => $DurationInSeconds->coercion,
);

has 'last_try' => (
    documentation => q{In-memory LRU buffer storing the result of last key fetch attempts},
    isa           => 'HashRef',
    is            => 'rw',
    default       => sub {
        my %last_try;
        tie %last_try, 'Tie::Cache', { MaxCount => 1000 };
        return \%last_try;
    },
);

has 'iterate_id' => (
    isa           => 'Int',
    is            => 'rw',
);

has 'dbus_object' => (
    isa           => 'Object',
    is            => 'rw',
    default       => sub {
        my ($bus, $service);
        if ($ENV{HARNESS_ACTIVE}) {
            $bus = Net::DBus->test;
            $service = $bus->export_service("org.parcimonie.daemon");
            Net::DBus::Test::MockObject->new($service, "/org/parcimonie/daemon/object");
        }
        else {
            $bus = Net::DBus->session;
            $service = $bus->export_service("org.parcimonie.daemon");
            App::Parcimonie::DBus::Object->new($service);
        }
    },
);

option 'gnupg_already_torified' => (
    documentation => q{gpg is already torified somehow (e.g. gpg.conf or firewall)},
    isa       => 'Bool',
    is        => 'ro',
    required  => 0,
    default   => sub { 0; },
);


=head1 METHODS

=cut

=head2 BUILD

Post-constructor.

=cut
sub BUILD {
    my $self = shift;

    $self->keyserver_defined_on_command_line
        or checkGpgHasDefinedKeyserver($self->gnupg_options);
}

=head2 run

Run the daemon infinite loop.

=cut
sub run {
    my $self = shift;
    my $opt  = shift;
    my $args = shift;

    my $reactor = Net::DBus::Reactor->main();

    my $initial_sleep_time = 1 * 1000;

    $self->iterate_id(
        $reactor->add_timeout(
            $initial_sleep_time,
            Net::DBus::Callback->new(method => sub {
                my $next_sleep_time = $self->iterate;
                # at definition time, the ->add_timeout return value is not known yet;
                # it's stored in the iterate_id attribute
                # => use it only once it's been computed.
                if (defined $self->iterate_id) {
                    $self->debug(sprintf(
                        "Will now sleep %i seconds.",
                        $next_sleep_time
                    ));
                    $reactor->toggle_timeout(
                        $self->iterate_id,
                        1,
                        $next_sleep_time * 1000
                    );
                }
            })
          )
    );

    $reactor->run();
};

sub debug {
    my $self = shift;
    my $msg  = shift;
    say STDERR $self->encoding->encode($msg) if $self->verbose;
}

sub fatal {
    my $self      = shift;
    my $msg       = shift;
    my $exit_code = shift;
    say STDERR $self->encoding->encode($msg);
    exit($exit_code);
}

sub _build_gnupg_options {
    my $self = shift;
    my %opts;
    $opts{homedir}    = $self->gnupg_homedir    if defined $self->gnupg_homedir;
    $opts{extra_args} = $self->gnupg_extra_args if defined $self->gnupg_extra_args;
    return \%opts;
}

=head2 keyserver_defined_on_command_line

Return true iff a keyserver was passed on the command-line via --gnupg-extra-arg.

=cut
sub keyserver_defined_on_command_line {
    my $self      = shift;
    any {
        $_ =~ m{
                   \A                # starts with
                   [-] [-] keyserver # literal --keyserver, followed by
                   [ =]              # a space or an equal sign
                   [^\n]+            # followed by anything but a newline
           }xms
    } @{$self->gnupg_extra_args};
}

sub tryRecvKey {
    my $self  = shift;
    my $keyid = shift;
    my $gpg_output;
    my $gpg_error;

    $self->debug(sprintf("tryRecvKey: trying to fetch %s", $keyid));
    $self->dbus_object->emit_signal("FetchBegin", $keyid);

    try {
        $gpg_output = gpgRecvKeys(
            [ $keyid ],
            $self->gnupg_options,
            already_torified => $self->gnupg_already_torified,
        );
    } catch {
        $gpg_error = $_;
    };

    $gpg_output ||= '';
    my $success = 0;
    if (defined $gpg_error) {
        warn $self->encoding->encode($gpg_error);
    }
    else {
        $self->debug($gpg_output);
        $success = 1;
        $gpg_error = '';
    }

    $self->set_last_try( $keyid => { success => $success, msg => $gpg_error } );
    $self->dbus_object->emit_signal("FetchEnd", $keyid, $success, $gpg_error);

}

sub next_sleep_time {
    my $self            = shift;
    my $num_public_keys = shift;
    my $average_lapse_time =
        $self->has_average_lapse_time ?
            $self->average_lapse_time
            : averageLapseTime($num_public_keys);

    $self->debug(sprintf('Using %s seconds as average sleep time.',
                         $average_lapse_time
    ));

    my $next_sleep_time = rand(2 * $average_lapse_time);
    if ($next_sleep_time < $self->minimum_lapse_time) {
        $next_sleep_time = $self->minimum_lapse_time;
    }
    return $next_sleep_time;
}

=head2 iterate

Arg: long PGP key id (Str).
Returns next sleep time (seconds).

=cut
sub iterate {
    my $self = shift;
    my $default_sleep_time = 600;
    my @public_keys = gpgPublicKeys(
        $self->gnupg_options,
        already_torified => $self->gnupg_already_torified,
    );
    unless (@public_keys) {
        warn "No public key was found.";
        return $default_sleep_time ;
    }
    my $next_sleep_time = $self->next_sleep_time(scalar(@public_keys));
    my ( $keyid ) = pickRandomItems(1, @public_keys);
    # allow the GC to free some memory
    undef(@public_keys);

    $self->tryRecvKey($keyid);

    return $next_sleep_time;
}

sub set_last_try {
    my $self   = shift;
    my $keyid  = shift;
    my $result = shift;

    $self->last_try->{$keyid} = $result;
}

no Moo;
1; # End of App::Parcimonie::Daemon