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