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 DX::Action::FromCode;
   7 use Test::Exception;
   8
   9 {
  10   package My::PathStatus;
  11
  12   use Moo;
  13
  14   has path => (is => 'ro', required => 1);
  15   has info => (is => 'ro');
  16
  17   package My::PathStatusInfo;
  18
  19   use Moo;
  20
  21   has is_directory => (is => 'ro', default => 0);
  22   has is_file => (is => 'ro', default => 0);
  23   has mode => (is => 'ro', required => 1);
  24 }
  25
  26 @INC{qw(My/PathStatus.pm My/PathStatusInfo.pm)} = (__FILE__,__FILE__);
  27
  28 my %protos = (
  29   '.ssh' => My::PathStatus->new(
  30     path => '.ssh',
  31     info => My::PathStatusInfo->new(is_directory => 1, mode => '0755')
  32   ),
  33   '.ssh/authorized_keys' => My::PathStatus->new(
  34     path => '.ssh/authorized_keys',
  35     info => My::PathStatusInfo->new(is_file => 1, mode => '0644')
  36   ),
  37 );
  38
  39 my %empty = (
  40   '.ssh' => My::PathStatus->new(
  41     path => '.ssh'
  42   )
  43 );
  44
  45 my %path_status;
  46
  47 my $solver = DX::Solver->new(
  48   facts => { path_status => DX::SetOver->new(
  49                over => 'path',
  50                values => \%path_status,
  51              ) },
  52 );
  53
  54 $solver->add_rule(@$_) for (
  55   [ path_status => [ qw(PS) ],
  56     [ member_of => 'PS', [ value => 'path_status' ] ] ],
  57   [ path => [ qw(PS P) ],
  58     [ prop => 'PS', [ value => 'path' ], 'P' ] ],
  59   [ mode => [ qw(PS M) ],
  60     [ constrain => [ qw(PS M) ],
  61         sub { $_[0]->info and $_[0]->info->mode eq $_[1] } ] ],
  62   [ exists_path => [ qw(PS) ],
  63     [ constrain => [ qw(PS) ],
  64         sub {
  65           $_[0]->info and ($_[0]->info->is_directory or $_[0]->info->is_file)
  66         } ] ],
  67   [ is_directory => [ qw(PS) ],
  68     [ constrain => [ qw(PS) ],
  69         sub { $_[0]->info and $_[0]->info->is_directory } ] ],
  70   [ is_file => [ qw(PS) ],
  71     [ constrain => [ qw(PS) ],
  72         sub { $_[0]->info and $_[0]->info->is_file } ] ],
  73 );
  74
  75 %path_status = %protos;
  76
  77 sub paths_for_simple {
  78   join ' ', map $_->{PS}->bound_value->path, $solver->query(
  79     [ qw(PS) ], [ path_status => 'PS' ], @_
  80   )->results;
  81 }
  82
  83 is(paths_for_simple(), '.ssh .ssh/authorized_keys');
  84
  85 is(paths_for_simple([ is_directory => 'PS' ]), '.ssh');
  86
  87 is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys');
  88
  89 is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh');
  90
  91 $solver->add_rule(
  92   path_status_at => [ 'PS', 'P' ],
  93     [ path_status => 'PS' ],
  94     [ path => qw(PS P) ],
  95 );
  96 $solver->add_rule(
  97   path_status_at => [ 'PS', 'P' ],
  98     [ constrain => [] => sub { die "ARGH" } ]
  99 );
 100
 101 throws_ok {
 102   $solver->query(
 103     [ qw(PS) ],
 104       [ path_status_at => 'PS', [ value => '.ssh' ] ]
 105   )->results
 106 } qr/ARGH/;
 107
 108 delete $solver->rule_set->rules->{'path_status_at/2'};
 109
 110 $solver->add_rule(
 111   path_status_at => [ 'PS', 'P' ],
 112     [ path_status => 'PS' ],
 113     [ path => qw(PS P) ],
 114     [ 'cut' ],
 115 );
 116 $solver->add_rule(
 117   path_status_at => [ 'PS', 'P' ],
 118     [ constrain => [] => sub { die "ARGH" } ]
 119 );
 120
 121 my @res;
 122
 123 lives_ok {
 124   @res = $solver->query(
 125     [ qw(PS) ],
 126       [ path_status_at => 'PS', [ value => '.ssh' ] ]
 127   )->results
 128 };
 129
 130 is(join(' ', map $_->{PS}->bound_value->path, @res), '.ssh');
 131
 132 delete $solver->rule_set->rules->{'path_status_at/2'};
 133
 134 $solver->add_rule(
 135   path_status_at => [ 'PS', 'P' ],
 136     [ path_status => 'PS' ],
 137     [ path => qw(PS P) ],
 138     [ 'cut' ],
 139 );
 140
 141 my %ob_res;
 142
 143 $solver->add_rule(
 144   path_status_at => [ 'PS', 'P' ],
 145     [ observe => [ 'P' ],
 146         sub {
 147           my ($path) = $_[0];
 148           DX::Observer::FromCode->new(
 149             code => sub { (path_status => $ob_res{$path}) }
 150           )
 151         }
 152     ],
 153     [ path_status => 'PS' ],
 154     [ path => qw(PS P) ],
 155 );
 156
 157 %path_status = ();
 158
 159 $ob_res{'.ssh'} = $protos{'.ssh'};
 160
 161 sub paths_for {
 162   join ' ', map $_->{PS}->bound_value->path, $solver->query([ 'PS' ], @_)->results;
 163 }
 164
 165 is(
 166   paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]),
 167   '',
 168   'no .ssh entry'
 169 );
 170
 171 throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 172   qr/refused/;
 173
 174 $solver->{observation_policy} = sub { 1 };
 175
 176 is(
 177   paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]),
 178   '.ssh',
 179   'observation'
 180 );
 181
 182 is($path_status{'.ssh'}, $ob_res{'.ssh'});
 183
 184 delete $solver->{observation_policy};
 185
 186 lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 187   'No observation required anymore';
 188
 189 $path_status{'.ssh/authorized_keys'} = $protos{'.ssh/authorized_keys'};
 190
 191 is(
 192   paths_for([ path_status => 'PS' ], [ not => [ is_directory => 'PS' ] ]),
 193   '.ssh/authorized_keys',
 194   'Negation'
 195 );
 196
 197 $solver->add_rule(@$_) for (
 198   [ directory_at => [ qw(PS P) ],
 199     [ path_status_at => qw(PS P) ],
 200     [ is_directory => 'PS' ] ],
 201 );
 202
 203 %path_status = ();
 204
 205 $ob_res{'.ssh'} = $empty{'.ssh'};
 206
 207 #%path_status = %protos;
 208
 209 $solver->{observation_policy} = sub { 1 };
 210
 211 sub dot_ssh_query {
 212   $solver->query([ 'PS' ], [ directory_at => 'PS' => [ value => '.ssh' ] ]);
 213 }
 214
 215 is_deeply(
 216   [ dot_ssh_query()->results ],
 217   []
 218 );
 219
 220 #::Dwarn(paths_for([ directory_at => 'PS', [ value => '.ssh' ] ]));
 221
 222 $solver->add_rule(@$_) for (
 223   [ is_directory => [ qw(PS) ],
 224     [ not => [ exists_path => 'PS' ] ],
 225     [ act => [ 'PS' ],
 226         sub {
 227           my ($ps_var) = @_;
 228           my ($id, $value) = ($ps_var->id, $ps_var->bound_value);
 229           DX::Action::FromCode->new(
 230             expect => sub {
 231               ($id => My::PathStatus->new(
 232                 path => $value->path,
 233                 info => My::PathStatusInfo->new(
 234                   is_directory => 1, mode => ''
 235                 )
 236               ))
 237             },
 238             perform => sub {
 239               $ob_res{$value->path} = $protos{$value->path};
 240               (path_status => $value);
 241             }
 242           )
 243         } ] ]
 244 );
 245
 246 %path_status = ();
 247
 248 @res = dot_ssh_query()->results;
 249
 250 is(scalar(@res),1,'Single result');
 251
 252 is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed');
 253
 254 ok(my $action = $res[0]->{PS}->action);
 255
 256 my ($type, $value) = $action->run;
 257
 258 $solver->facts->{$type}->remove_value($value);
 259
 260 ok(!$path_status{'.ssh'}, 'Empty retracted');
 261
 262 @res = dot_ssh_query()->results;
 263
 264 is(scalar(@res),1,'Single result');
 265
 266 is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');
 267
 268 ok(!$res[0]->{PS}->action, 'No action');
 269
 270 done_testing;