From: Matt S Trout Date: Mon, 27 Jan 2014 10:21:59 +0000 (+0000) Subject: ssh key sketch test X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FDKit.git;a=commitdiff_plain;h=b373788e29bdee028a124201fd1c2ca85f02ac48 ssh key sketch test --- diff --git a/lib/DX/State.pm b/lib/DX/State.pm index 7ec2e1b..b4ad233 100644 --- a/lib/DX/State.pm +++ b/lib/DX/State.pm @@ -2,6 +2,7 @@ package DX::State; use Return::MultiLevel qw(with_return); use DX::Op::FromCode; +use Scalar::Util qw(blessed); use Moo; has next_op => (is => 'ro', required => 1); @@ -14,11 +15,35 @@ has scope => (is => 'ro', required => 1); has last_choice => (is => 'ro', required => 1); +has id_gen => (is => 'ro', default => sub { {} }); + sub scope_var { my ($self, $name) = @_; $self->by_id->{$self->scope->{$name}}; } +sub allocate_var { + my ($self, $name, $var) = @_; + my $id = join('_', $name, ++($self->id_gen->{$name})); + DX::Var->new(id => $id, %$var); +} + +sub assign_vars { + my ($self, %vars) = @_; + my %by_id = %{$self->by_id}; + foreach my $name (keys %vars) { +warn "assign: ${name}"; + unless (blessed($vars{$name})) { + my $var = $vars{$name} = $self->allocate_var($name, $vars{$name}); + $by_id{$var->id} = $var; + } + } + $self->but( + by_id => \%by_id, + scope => { %{$self->scope}, map +($_ => $vars{$_}->id), keys %vars } + ); +} + sub bind_var_then { my ($self, $var, $value, $then) = @_; warn "Binding ".$var->id." to $value"; @@ -70,6 +95,7 @@ sub run { my ($return) = @_; local our $Nonlocal_Return = $return; while (my $op = $state->next_op) { +#::Dwarn($op); $state = $op->run($state); } return $state; diff --git a/lib/DX/Var.pm b/lib/DX/Var.pm index a711f98..eafa895 100644 --- a/lib/DX/Var.pm +++ b/lib/DX/Var.pm @@ -6,10 +6,15 @@ has id => (is => 'ro', required => 1); has bound_stream => (is => 'ro'); -has bound_value => (is => 'lazy', clearer => 1, builder => sub { +has bound_value => (is => 'lazy', predicate => 1, clearer => 1, builder => sub { $_[0]->bound_stream->next; }); +sub is_bound { + my ($self) = @_; + $self->has_bound_value || $self->bound_stream; +} + sub with_stream { my ($self, $stream) = @_; $self->new(%$self, bound_stream => $stream); diff --git a/t/ssh_key.t b/t/ssh_key.t new file mode 100644 index 0000000..8d8d5c9 --- /dev/null +++ b/t/ssh_key.t @@ -0,0 +1,157 @@ +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 }, + return_stack => [ @{$state->return_stack}, $ret_op ], + next_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; + $state->but( + scope => {}, + return_stack => [ @{$state->return_stack}, $ret_op ], + next_op => FromCode->new( + code => sub { $option->(@_, @args) }, + next => $pop_ret, + ), + ); + }; +} + +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;