146 lines
3.4 KiB
Perl
Executable File
146 lines
3.4 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
# fix for older Perl which warns about a bug in File::Slurp
|
|
BEGIN {
|
|
no warnings 'portable';
|
|
use File::Slurp;
|
|
}
|
|
|
|
use FindBin;
|
|
use lib "$FindBin::Bin/../lib";
|
|
use App::Netdisco;
|
|
|
|
use Dancer qw/:moose :script/;
|
|
use Dancer::Plugin::DBIC 'schema';
|
|
|
|
use Daemon::Generic::While1;
|
|
use Parallel::Prefork;
|
|
use Net::Domain 'hostfqdn';
|
|
use Role::Tiny;
|
|
use Try::Tiny;
|
|
|
|
# Parallel::Prefork instance
|
|
my $pp = undef;
|
|
|
|
# track worker pids and their roles
|
|
my %workers = ();
|
|
my $next_role = undef;
|
|
|
|
# must come after globals initialization
|
|
newdaemon(
|
|
progname => 'netdisco-daemon',
|
|
($> != 0 ? (pidbase => './') : ()),
|
|
logpriority => 'daemon.info',
|
|
);
|
|
|
|
sub gd_preconfig {
|
|
my $gd = shift;
|
|
|
|
# used for locking jobs in central Pg queue
|
|
$gd->{nd_host} = hostfqdn;
|
|
|
|
set(daemon_pollers => 2)
|
|
if !defined setting('daemon_pollers');
|
|
set(daemon_interactives => 2)
|
|
if !defined setting('daemon_interactives');
|
|
|
|
# need to do this after setting defaults
|
|
$pp = Parallel::Prefork->new(
|
|
max_workers => (1 + setting('daemon_pollers')
|
|
+ setting('daemon_interactives')),
|
|
spawn_interval => 2,
|
|
before_fork => \&set_next_worker_role,
|
|
after_fork => \®ister_worker,
|
|
on_child_reap => \&unregister_worker,
|
|
trap_signals => {
|
|
TERM => 'TERM',
|
|
INT => 'TERM',
|
|
},
|
|
);
|
|
|
|
# do not remove this line - required by Daemon::Generic
|
|
return ();
|
|
}
|
|
|
|
# main loop
|
|
sub gd_run_body {
|
|
my $gd = shift;
|
|
|
|
$gd->handle_term
|
|
if $pp->signal_received =~ m/^(?:TERM|INT)$/;
|
|
|
|
$pp->start(sub {
|
|
print STDERR ">>> new $next_role worker starting...\n";
|
|
with "App::Netdisco::Daemon::Worker::$next_role";
|
|
$gd->worker_begin if $gd->can('worker_begin');
|
|
$gd->worker_body;
|
|
$gd->worker_end if $gd->can('worker_end');
|
|
});
|
|
|
|
# I don't think Parallel::Prefork ever returns from start()
|
|
# until a child exits. Not sure this is ever reached.
|
|
$gd->gd_sleep( setting('daemon_sleep_time') || 5 )
|
|
if not $pp->signal_received;
|
|
}
|
|
|
|
sub register_worker {
|
|
my (undef, $pid) = @_;
|
|
$workers{$pid} = $next_role;
|
|
}
|
|
|
|
sub unregister_worker {
|
|
my (undef, $pid, $status) = @_;
|
|
delete $workers{$pid};
|
|
# also check for bad exit status?
|
|
|
|
# revert any running jobs (will be such if child died)
|
|
try {
|
|
schema('daemon')->resultset('Admin')
|
|
->search({status => "running-$pid"})
|
|
->update({status => 'queued', started => undef});
|
|
}
|
|
catch { warn "error reverting jobs for pid $pid: $_\n" };
|
|
}
|
|
|
|
sub set_next_worker_role {
|
|
my $pp = shift;
|
|
$next_role = _find_next_worker_role();
|
|
}
|
|
|
|
sub _find_next_worker_role {
|
|
my @cur = values %workers;
|
|
my $manager = scalar grep {$_ eq 'Manager'} @cur;
|
|
my $poller = scalar grep {$_ eq 'Poller'} @cur;
|
|
my $inter = scalar grep {$_ eq 'Interactive'} @cur;
|
|
|
|
return 'Manager' if $manager < 1;
|
|
|
|
my $need_poller = $poller < setting('daemon_pollers');
|
|
my $need_inter = $inter < setting('daemon_interactives');
|
|
|
|
if ($need_poller and $need_inter) {
|
|
return (int(rand(2)) ? 'Interactive' : 'Poller');
|
|
}
|
|
|
|
return 'Interactive' if $need_inter;
|
|
return 'Poller' if $need_poller;
|
|
}
|
|
|
|
sub handle_term {
|
|
my $gd = shift;
|
|
$pp->wait_all_children;
|
|
$gd->gd_quit_event
|
|
}
|
|
|
|
# in case we screw up and die ourselves
|
|
END {
|
|
if (defined $pp) {
|
|
$pp->signal_all_children('TERM');
|
|
$pp->wait_all_children;
|
|
}
|
|
}
|
|
|
|
# nullify this to permit Parallel::Prefork to register handlers instead
|
|
sub gd_setup_signals {}
|
|
|