t/dot_ssh.t

   1 use strictures 1;
   2 use Test::More;
   3 use DX::Solver;
   4 use DX::SetOver;
   5 use DX::Observer::FromCode;
   6 use Test::Exception;
   7
   8 {
   9   package My::PathStatus;
  10
  11   use Moo;
  12
  13   has path => (is => 'ro', required => 1);
  14   has info => (is => 'ro', required => 1);
  15
  16   package My::PathStatusInfo;
  17
  18   use Moo;
  19
  20   has is_directory => (is => 'ro', default => 0);
  21   has is_file => (is => 'ro', default => 0);
  22   has mode => (is => 'ro', required => 1);
  23 }
  24
  25 @INC{qw(My/PathStatus.pm My/PathStatusInfo.pm)} = (__FILE__,__FILE__);
  26
  27 my %protos = (
  28   '.ssh' => My::PathStatus->new(
  29     path => '.ssh',
  30     info => My::PathStatusInfo->new(is_directory => 1, mode => '0755')
  31   ),
  32   '.ssh/authorized_keys' => My::PathStatus->new(
  33     path => '.ssh/authorized_keys',
  34     info => My::PathStatusInfo->new(is_file => 1, mode => '0644')
  35   ),
  36 );
  37
  38 my %path_status;
  39
  40 my $solver = DX::Solver->new(
  41   facts => { path_status => DX::SetOver->new(
  42                over => 'path',
  43                values => \%path_status,
  44              ) },
  45 );
  46
  47 $solver->add_rule(@$_) for (
  48   [ path_status => [ qw(PS) ],
  49     [ member_of => 'PS', [ value => 'path_status' ] ] ],
  50   [ path => [ qw(PS P) ],
  51     [ constrain => [ qw(PS P) ], sub { $_[0]->path eq $_[1] } ] ],
  52   [ mode => [ qw(PS M) ],
  53     [ constrain => [ qw(PS M) ],
  54        sub { $_[0]->info and $_[0]->info->mode eq $_[1] } ] ],
  55   [ is_directory => [ qw(PS) ],
  56     [ constrain => [ qw(PS) ],
  57         sub { $_[0]->info and $_[0]->info->is_directory } ] ],
  58   [ is_file => [ qw(PS) ],
  59     [ constrain => [ qw(PS) ],
  60         sub { $_[0]->info and $_[0]->info->is_file } ] ],
  61 );
  62
  63 %path_status = %protos;
  64
  65 sub paths_for_simple {
  66   join ' ', map $_->{PS}->path, $solver->query(
  67     [ qw(PS) ], [ path_status => 'PS' ], @_
  68   )->results;
  69 }
  70
  71 is(paths_for_simple(), '.ssh .ssh/authorized_keys');
  72
  73 is(paths_for_simple([ is_directory => 'PS' ]), '.ssh');
  74
  75 is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys');
  76
  77 is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh');
  78
  79 $solver->add_rule(
  80   path_status_at => [ 'PS', 'P' ],
  81     [ path_status => 'PS' ],
  82     [ path => qw(PS P) ],
  83 );
  84 $solver->add_rule(
  85   path_status_at => [ 'PS', 'P' ],
  86     [ constrain => [] => sub { die "ARGH" } ]
  87 );
  88
  89 throws_ok {
  90   $solver->query(
  91     [ qw(PS) ],
  92       [ path_status_at => 'PS', [ value => '.ssh' ] ]
  93   )->results
  94 } qr/ARGH/;
  95
  96 delete $solver->rule_set->rules->{'path_status_at/2'};
  97
  98 $solver->add_rule(
  99   path_status_at => [ 'PS', 'P' ],
 100     [ path_status => 'PS' ],
 101     [ path => qw(PS P) ],
 102     [ 'cut' ],
 103 );
 104 $solver->add_rule(
 105   path_status_at => [ 'PS', 'P' ],
 106     [ constrain => [] => sub { die "ARGH" } ]
 107 );
 108
 109 my @res;
 110
 111 lives_ok {
 112   @res = $solver->query(
 113     [ qw(PS) ],
 114       [ path_status_at => 'PS', [ value => '.ssh' ] ]
 115   )->results
 116 };
 117
 118 is(join(' ', map $_->{PS}->path, @res), '.ssh');
 119
 120 delete $solver->rule_set->rules->{'path_status_at/2'};
 121
 122 $solver->add_rule(
 123   path_status_at => [ 'PS', 'P' ],
 124     [ path_status => 'PS' ],
 125     [ path => qw(PS P) ],
 126     [ 'cut' ],
 127 );
 128
 129 my %ob_res;
 130
 131 $solver->add_rule(
 132   path_status_at => [ 'PS', 'P' ],
 133     [ observe => [ 'P' ],
 134         sub {
 135           my ($path) = $_[0];
 136           DX::Observer::FromCode->new(
 137             code => sub { (path_status => $ob_res{$path}) }
 138           )
 139         }
 140     ],
 141     [ path_status => 'PS' ],
 142     [ path => qw(PS P) ],
 143 );
 144
 145 %path_status = ('.ssh/authorized_keys' => $protos{'.ssh/authorized_keys'});
 146
 147 $ob_res{'.ssh'} = $protos{'.ssh'};
 148
 149 sub paths_for {
 150   join ' ', map $_->{PS}->path, $solver->query([ 'PS' ], @_)->results;
 151 }
 152
 153 is(
 154   paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]),
 155   '',
 156   'no .ssh entry'
 157 );
 158
 159 throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 160   qr/refused/;
 161
 162 $solver->{observation_policy} = sub { 1 };
 163
 164 is(
 165   paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]),
 166   '.ssh',
 167   'observation'
 168 );
 169
 170 is($path_status{'.ssh'}, $ob_res{'.ssh'});
 171
 172 delete $solver->{observation_policy};
 173
 174 lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 175   'No observation required anymore';
 176
 177 done_testing;