netdisco/bin/netdisco-backend

#!/usr/bin/env perl

use strict;
use warnings;

our $home;

BEGIN {
  use FindBin;
  FindBin::again();

  my $me = File::Spec->catfile($FindBin::RealBin, $FindBin::RealScript);
  my $uid = (stat($me))[4] || 0;

  $home = ($ENV{NETDISCO_HOME} || (getpwuid($uid))[7] || $ENV{HOME});

  # try to find a localenv if one isn't already in place.
  if (!exists $ENV{PERL_LOCAL_LIB_ROOT}) {
      use File::Spec;
      my $localenv = File::Spec->catfile($FindBin::Bin, 'localenv');
      exec($localenv, $0, @ARGV) if -f $localenv;
      $localenv = File::Spec->catfile($home, 'perl5', 'bin', 'localenv');
      exec($localenv, $0, @ARGV) if -f $localenv;

      die "Sorry, can't find libs required for App::Netdisco.\n"
        if !exists $ENV{PERLBREW_PERL};
  }
}

BEGIN {
  use Path::Class;

  # stuff useful locations into @INC and $PATH
  unshift @INC,
    dir($FindBin::RealBin)->parent->subdir('lib')->stringify,
    dir($FindBin::RealBin, 'lib')->stringify;

  use Config;
  $ENV{PATH} = $FindBin::RealBin . $Config{path_sep} . $ENV{PATH};
}

use Daemon::Control;
use Filesys::Notify::Simple;
use File::Copy;

use App::Netdisco::Environment;
my $config = ($ENV{PLACK_ENV} || $ENV{DANCER_ENVIRONMENT}) .'.yml';

# make sure there is a config file in place
my $template_config = file($ENV{DANCER_CONFDIR}, 'environments', $config);
my $app_config = file($ENV{DANCER_ENVDIR}, $config);
if (! -e $app_config and -e $template_config) {
  copy $template_config, $app_config;
}
if (! -e $app_config) {
  die "error: cannot find Netdisco config at $template_config or $app_config\n";
}

my $netdisco = file($FindBin::RealBin, 'netdisco-backend-fg');
my @args = (scalar @ARGV > 1 ? @ARGV[1 .. $#ARGV] : ());

my $log_dir = dir($home, 'logs');
mkdir $log_dir if ! -d $log_dir;
my $log_file = file($log_dir, 'netdisco-backend.log');

my $uid = (stat($netdisco->stringify))[4] || 0;
my $gid = (stat($netdisco->stringify))[5] || 0;

my $old_pid = file($home, 'netdisco-daemon.pid');
my $new_pid = file($home, 'netdisco-backend.pid');
if (-f $old_pid) { File::Copy::move( $old_pid, $new_pid ) }

Daemon::Control->new({
  name => 'Netdisco Backend',
  program  => \&restarter,
  program_args => [@args],
  pid_file => $new_pid,
  stderr_file => $log_file,
  stdout_file => $log_file,
  redirect_before_fork => 0,
  uid => $uid, gid => $gid,
})->run;

# the guts of this are borrowed from Plack::Loader::Restarter - many thanks!!
my $child = 0;

sub restarter {
  my ($daemon, @program_args) = @_;
  $0 = 'netdisco-backend';

  $child = fork_and_start($daemon, @program_args);
  exit(1) unless $child;

  my $watcher = Filesys::Notify::Simple->new([$ENV{DANCER_ENVDIR}, $log_dir]);
  warn "config watcher: watching $ENV{DANCER_ENVDIR} for updates.\n";

  local $SIG{TERM} = sub { $child = signal_child('TERM', $child); exit(0); };

  while (1) {
      my @restart;

      # this is blocking
      $watcher->wait(sub {
          my @events = @_;
          @events = grep {$_->{path} eq $log_file or
                          file($_->{path})->basename eq $config} @events;
          return unless @events;
          @restart = @events;
      });

      my ($hupit, $rotate) = (0, 0);
      next unless @restart;

      foreach my $f (@restart) {
          if ($f->{path} eq $log_file) {
              ++$rotate;
          }
          else {
              warn "-- $f->{path} updated.\n";
              ++$hupit;
          }
      }

      rotate_logs($child, $daemon, @program_args) if $rotate;
      if ($hupit) {
          signal_child('TERM', $child);
          $child = fork_and_start($daemon, @program_args);
          exit(1) unless $child;
      }
  }
}

sub fork_and_start {
  my ($daemon, @daemon_args) = @_;
  my $pid = fork;
  die "Can't fork: $!" unless defined $pid;

  if ($pid == 0) { # child
      $daemon->redirect_filehandles;
      exec( $netdisco->stringify, @daemon_args );
  }
  else {
      return $pid;
  }
}

sub signal_child {
  my ($signal, $pid) = @_;
  return unless $signal and $pid;
  warn "config watcher: sending $signal to the server (pid:$pid)...\n";
  kill $signal => $pid;
  waitpid($pid, 0);
}

sub rotate_logs {
  my $child = shift;

  return unless (-f $log_file) and
    ((-s $log_file) > (10 * 1024768));

  my @files = glob file($log_dir, '*');
  foreach my $f (reverse sort @files) {
      next unless $f =~ m/$log_file\.(\d)$/;
      my $pos = $1;
      unlink $f if $pos == 7;
      my $next = $pos + 1;
      (my $newf = $f) =~ s/\.$pos$/.$next/;
      rename $f, $newf;
  }

  # if the log file's about 10M then the race condition in copy/truncate
  # has a low risk of data loss. if the file's larger, then we rename and
  # kill.
  if ((-s $log_file) > (12 * 1024768)) {
      rename $log_file, $log_file .'.1';
      signal_child('TERM', $child);
      $child = fork_and_start(@_);
      exit(1) unless $child;
  }
  else {
      copy $log_file, $log_file .'.1';
      truncate $log_file, 0;
  }
}

=head1 NAME

netdisco-backend - Job Control Daemon for Netdisco

=head1 SEE ALSO

=over 4

=item *

L<App::Netdisco>

=back

=cut