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 File::Spec;
   8 use Test::Exception;
   9
  10 {
  11   package My::PathStatus;
  12
  13   use Moo;
  14
  15   has path => (is => 'ro', required => 1);
  16   has info => (is => 'ro', predicate => 1);
  17
  18   package My::PathStatusInfo;
  19
  20   use Moo;
  21
  22   has is_directory => (is => 'ro', default => 0);
  23   has is_file => (is => 'ro', default => 0);
  24   has mode => (is => 'ro', required => 1);
  25 }
  26
  27 @INC{qw(My/PathStatus.pm My/PathStatusInfo.pm)} = (__FILE__,__FILE__);
  28
  29 my %protos = (
  30   '.ssh' => My::PathStatus->new(
  31     path => '.ssh',
  32     info => My::PathStatusInfo->new(is_directory => 1, mode => '0755')
  33   ),
  34   '.ssh/authorized_keys' => My::PathStatus->new(
  35     path => '.ssh/authorized_keys',
  36     info => My::PathStatusInfo->new(is_file => 1, mode => '0644')
  37   ),
  38 );
  39
  40 my %empty = (
  41   '.ssh' => My::PathStatus->new(
  42     path => '.ssh'
  43   ),
  44   '.ssh/authorized_keys' => My::PathStatus->new(
  45     path => '.ssh/authorized_keys'
  46   )
  47 );
  48
  49 my %path_status;
  50
  51 my $solver = DX::Solver->new(
  52   facts => { path_status => DX::SetOver->new(
  53                over => 'path',
  54                values => \%path_status,
  55              ) },
  56 );
  57
  58 $solver->add_rule(@$_) for (
  59   [ path_status => [ qw(PS) ],
  60     [ member_of => 'PS', \'path_status' ] ],
  61   [ path => [ qw(PS P) ],
  62     [ prop => 'PS', \'path', 'P' ] ],
  63   [ info_prop => [ qw(PS N V) ],
  64     [ exists => [ qw(PSI) ],
  65       [ prop => 'PS', \'info', 'PSI' ],
  66       [ prop => 'PSI', 'N', 'V' ] ] ],
  67   [ mode => [ qw(PS M) ],
  68     [ info_prop => 'PS', \'mode', 'M' ] ],
  69   [ exists_path => [ qw(PS) ],
  70     [ info_prop => 'PS', \'is_directory', \1 ] ],
  71   [ exists_path => [ qw(PS) ],
  72     [ info_prop => 'PS', \'is_file', \1 ] ],
  73   [ is_directory => [ qw(PS) ],
  74     [ info_prop => 'PS', \'is_directory', \1 ] ],
  75   [ is_file => [ qw(PS) ],
  76     [ info_prop => 'PS', \'is_file', \1 ] ],
  77 );
  78
  79 %path_status = %protos;
  80
  81 sub paths_for_simple {
  82   join ' ', map $_->value_for('PS')->path, $solver->query(
  83     [ qw(PS) ], [ path_status => 'PS' ], @_
  84   )->results;
  85 }
  86
  87 is(paths_for_simple(), '.ssh .ssh/authorized_keys');
  88
  89 is(paths_for_simple([ is_directory => 'PS' ]), '.ssh');
  90
  91 is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys');
  92
  93 is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh');
  94
  95 $solver->add_rule(
  96   path_status_at => [ 'PS', 'P' ],
  97     [ path_status => 'PS' ],
  98     [ path => qw(PS P) ],
  99 );
 100 $solver->add_rule(
 101   path_status_at => [ 'PS', 'P' ],
 102     [ constrain => [] => sub { die "ARGH" } ]
 103 );
 104
 105 throws_ok {
 106   $solver->query(
 107     [ qw(PS) ],
 108       [ path_status_at => 'PS', [ value => '.ssh' ] ]
 109   )->results
 110 } qr/ARGH/;
 111
 112 delete $solver->rule_set->rules->{'path_status_at/2'};
 113
 114 $solver->add_rule(
 115   path_status_at => [ 'PS', 'P' ],
 116     [ path_status => 'PS' ],
 117     [ path => qw(PS P) ],
 118     [ 'cut' ],
 119 );
 120 $solver->add_rule(
 121   path_status_at => [ 'PS', 'P' ],
 122     [ constrain => [] => sub { die "ARGH" } ]
 123 );
 124
 125 my @res;
 126
 127 lives_ok {
 128   @res = $solver->query(
 129     [ qw(PS) ],
 130       [ path_status_at => 'PS', [ value => '.ssh' ] ]
 131   )->results
 132 };
 133
 134 is(join(' ', map $_->value_for('PS')->path, @res), '.ssh');
 135
 136 delete $solver->rule_set->rules->{'path_status_at/2'};
 137
 138 $solver->add_rule(
 139   path_status_at => [ 'PS', 'P' ],
 140     [ path_status => 'PS' ],
 141     [ path => qw(PS P) ],
 142     [ 'cut' ],
 143 );
 144
 145 my %ob_res;
 146
 147 $solver->add_rule(
 148   path_status_at => [ 'PS', 'P' ],
 149     [ observe => [ 'P' ],
 150         sub {
 151           my ($path) = $_[0];
 152           DX::Observer::FromCode->new(
 153             code => sub { (path_status => $ob_res{$path}) }
 154           )
 155         }
 156     ],
 157     [ path_status => 'PS' ],
 158     [ path => qw(PS P) ],
 159 );
 160
 161 %path_status = ();
 162
 163 $ob_res{'.ssh'} = $protos{'.ssh'};
 164
 165 sub paths_for {
 166   join ' ', map $_->value_for('PS')->path, $solver->query([ 'PS' ], @_)->results;
 167 }
 168
 169 is(
 170   paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]),
 171   '',
 172   'no .ssh entry'
 173 );
 174
 175 throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 176   qr/refused/;
 177
 178 $solver->{observation_policy} = sub { 1 };
 179
 180 is(
 181   paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]),
 182   '.ssh',
 183   'observation'
 184 );
 185
 186 is($path_status{'.ssh'}, $ob_res{'.ssh'});
 187
 188 delete $solver->{observation_policy};
 189
 190 lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 191   'No observation required anymore';
 192
 193 $path_status{'.ssh/authorized_keys'} = $protos{'.ssh/authorized_keys'};
 194
 195 is(
 196   paths_for([ path_status => 'PS' ], [ not => [ is_directory => 'PS' ] ]),
 197   '.ssh/authorized_keys',
 198   'Negation'
 199 );
 200
 201 $solver->add_rule(@$_) for (
 202   [ directory_at => [ qw(PS P) ],
 203     [ path_status_at => qw(PS P) ],
 204     [ is_directory => 'PS' ] ],
 205   [ file_at => [ qw(PS P) ],
 206     [ path_status_at => qw(PS P) ],
 207     [ is_file => 'PS' ] ],
 208 );
 209
 210 %path_status = ();
 211
 212 $ob_res{'.ssh'} = $empty{'.ssh'};
 213
 214 #%path_status = %protos;
 215
 216 $solver->{observation_policy} = sub { 1 };
 217
 218 sub dot_ssh_query {
 219   $solver->query([ 'PS' ], [ directory_at => 'PS' => [ value => '.ssh' ] ]);
 220 }
 221
 222 is_deeply(
 223   [ dot_ssh_query()->results ],
 224   []
 225 );
 226
 227 #::Dwarn(paths_for([ directory_at => 'PS', [ value => '.ssh' ] ]));
 228
 229 $solver->add_rule(@$_) for (
 230   [ is_directory => [ qw(PS) ],
 231     [ not => [ exists_path => 'PS' ] ],
 232     [ act => [ 'PS' ],
 233         sub {
 234           my ($ps_var) = @_;
 235           my ($id, $value) = ($ps_var->id, $ps_var->bound_value);
 236           DX::Action::FromCode->new(
 237             expect => sub {
 238               ($id => My::PathStatus->new(
 239                 path => $value->path,
 240                 info => My::PathStatusInfo->new(
 241                   is_directory => 1, mode => ''
 242                 )
 243               ))
 244             },
 245             perform => sub {
 246               $ob_res{$value->path} = $protos{$value->path};
 247               (path_status => $value);
 248             }
 249           )
 250         } ] ]
 251 );
 252
 253 %path_status = ();
 254
 255 @res = dot_ssh_query()->results;
 256
 257 is(scalar(@res),1,'Single result');
 258
 259 is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed');
 260
 261 is(
 262   scalar(my ($action) = $res[0]->actions), 1
 263 );
 264
 265 $solver->run_action($action);
 266
 267 ok(!$path_status{'.ssh'}, 'Empty retracted');
 268
 269 @res = dot_ssh_query()->results;
 270
 271 is(scalar(@res),1,'Single result');
 272
 273 is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');
 274
 275 ok(!$res[0]->actions, 'No action');
 276
 277 $solver->add_predicate(
 278   catfile => [ qw(DirPath FileName FilePath) ],
 279     [ qw(+ + -) ] => sub {
 280       +(FilePath => [ value => File::Spec->catfile($_{DirPath}, $_{FileName}) ])
 281     },
 282 );
 283
 284 $solver->add_rule(@$_) for (
 285   [ file_in => [ qw(DirStatus FileName FileStatus) ],
 286     [ is_directory => qw(DirStatus) ],
 287     [ exists => [ qw(DirPath) ],
 288       [ path => qw(DirStatus DirPath) ],
 289       [ exists => [ qw(FilePath) ],
 290         [ catfile => qw(DirPath FileName FilePath) ],
 291         [ file_at => qw(FileStatus FilePath) ] ] ] ],
 292   [ is_file => [ qw(PS) ],
 293     [ not => [ exists_path => 'PS' ] ],
 294     [ act => [ 'PS' ],
 295         sub {
 296           my ($ps_var) = @_;
 297           my ($id, $value) = ($ps_var->id, $ps_var->bound_value);
 298           DX::Action::FromCode->new(
 299             expect => sub {
 300               ($id => My::PathStatus->new(
 301                 path => $value->path,
 302                 info => My::PathStatusInfo->new(
 303                   is_file => 1, mode => ''
 304                 )
 305               ))
 306             },
 307             perform => sub {
 308               $ob_res{$value->path} = $protos{$value->path};
 309               (path_status => $value);
 310             }
 311           )
 312         } ] ]
 313 );
 314
 315 %path_status = ();
 316 %ob_res = %empty;
 317
 318 sub keys_file {
 319   $solver->query([ qw(D F) ],
 320      [ directory_at => 'D' => \'.ssh' ],
 321      [ file_in => 'D' => \'authorized_keys' => 'F' ],
 322    );
 323 }
 324
 325 @res = keys_file()->results;
 326
 327 is(scalar @res, 1, 'One result');
 328
 329 is(scalar(my @act = $res[0]->actions), 2, 'Two actions');
 330
 331 is(scalar(my ($poss) = grep !@{$_->dependencies}, @act), 1, 'One possible');
 332
 333 $solver->run_action($poss);
 334
 335 @res = keys_file()->results;
 336
 337 is(scalar @res, 1, 'One result');
 338
 339 is(
 340   scalar(($poss) = grep !@{$_->dependencies}, $res[0]->actions), 1,
 341   'One possible'
 342 );
 343
 344 $solver->run_action($poss);
 345
 346 @res = keys_file()->results;
 347
 348 is(scalar @res, 1, 'One result');
 349
 350 is(scalar($res[0]->actions), 0, 'No actions');
 351
 352 done_testing;