File Coverage

bin/sibs

Criterion	Covered	Total	%
statement	140	191	73.3
branch	56	110	50.9
condition	10	25	40.0
subroutine	21	25	84.0
pod			n/a
total	227	351	64.6

#!/usr/bin/env perl
use strict;
use warnings;
use Fcntl qw( O_CREAT O_EXCL );
use POSIX ();
use URI;

our @DEFAULT_EXCLUDE = qw( .cache .cpanm .gvfs Downloads Dropbox Trash );
our $SSH             = 'ssh';
our $SSH_KEYGEN      = 'ssh-keygen';
our $LOCK;

$ENV{HOME} ||= 'ENVIRONMENT_HOME_IS_NOT_SET';

END {
  unlink $LOCK if $LOCK;
}

sub run_rsync {
  my $self    = shift;
  my $uri     = $self->{destination};
  my $lock    = sprintf '%s.backup.lock', $self->{config};
  my @options = qw( -az --delete-after --numeric-ids --relative );

  push @options, map {qq(--exclude=$_)} @{$self->{exclude} || []};
  push @options, '--verbose' if $self->{verbose};
  push @options, @{$self->{source}};

  if (my $remote_host = $self->remote_host) {
    push @options, sprintf '%s@%s:%s/incoming', $uri->userinfo, $remote_host, $uri->path;
  }
  else {
    push @options, sprintf '%s/incoming', $uri->path;
  }

  IO::File->new->open($lock, O_CREAT | O_EXCL) or die "Already backing up. ($lock)\n";
  $LOCK = $lock;
  $self->_system(rsync => @options);
}

sub create_sibs_config {
  my $self = shift;
  my $tmp = sprintf '%s.tmp', $self->{config};

  open my $CONFIG, '>', $tmp or die "Cannot write $tmp: $!\n";
  local $_;
  $self->_log($@ || "Creating '$self->{config}' from user input...");

  print $CONFIG "{\n";
  printf $CONFIG "  email => '%s',\n",         $_ if $self->_read('email');
  printf $CONFIG "  exclude => [qw( %s )],\n", $_ if $self->_read('exclude');
  printf $CONFIG "  source => [qw( %s )],\n",  $_ if $self->_read('source');
  printf $CONFIG "  destination => '%s',\n",   $_ if $self->_read('destination');
  print $CONFIG "}\n";

  close $CONFIG or die "Could not write '$tmp': $!\n";
  rename $tmp, $self->{config} or die "Could not write '$self->{config}: $!'\n";
}

sub add_backup_host_to_ssh_config {
  my $self    = shift;
  my $moniker = $self->remote_host;
  my $file    = $self->ssh_file('config');

  if (-r $file) {
    open my $CONFIG, '<', $file or die "Could not open $file: $!";
    while (<$CONFIG>) {
      next unless /Host\s+$moniker/;
      $self->_log("Host $moniker exists in $file.");
      return 1;
    }
  }

  $self->_log("Adding $moniker to $file");
  open my $CONFIG, '>>', $file or die "Cannot write to $file: $!";
  printf $CONFIG "\nHost %s\n",         $self->remote_host;
  printf $CONFIG "  Hostname %s\n",     $self->{destination}->host;
  printf $CONFIG "  IdentityFile %s\n", $self->ssh_file('sibs_dsa');
  close $CONFIG;
}

sub create_identity_file {
  my $self = shift;
  my $file = $self->ssh_file('sibs_dsa');
  my $identity;

  if (-r $file) {
    $self->_log("Identity file '$file' exists");
  }
  else {
    $self->_log("Creating $file with empty password using ssh-keygen ...");
    $self->_system($SSH_KEYGEN => qw( -q -b 4096 -t rsa ), -N => '', -f => $file);
  }

  $self->_log("Copying pub key to remote host ...");
  open my $IDENTITY, '<', "$file.pub" or die "Cannot read $file.pub: $!";
  $self->run_sibs_remote(sub { readline $IDENTITY }, 'remote-init');
}

sub remote_add_pub_key {
  my ($self, $key) = @_;
  my $file = $self->ssh_file('authorized_keys');

  if (-r $file) {
    my $match = quotemeta $key;
    open my $AUTHORIZED_KEYS, '<', $file or die "Could not open $file: $!";
    while (<$AUTHORIZED_KEYS>) {
      next unless /$match/;
      $self->_log("Remote host has pub key");
      return 0;
    }
  }

  open my $AUTHORIZED_KEYS, '>>', $file or die "Could not append to $file: $!\n";
  print $AUTHORIZED_KEYS $key;
  print $AUTHORIZED_KEYS "\n" unless $key =~ /\n$/;
  close $AUTHORIZED_KEYS;
  $self->_log("Pub key added to remote authorized_keys.");
  return 1;
}

sub remote_host {
  my $self    = shift;
  my $host    = $self->{destination}->host or return '';
  my $moniker = "sibs-$host";

  $moniker =~ s/\./-/g;
  $moniker;
}

