use FactRef objects to sanify action handling

[scpubgit/DKit.git] / t / dot_ssh.t

use strictures 1;
use Test::More;
use DX::Solver;
use DX::SetOver;
use DX::Observer::FromCode;
use DX::Action::FromCode;
use File::Spec;
use Test::Exception;

{
  package My::PathStatus;

  use Moo;

  has path => (is => 'ro', required => 1);
  has info => (is => 'ro', predicate => 1);

  package My::PathStatusInfo;

  use Moo;

  has is_directory => (is => 'ro', default => 0);
  has is_file => (is => 'ro', default => 0);
  has mode => (is => 'ro', required => 1);
}

@INC{qw(My/PathStatus.pm My/PathStatusInfo.pm)} = (__FILE__,__FILE__);

my %protos = (
  '.ssh' => My::PathStatus->new(
    path => '.ssh',
    info => My::PathStatusInfo->new(is_directory => 1, mode => '0755')
  ),
  '.ssh/authorized_keys' => My::PathStatus->new(
    path => '.ssh/authorized_keys',
    info => My::PathStatusInfo->new(is_file => 1, mode => '0644')
  ),
);

my %empty = (
  '.ssh' => My::PathStatus->new(
    path => '.ssh'
  ),
  '.ssh/authorized_keys' => My::PathStatus->new(
    path => '.ssh/authorized_keys'
  )
);

my %path_status;

my $solver = DX::Solver->new(
  facts => { path_status => DX::SetOver->new(
               over => 'path',
               values => \%path_status,
             ) },
);

$solver->add_rule(@$_) for (
  [ path_status => [ qw(PS) ],
    [ member_of => 'PS', \'path_status' ] ],
  [ path => [ qw(PS P) ],
    [ prop => 'PS', \'path', 'P' ] ],
  [ info_prop => [ qw(PS N V) ],
    [ exists => [ qw(PSI) ],
      [ prop => 'PS', \'info', 'PSI' ],
      [ prop => 'PSI', 'N', 'V' ] ] ],
  [ mode => [ qw(PS M) ],
    [ info_prop => 'PS', \'mode', 'M' ] ],
  [ exists_path => [ qw(PS) ],
    [ info_prop => 'PS', \'is_directory', \1 ] ],
  [ exists_path => [ qw(PS) ],
    [ info_prop => 'PS', \'is_file', \1 ] ],
  [ is_directory => [ qw(PS) ],
    [ info_prop => 'PS', \'is_directory', \1 ] ],
  [ is_file => [ qw(PS) ],
    [ info_prop => 'PS', \'is_file', \1 ] ],
);

%path_status = %protos;

sub paths_for_simple {
  join ' ', map $_->value_for('PS')->path, $solver->query(
    [ qw(PS) ], [ path_status => 'PS' ], @_
  )->results;
}

is(paths_for_simple(), '.ssh .ssh/authorized_keys');

is(paths_for_simple([ is_directory => 'PS' ]), '.ssh');

is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys');

is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh');

$solver->add_rule(
  path_status_at => [ 'PS', 'P' ],
    [ path_status => 'PS' ],
    [ path => qw(PS P) ],
);
$solver->add_rule(
  path_status_at => [ 'PS', 'P' ],
    [ constrain => [] => sub { die "ARGH" } ]
);

throws_ok {
  $solver->query(
    [ qw(PS) ],
      [ path_status_at => 'PS', [ value => '.ssh' ] ]
  )->results
} qr/ARGH/;

delete $solver->rule_set->rules->{'path_status_at/2'};

$solver->add_rule(
  path_status_at => [ 'PS', 'P' ],
    [ path_status => 'PS' ],
    [ path => qw(PS P) ],
    [ 'cut' ],
);
$solver->add_rule(
  path_status_at => [ 'PS', 'P' ],
    [ constrain => [] => sub { die "ARGH" } ]
);

my @res;

lives_ok {
  @res = $solver->query(
    [ qw(PS) ],
      [ path_status_at => 'PS', [ value => '.ssh' ] ]
  )->results
};

is(join(' ', map $_->value_for('PS')->path, @res), '.ssh');

delete $solver->rule_set->rules->{'path_status_at/2'};

$solver->add_rule(
  path_status_at => [ 'PS', 'P' ],
    [ path_status => 'PS' ],
    [ path => qw(PS P) ],
    [ 'cut' ],
);

my %ob_res;

$solver->add_rule(
  path_status_at => [ 'PS', 'P' ],
    [ observe => [ 'P' ],
        sub {
          my ($path) = $_[0];
          DX::Observer::FromCode->new(
            code => sub { (path_status => $ob_res{$path}) }
          )
        }
    ],
    [ path_status => 'PS' ],
    [ path => qw(PS P) ],
);

%path_status = ();

