t/ssh_key.t

   1 use strictures 1;
   2 use Test::More;
   3 use List::Util qw(reduce);
   4 use aliased 'DX::Op::FromCode';
   5 use DX::Var;
   6 use DX::State;
   7
   8 my $defs = <<'EOF';
   9 [ssh-key-installed [keyline]
  10   [exists d
  11     [directory-at d [string t/scratch/.ssh]]
  12     [directory-perms d [string 0755]]]
  13   [exists f
  14     [file-at f [string t/scratch/.ssh/authorized_keys]]
  15     [file-perms f [string 0644]]
  16     [file-contains-line f keyline]]
  17 ]
  18 EOF
  19
  20 my %names;
  21
  22 my $path_status = {};
  23
  24 sub make_set_bind {
  25   my ($set) = @_;
  26   sub {
  27     my ($self, $state, $thing, $key) = @_;
  28     die "key unbound" unless $key->is_bound;
  29     die "thing bound" if $thing->is_bound;
  30     if (my $value = $set->{$key->bound_value}) {
  31       return $state->bind_value($thing, $value)->then($self->next);
  32     }
  33     return $state->backtrack;
  34   }
  35 }
  36
  37 sub make_test {
  38   my ($test) = @_;
  39   sub {
  40     my ($self, $state, @args) = @_;
  41     if ($test->(@args)) {
  42       return $state->then($self->next);
  43     }
  44     return $state->backtrack;
  45   }
  46 }
  47
  48 my $pop_ret = FromCode->new(code => sub { $_[1]->pop_return_stack });
  49
  50 sub link_ops {
  51   my @to_link = @_;
  52   reduce { FromCode->new(next => $a, code => $b) } $pop_ret, reverse @to_link;
  53 }
  54
  55 sub make_exists {
  56   my ($var_names, @body) = @_;
  57   my %vars = map +($_ => {}), @$var_names;
  58   my $inner_op = link_ops(@body);
  59   sub {
  60     my ($self, $state) = @_;
  61     my $scope = $state->scope;
  62     my $ret_op = FromCode->new(
  63       code => sub { $_[1]->but(scope => $scope, next_op => $_[0]->next) },
  64       next => $self->next,
  65     );
  66     $state->but(scope => { %$scope })
  67           ->push_return_then($ret_op, $inner_op)
  68           ->assign_vars(%vars);
  69   };
  70 }
  71
  72 sub make_call {
  73   my ($predicate, @arg_spec) = @_;
  74   die "didn't invent or yet" unless @$predicate == 1;
  75   my ($option) = @$predicate;
  76   sub {
  77     my ($self, $state) = @_;
  78     my $scope = $state->scope;
  79     my $ret_op = FromCode->new(
  80       code => sub { $_[1]->but(scope => $scope, next_op => $_[0]->next) },
  81       next => $self->next,
  82     );
  83     my @args = map {
  84       my ($type, $val) = @$_;
  85       if ($type eq 'var') {
  86         $state->scope_var($val);
  87       } elsif ($type eq 'value') {
  88         $state->allocate_var('v', { bound_value => $val });
  89       } else {
  90         die "WTH";
  91       }
  92     } @arg_spec;
  93     my $next_op = FromCode->new(
  94       code => sub { $option->(@_, @args) },
  95       next => $pop_ret,
  96     );
  97     $state->but(scope => {})
  98           ->push_return_then($ret_op, $next_op);
  99   };
 100 }
 101
 102 sub make_state {
 103   my ($vars, $op) = @_;
 104
 105   DX::State->new(
 106     next_op => $op,
 107     return_stack => [],
 108     by_id => {},
 109     scope => {},
 110     last_choice => []
 111   )->assign_vars(map +($_ => {}), @$vars);
 112 }
 113
 114 $names{path_status} = [
 115   make_set_bind($path_status)
 116 ];
 117
 118 $names{path_exists} = [ make_test(
 119   sub { $_[0]->{is_directory} || $_[0]->{is_file} }
 120 ) ];
 121
 122 $names{is_directory} = [
 123   make_test(sub { $_[0]->bound_value->{is_directory} }),
 124 #  make_rule(
 125 #    [ 'D' ],
 126 #    make_not(make_call($names{path_exists}, [ var => 'D' ])),
 127 #    make_action(
 128 #      sub { +{ action => 'mkdir', path => $_[0]->{path}, is_directory => 1, perms => unknown() } },
 129 #      [ var => 'D' ]
 130 #    ),
 131 #  ),
 132 ];
 133
 134 $names{dot_ssh} = [ make_exists(
 135   [ 'D' ],
 136   make_call($names{path_status}, [ var => 'D' ], [ value => 't/scratch/.ssh' ]),
 137   make_call($names{is_directory}, [ var => 'D' ])
 138 ) ];
 139
 140 my $state = make_state([], FromCode->new(code => $names{dot_ssh}[0]));
 141
 142 is($state->run, undef, 'Failure with no path status');
 143
 144 $path_status->{'t/scratch/.ssh'} = { is_directory => 0 };
 145
 146 is($state->run, undef, 'Failure with non-directory');
 147
 148 $path_status->{'t/scratch/.ssh'} = { is_directory => 1 };
 149
 150 isa_ok($state->run, 'DX::State', 'Success with directory');
 151
 152 done_testing;