t/ssh_key.t

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