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(scope => { %$scope })
  68           ->push_return_then($ret_op, $inner_op)
  69           ->assign_vars(%vars);
  70   };
  71 }
  72
  73 sub make_call {
  74   my ($predicate, @arg_spec) = @_;
  75   die "didn't invent or yet" unless @$predicate == 1;
  76   my ($option) = @$predicate;
  77   sub {
  78     my ($self, $state) = @_;
  79     my $scope = $state->scope;
  80     my $ret_op = FromCode->new(
  81       code => sub { $_[1]->but(scope => $scope, next_op => $_[0]->next) },
  82       next => $self->next,
  83     );
  84     my @args = map {
  85       my ($type, $val) = @$_;
  86       if ($type eq 'var') {
  87         $state->scope_var($val);
  88       } elsif ($type eq 'value') {
  89         $state->allocate_var('v', { bound_value => $val });
  90       } else {
  91         die "WTH";
  92       }
  93     } @arg_spec;
  94     my $next_op = FromCode->new(
  95       code => sub { $option->(@_, @args) },
  96       next => $pop_ret,
  97     );
  98     $state->but(scope => {})
  99           ->push_return_then($ret_op, $next_op);
 100   };
 101 }
 102
 103 sub make_state {
 104   my ($vars, $op) = @_;
 105
 106   DX::State->new(
 107     next_op => $op,
 108     return_stack => [],
 109     by_id => {},
 110     scope => {},
 111     last_choice => []
 112   )->assign_vars(map +($_ => {}), @$vars);
 113 }
 114
 115 $names{path_status} = [
 116   make_set_bind($path_status)
 117 ];
 118
 119 $names{path_exists} = [ make_test(
 120   sub { $_[0]->{is_directory} || $_[0]->{is_file} }
 121 ) ];
 122
 123 $names{is_directory} = [
 124   make_test(sub { $_[0]->bound_value->{is_directory} }),
 125 #  make_rule(
 126 #    [ 'D' ],
 127 #    make_not(make_call($names{path_exists}, [ var => 'D' ])),
 128 #    make_action(
 129 #      sub { +{ action => 'mkdir', path => $_[0]->{path}, is_directory => 1, perms => unknown() } },
 130 #      [ var => 'D' ]
 131 #    ),
 132 #  ),
 133 ];
 134
 135 $names{dot_ssh} = [ make_exists(
 136   [ 'D' ],
 137   make_call($names{path_status}, [ var => 'D' ], [ value => 't/scratch/.ssh' ]),
 138   make_call($names{is_directory}, [ var => 'D' ])
 139 ) ];
 140
 141 my $state = make_state([], FromCode->new(code => $names{dot_ssh}[0]));
 142
 143 is($state->run, undef, 'Failure with no path status');
 144
 145 $path_status->{'t/scratch/.ssh'} = { is_directory => 0 };
 146
 147 is($state->run, undef, 'Failure with non-directory');
 148
 149 $path_status->{'t/scratch/.ssh'} = { is_directory => 1 };
 150
 151 isa_ok($state->run, 'DX::State', 'Success with directory');
 152
 153 done_testing;