stop using return_stack directly in tests

[scpubgit/DKit.git] / t / ssh_key.t

use strictures 1;
use Test::More;
use Unknown::Values;
use List::Util qw(reduce);
use aliased 'DX::Op::FromCode';
use DX::Var;
use DX::State;

my $defs = <<'EOF';
[ssh-key-installed [keyline]
  [exists d
    [directory-at d [string t/scratch/.ssh]]
    [directory-perms d [string 0755]]]
  [exists f
    [file-at f [string t/scratch/.ssh/authorized_keys]]
    [file-perms f [string 0644]]
    [file-contains-line f keyline]]
]
EOF

my %names;

my $path_status = {};

sub make_set_bind {
  my ($set) = @_;
  sub {
    my ($self, $state, $thing, $key) = @_;
    die "key unbound" unless $key->is_bound;
    die "thing bound" if $thing->is_bound;
    if (my $value = $set->{$key->bound_value}) {
      return $state->bind_var_then($thing, $value, $self->next);
    }
    return $state->backtrack;
  }
}

sub make_test {
  my ($test) = @_;
  sub {
    my ($self, $state, @args) = @_;
    if ($test->(@args)) {
      return $state->then($self->next);
    }
    return $state->backtrack;
  }
}

my $pop_ret = FromCode->new(code => sub { $_[1]->pop_return_stack });

sub link_ops {
  my @to_link = @_;
  reduce { FromCode->new(next => $a, code => $b) } $pop_ret, reverse @to_link;
}

sub make_exists {
  my ($var_names, @body) = @_;
  my %vars = map +($_ => {}), @$var_names;
  my $inner_op = link_ops(@body);
  sub {
    my ($self, $state) = @_;
    my $scope = $state->scope;
    my $ret_op = FromCode->new(
      code => sub { $_[1]->but(scope => $scope, next_op => $_[0]->next) },
      next => $self->next,
    );
    $state->but(scope => { %$scope })
          ->push_return_then($ret_op, $inner_op)
          ->assign_vars(%vars);
  };
}

sub make_call {
  my ($predicate, @arg_spec) = @_;
  die "didn't invent or yet" unless @$predicate == 1;
  my ($option) = @$predicate;
  sub {
    my ($self, $state) = @_;
    my $scope = $state->scope;
    my $ret_op = FromCode->new(
      code => sub { $_[1]->but(scope => $scope, next_op => $_[0]->next) },
      next => $self->next,
    );
    my @args = map {
      my ($type, $val) = @$_;
      if ($type eq 'var') {
        $state->scope_var($val);
      } elsif ($type eq 'value') {
        $state->allocate_var('v', { bound_value => $val });
      } else {
        die "WTH";
      }
    } @arg_spec;
    my $next_op = FromCode->new(
      code => sub { $option->(@_, @args) },
      next => $pop_ret,
    );
    $state->but(scope => {})
          ->push_return_then($ret_op, $next_op);
  };
}

sub make_state {
  my ($vars, $op) = @_;

  DX::State->new(
    next_op => $op,
    return_stack => [],
    by_id => {},
    scope => {},
    last_choice => []
  )->assign_vars(map +($_ => {}), @$vars);
}

$names{path_status} = [
  make_set_bind($path_status)
];

$names{path_exists} = [ make_test(
  sub { $_[0]->{is_directory} || $_[0]->{is_file} }
) ];

$names{is_directory} = [
  make_test(sub { $_[0]->bound_value->{is_directory} }),
#  make_rule(
#    [ 'D' ],
#    make_not(make_call($names{path_exists}, [ var => 'D' ])),
#    make_action(
#      sub { +{ action => 'mkdir', path => $_[0]->{path}, is_directory => 1, perms => unknown() } },
#      [ var => 'D' ]
#    ),
#  ),
];

$names{dot_ssh} = [ make_exists(
  [ 'D' ],
  make_call($names{path_status}, [ var => 'D' ], [ value => 't/scratch/.ssh' ]),
  make_call($names{is_directory}, [ var => 'D' ])
) ];

my $state = make_state([], FromCode->new(code => $names{dot_ssh}[0]));

is($state->run, undef, 'Failure with no path status');

$path_status->{'t/scratch/.ssh'} = { is_directory => 0 };

is($state->run, undef, 'Failure with non-directory');

$path_status->{'t/scratch/.ssh'} = { is_directory => 1 };

isa_ok($state->run, 'DX::State', 'Success with directory');

done_testing;