$ob_res{'.ssh'} = $protos{'.ssh'};

sub paths_for {
  join ' ', map $_->value_for('PS')->path, $solver->query([ 'PS' ], @_)->results;
}

is(
  paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]),
  '',
  'no .ssh entry'
);

throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
  qr/refused/;

$solver->{observation_policy} = sub { 1 };

is(
  paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]),
  '.ssh',
  'observation'
);

is($path_status{'.ssh'}, $ob_res{'.ssh'});

delete $solver->{observation_policy};

lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
  'No observation required anymore';

$path_status{'.ssh/authorized_keys'} = $protos{'.ssh/authorized_keys'};

is(
  paths_for([ path_status => 'PS' ], [ not => [ is_directory => 'PS' ] ]),
  '.ssh/authorized_keys',
  'Negation'
);

$solver->add_rule(@$_) for (
  [ directory_at => [ qw(PS P) ],
    [ path_status_at => qw(PS P) ],
    [ is_directory => 'PS' ] ],
  [ file_at => [ qw(PS P) ],
    [ path_status_at => qw(PS P) ],
    [ is_file => 'PS' ] ],
);

%path_status = ();

$ob_res{'.ssh'} = $empty{'.ssh'};

#%path_status = %protos;

$solver->{observation_policy} = sub { 1 };

sub dot_ssh_query {
  $solver->query([ 'PS' ], [ directory_at => 'PS' => [ value => '.ssh' ] ]);
}

is_deeply(
  [ dot_ssh_query()->results ],
  []
);

#::Dwarn(paths_for([ directory_at => 'PS', [ value => '.ssh' ] ]));

$solver->add_rule(@$_) for (
  [ is_directory => [ qw(PS) ],
    [ not => [ exists_path => 'PS' ] ],
    [ act => [ 'PS' ],
        sub {
          my ($value) = @_;
          DX::Action::FromCode->new(
            expect => sub {
              (path_status => My::PathStatus->new(
                path => $value->path,
                info => My::PathStatusInfo->new(
                  is_directory => 1, mode => ''
                )
              ))
            },
            perform => sub {
              $ob_res{$value->path} = $protos{$value->path};
              (path_status => $value);
            }
          )
        } ] ]
);

%path_status = ();

@res = dot_ssh_query()->results;

is(scalar(@res),1,'Single result');

is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed');

is(
  scalar(my ($action) = $res[0]->actions), 1
);

$solver->run_action($action);

ok(!$path_status{'.ssh'}, 'Empty retracted');

@res = dot_ssh_query()->results;

is(scalar(@res),1,'Single result');

is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');

ok(!$res[0]->actions, 'No action');

$solver->add_predicate(
  catfile => [ qw(DirPath FileName FilePath) ],
    [ qw(+ + -) ] => sub {
      +(FilePath => [ value => File::Spec->catfile($_{DirPath}, $_{FileName}) ])
    },
);

$solver->add_rule(@$_) for (
  [ file_in => [ qw(DirStatus FileName FileStatus) ],
    [ is_directory => qw(DirStatus) ],
    [ exists => [ qw(DirPath) ],
      [ path => qw(DirStatus DirPath) ],
      [ exists => [ qw(FilePath) ],
        [ catfile => qw(DirPath FileName FilePath) ],
        [ file_at => qw(FileStatus FilePath) ] ] ] ],
  [ is_file => [ qw(PS) ],
    [ not => [ exists_path => 'PS' ] ],
    [ act => [ 'PS' ],
        sub {
          my ($value) = @_;
          DX::Action::FromCode->new(
            expect => sub {
              (path_status => My::PathStatus->new(
                path => $value->path,
                info => My::PathStatusInfo->new(
                  is_file => 1, mode => ''
                )
              ))
            },
            perform => sub {
              $ob_res{$value->path} = $protos{$value->path};
              (path_status => $value);
            }
          )
        } ] ]
);

%path_status = ();
%ob_res = %empty;

sub keys_file {
  $solver->query([ qw(D F) ],
     [ directory_at => 'D' => \'.ssh' ],
     [ file_in => 'D' => \'authorized_keys' => 'F' ],
   );
}

@res = keys_file()->results;

is(scalar @res, 1, 'One result');

is(scalar(my @act = $res[0]->actions), 2, 'Two actions');

#::Dwarn(\@act);

is(scalar(my ($poss) = grep !@{$_->dependencies}, @act), 1, 'One possible');

$solver->run_action($poss);

@res = keys_file()->results;

is(scalar @res, 1, 'One result');

is(
  scalar(($poss) = grep !@{$_->dependencies}, $res[0]->actions), 1,
  'One possible'
);

$solver->run_action($poss);

@res = keys_file()->results;

is(scalar @res, 1, 'One result');

is(scalar($res[0]->actions), 0, 'No actions');

done_testing;