sub load_config {
  my $self = shift;
  my $config;

  open my $CONFIG, '<', $self->{config} or die "Cannot read $self->{config}: $! Run '$0 setup'\n";
  $config = join '', <$CONFIG>;
  $config = eval <<"  CONFIG";
    use strict;
    use warnings;
    use File::Basename;
    $config
  CONFIG

  $config or die "Invalid config file: ($@)\n";
  $config->{exclude} ||= [@DEFAULT_EXCLUDE];
  $config->{source}  ||= [$ENV{HOME}];
  $config->{destination} = URI->new($config->{destination} || '');

  @{$self}{keys %$config} = values %$config;

  for my $m (qw( scheme path )) {
    next if $config->{destination}->$m;
    die "[$self->{config}] Missing '$m' part for 'destination' URI\n";
  }

  $config->{destination}->scheme eq 'rsync'
    or die "[$self->{config}] Only rsync:// is supported for 'destination' URI\n";
}

sub run_sibs_remote {
  my ($self, @args) = @_;
  my $stdin = ref $args[0] eq 'CODE' ? shift @args : sub {''};
  my @cmd;

  if (my $remote_host = $self->remote_host) {
    @cmd = ($SSH => '-l' => $self->{destination}->userinfo, $remote_host);
  }

  unshift @args, '--silent'  if $self->{silent};
  unshift @args, '--verbose' if $self->{verbose};
  push @cmd, qq(perl - @args);

  open my $SSH,  '|-', @cmd     or die "Cannot start 'sibs @args' remote: $!";
  open my $SELF, '<',  __FILE__ or die "Cannot read $0: $!";
  print $SSH $_ while <$SELF>;
  print $SSH "\n__DATA__\n";
  print $SSH $self->$stdin;
  close $SSH;    # TODO: do i need to wait?
}

sub ssh_file {
  my ($self, $file) = @_;

  if (!$self->{ssh_dir}) {
    mkdir "$ENV{HOME}/.ssh" or die "Could not mkdir $ENV{HOME}/.ssh: $!" unless -d "$ENV{HOME}/.ssh";
    chmod 0700, "$ENV{HOME}/.ssh";
    $self->{ssh_dir} = "$ENV{HOME}/.ssh";
  }

  return $self->{ssh_dir} unless $file;
  return join '/', $self->{ssh_dir}, $file;
}

sub _backup_name {
  POSIX::strftime($_[0]->{format} || '%d-%H', localtime);
}

sub _log {
  my $self = shift;
  my $min  = (localtime)[1];
  my $hour = (localtime)[2];

  return if $self->{silent};
  warn sprintf "[%02s:%02s] %s\n", $hour, $min, join ' ', @_;
}

sub _read {
  my ($self, $k) = @_;
  my $v = $self->{$k};
  $v = join ' ', @$v if ref $v eq 'ARRAY';
  local $| = 1;
  print $k;
  printf " ($v)", if $v;
  print ": ";
  $_ = ;
  chomp;
  $_ ||= $v;
}

sub _system {
  my ($self, $program, @options) = @_;

  for my $path (qw( /bin /usr/bin /usr/local/bin )) {
    next unless -x "$path/$program";
    $program = "$path/$program";
    last;
  }

  $self->_log(join ' ', map { length $_ ? $_ : '""' } $program, @options);
  system $program => @options;
}

sub run {
  my ($self, @args) = @_;
  my $action = 'help';
  my $i      = 0;

  while ($i < @args) {
    $self->{config}  = splice @args, $i, 1, () and next if -f $args[$i];
    $self->{verbose} = splice @args, $i, 1, () and next if $args[$i] =~ /^--?v/;
    $self->{silent}  = splice @args, $i, 1, () and next if $args[$i] =~ /^--?s/;
    $i++;
  }

  $action = shift @args if @args;
  $self->{config} ||= "$ENV{HOME}/.sibs.conf";

  if ($action eq 'setup') {
    $self->create_sibs_config until eval { $self->load_config };
    $self->_log("Created $self->{config}");
    $self->add_backup_host_to_ssh_config;
    $self->create_identity_file;
  }
  elsif ($action eq 'backup') {
    $self->load_config;
    $self->run_rsync;
    $self->run_sibs_remote('remote-archive', $self->{destination}->path, $self->_backup_name);
  }
  elsif ($action eq 'man') {
    exec perldoc => 'App::sibs';
  }
  elsif ($action eq 'remote-init') {
    $self->remote_add_pub_key(eval 'do { local $/;  }');
  }
  elsif ($action eq 'remote-archive') {
    my ($dir, $name) = @args;
    chdir $dir or die "Cannot chdir $dir: $!\n";
    $self->_system(rm => -r => $name) if -d $name;
    $self->_system(cp => "-al" => "incoming" => $name);
    $self->_system(touch => $name);
  }
  elsif ($action eq 'version') {
    require App::sibs;
    print App::sibs->VERSION, "\n";
  }
  elsif (!$ENV{HARNESS_IS_VERBOSE}) {
    print <<'    HELP';
    sibs man
    sibs setup
    sibs backup
    sibs version
    HELP
  }

  return 0;
}

exit +(bless {})->run(@ARGV) unless defined wantarray;
bless {};