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', predicate => 1);
  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     [ exists => [ qw(PSI) ],
  61       [ prop => 'PS', [ value => 'info' ], 'PSI' ],
  62       [ prop => 'PSI', [ value => 'mode' ], 'M' ] ] ],
  63   [ exists_path => [ qw(PS) ],
  64     [ exists => [ qw(PSI) ],
  65       [ prop => 'PS', [ value => 'info' ], 'PSI' ],
  66       [ prop => 'PSI', [ value => 'is_directory' ], [ value => 1 ] ] ] ],
  67   [ exists_path => [ qw(PS) ],
  68     [ exists => [ qw(PSI) ],
  69       [ prop => 'PS', [ value => 'info' ], 'PSI' ],
  70       [ prop => 'PSI', [ value => 'is_file' ], [ value => 1 ] ] ] ],
  71   [ is_directory => [ qw(PS) ],
  72     [ exists => [ qw(PSI) ],
  73       [ prop => 'PS', [ value => 'info' ], 'PSI' ],
  74       [ prop => 'PSI', [ value => 'is_directory' ], [ value => 1 ] ] ] ],
  75   [ is_file => [ qw(PS) ],
  76     [ exists => [ qw(PSI) ],
  77       [ prop => 'PS', [ value => 'info' ], 'PSI' ],
  78       [ prop => 'PSI', [ value => 'is_file' ], [ value => 1 ] ] ] ],
  79 );
  80
  81 %path_status = %protos;
  82
  83 sub paths_for_simple {
  84   join ' ', map $_->{PS}->bound_value->path, $solver->query(
  85     [ qw(PS) ], [ path_status => 'PS' ], @_
  86   )->results;
  87 }
  88
  89 is(paths_for_simple(), '.ssh .ssh/authorized_keys');
  90
  91 is(paths_for_simple([ is_directory => 'PS' ]), '.ssh');
  92
  93 is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys');
  94
  95 is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh');
  96
  97 $solver->add_rule(
  98   path_status_at => [ 'PS', 'P' ],
  99     [ path_status => 'PS' ],
 100     [ path => qw(PS P) ],
 101 );
 102 $solver->add_rule(
 103   path_status_at => [ 'PS', 'P' ],
 104     [ constrain => [] => sub { die "ARGH" } ]
 105 );
 106
 107 throws_ok {
 108   $solver->query(
 109     [ qw(PS) ],
 110       [ path_status_at => 'PS', [ value => '.ssh' ] ]
 111   )->results
 112 } qr/ARGH/;
 113
 114 delete $solver->rule_set->rules->{'path_status_at/2'};
 115
 116 $solver->add_rule(
 117   path_status_at => [ 'PS', 'P' ],
 118     [ path_status => 'PS' ],
 119     [ path => qw(PS P) ],
 120     [ 'cut' ],
 121 );
 122 $solver->add_rule(
 123   path_status_at => [ 'PS', 'P' ],
 124     [ constrain => [] => sub { die "ARGH" } ]
 125 );
 126
 127 my @res;
 128
 129 lives_ok {
 130   @res = $solver->query(
 131     [ qw(PS) ],
 132       [ path_status_at => 'PS', [ value => '.ssh' ] ]
 133   )->results
 134 };
 135
 136 is(join(' ', map $_->{PS}->bound_value->path, @res), '.ssh');
 137
 138 delete $solver->rule_set->rules->{'path_status_at/2'};
 139
 140 $solver->add_rule(
 141   path_status_at => [ 'PS', 'P' ],
 142     [ path_status => 'PS' ],
 143     [ path => qw(PS P) ],
 144     [ 'cut' ],
 145 );
 146
 147 my %ob_res;
 148
 149 $solver->add_rule(
 150   path_status_at => [ 'PS', 'P' ],
 151     [ observe => [ 'P' ],
 152         sub {
 153           my ($path) = $_[0];
 154           DX::Observer::FromCode->new(
 155             code => sub { (path_status => $ob_res{$path}) }
 156           )
 157         }
 158     ],
 159     [ path_status => 'PS' ],
 160     [ path => qw(PS P) ],
 161 );
 162
 163 %path_status = ();
 164
 165 $ob_res{'.ssh'} = $protos{'.ssh'};
 166
 167 sub paths_for {
 168   join ' ', map $_->{PS}->bound_value->path, $solver->query([ 'PS' ], @_)->results;
 169 }
 170
 171 is(
 172   paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]),
 173   '',
 174   'no .ssh entry'
 175 );
 176
 177 throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 178   qr/refused/;
 179
 180 $solver->{observation_policy} = sub { 1 };
 181
 182 is(
 183   paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]),
 184   '.ssh',
 185   'observation'
 186 );
 187
 188 is($path_status{'.ssh'}, $ob_res{'.ssh'});
 189
 190 delete $solver->{observation_policy};
 191
 192 lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
 193   'No observation required anymore';
 194
 195 $path_status{'.ssh/authorized_keys'} = $protos{'.ssh/authorized_keys'};
 196
 197 is(
 198   paths_for([ path_status => 'PS' ], [ not => [ is_directory => 'PS' ] ]),
 199   '.ssh/authorized_keys',
 200   'Negation'
 201 );
 202
 203 $solver->add_rule(@$_) for (
 204   [ directory_at => [ qw(PS P) ],
 205     [ path_status_at => qw(PS P) ],
 206     [ is_directory => 'PS' ] ],
 207 );
 208
 209 %path_status = ();
 210
 211 $ob_res{'.ssh'} = $empty{'.ssh'};
 212
 213 #%path_status = %protos;
 214
 215 $solver->{observation_policy} = sub { 1 };
 216
 217 sub dot_ssh_query {
 218   $solver->query([ 'PS' ], [ directory_at => 'PS' => [ value => '.ssh' ] ]);
 219 }
 220
 221 is_deeply(
 222   [ dot_ssh_query()->results ],
 223   []
 224 );
 225
 226 #::Dwarn(paths_for([ directory_at => 'PS', [ value => '.ssh' ] ]));
 227
 228 $solver->add_rule(@$_) for (
 229   [ is_directory => [ qw(PS) ],
 230     [ not => [ exists_path => 'PS' ] ],
 231     [ act => [ 'PS' ],
 232         sub {
 233           my ($ps_var) = @_;
 234           my ($id, $value) = ($ps_var->id, $ps_var->bound_value);
 235           DX::Action::FromCode->new(
 236             expect => sub {
 237               ($id => My::PathStatus->new(
 238                 path => $value->path,
 239                 info => My::PathStatusInfo->new(
 240                   is_directory => 1, mode => ''
 241                 )
 242               ))
 243             },
 244             perform => sub {
 245               $ob_res{$value->path} = $protos{$value->path};
 246               (path_status => $value);
 247             }
 248           )
 249         } ] ]
 250 );
 251
 252 %path_status = ();
 253
 254 @res = dot_ssh_query()->results;
 255
 256 is(scalar(@res),1,'Single result');
 257
 258 is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed');
 259
 260 ok(my $action = $res[0]->{PS}->action);
 261
 262 my ($type, $value) = $action->run;
 263
 264 $solver->facts->{$type}->remove_value($value);
 265
 266 ok(!$path_status{'.ssh'}, 'Empty retracted');
 267
 268 @res = dot_ssh_query()->results;
 269
 270 is(scalar(@res),1,'Single result');
 271
 272 is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');
 273
 274 ok(!$res[0]->{PS}->action, 'No action');
 275
 276 done_testing;