parcimonie 0.10.2-4 / 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;

use 5.10.1;
use App::Parcimonie;
use Carp;
use Encode;
use English qw{-no_match_vars};
use List::Util qw{any};
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};
use namespace::clean;

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


=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 'with_dbus'  => (
    documentation => q{Send activity updates on the org.parcimonie.daemon D-Bus service},
    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_builtin_args' => (
    isa           => 'ArrayRef[Str]',
    is            => 'ro',
    default       => sub { [
        '--import-options' => 'merge-only',
    ] },
);

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 'iterate_id' => (
    isa           => 'Int',
    is            => 'rw',
);

has 'dbus_object' => (
    isa           => 'Object',
    is            => 'ro',
    lazy_build    => 1,
);

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; },
);

option 'gnupg2' => (
    documentation => q{Use GnuPG 2.1+ (default: autodetect gpg's version).},
    isa      => 'Bool',
    is       => 'ro',
    required => 0,
    default  => sub { gpg_is_v21(); },
);

has 'memory_usage' => (
    isa       => 'Memory::Usage',
    is        => 'ro',
    required  => 0,
);


=head1 METHODS

=cut

=head2 BUILD

Post-constructor.

=cut
sub BUILD {
    my $self = shift;

    $self->record_memory_usage("[BUILD]: entering");

    $self->keyserver_defined_on_command_line
        or checkGpgHasDefinedKeyserver(
            $self->gnupg_options,
            {
                gnupg2 => $self->gnupg2,
            });

    if ($self->with_dbus) {
        $self->record_memory_usage("[BUILD]: starting to load D-Bus dependencies");
        require App::Parcimonie::DBus::Object;
        require Net::DBus;
        require Net::DBus::Reactor;
        require Net::DBus::Service;
        require Net::DBus::Test::MockObject;
        $self->record_memory_usage("[BUILD]: finished loading D-Bus dependencies");
    }

    $self->record_memory_usage("[BUILD]: leaving");
}

sub _build_dbus_object {
    my $self = shift;

    croak "D-Bus is disabled." unless $self->with_dbus;

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

=head2 run

Run the daemon infinite loop.

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

    $self->record_memory_usage("[run]: entering");

    if ($self->with_dbus) {
        $self->run_with_dbus();
    }
    else {
        use JSON::PP;
        $self->run_without_dbus();
    }
}

sub run_without_dbus {
    my $self = shift;

    while (1) {
        my $next_sleep_time = $self->iterate;
        say encode_json({
            state   => 'Sleeping',
            details => {
                duration => $next_sleep_time,
            },
        });
        sleep($next_sleep_time);
    }
}

sub run_with_dbus {
    my $self = shift;

    $self->record_memory_usage("[run_with_dbus]: entering");

    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
                    ));
                    $self->notify({
                        signal => 'Sleeping',
                        duration => $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 = (
        extra_args => [],
    );
    $opts{homedir} = $self->gnupg_homedir if defined $self->gnupg_homedir;
    push @{$opts{extra_args}}, @{$self->gnupg_builtin_args}
        if defined $self->gnupg_builtin_args;
    push @{$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 notify {
    my $self = shift;
    my $args = shift;

    if ($self->with_dbus) {
        my $signal = $args->{signal};
        my @args_name;
        if ($signal eq 'FetchBegin') {
            @args_name = qw{keyid};
        }
        elsif ($signal eq 'FetchEnd') {
            @args_name = qw{keyid success gpg_error};
        }
        elsif ($signal eq 'Sleeping') {
            @args_name = qw{duration};
        }
        else {
            croak "Unsupported signal: $signal";
        }

        my @args;
        push @args, $args->{$_} for (@args_name);
        $self->dbus_object->emit_signal($signal, @args);
    }
    else {
        say encode_json {
            state   => $args->{signal},
            details => $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->notify({ signal => 'FetchBegin', keyid => $keyid });

    try {
        $gpg_output = gpgRecvKeys(
            [ $keyid ],
            $self->gnupg_options,
            already_torified => $self->gnupg_already_torified,
            gnupg2           => $self->gnupg2,
        );
    } 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->notify({
        signal    => 'FetchEnd',
        keyid     => $keyid,
        success   => $success,
        gpg_error => $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);

    my $fallback_lapse_time = $self->minimum_lapse_time
                            + rand($self->minimum_lapse_time);

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

    my $next_sleep_time = rand(2 * $average_lapse_time);
    if ($next_sleep_time < $self->minimum_lapse_time) {
        $next_sleep_time = $fallback_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;

    $self->record_memory_usage("[iterate]: entering");

    my @public_keys = gpgPublicKeys(
        $self->gnupg_options,
        already_torified => $self->gnupg_already_torified,
        gnupg2           => $self->gnupg2,
    );
    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->record_memory_usage("[iterate]: before fetching key $keyid");
    $self->tryRecvKey($keyid);
    $self->record_memory_usage("[iterate]: after fetching key $keyid");

    return $next_sleep_time;
}

=head2 record_memory_usage

Args: a message (Str) indicating when we're run.
Records memory usage in the memory_usage attribute,
iff. the REPORT_MEMORY_USAGE environment variable is set to a true value.

=cut
sub record_memory_usage {
    my $self = shift;
    my $message = shift;

    return unless exists $ENV{REPORT_MEMORY_USAGE}
        && defined $ENV{REPORT_MEMORY_USAGE}
        && $ENV{REPORT_MEMORY_USAGE};

    $self->memory_usage->record($message);
}

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