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