From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 8 Feb 2014 22:33:10 +0000 (+0000)
Subject: acion infrastructure
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=deec7cc438aebbe1d3488f24f0c368821e0993ba;p=scpubgit%2FDKit.git

acion infrastructure
---

diff --git a/lib/DX/Action/FromCode.pm b/lib/DX/Action/FromCode.pm
index 88e8b27..339e8a9 100644
--- a/lib/DX/Action/FromCode.pm
+++ b/lib/DX/Action/FromCode.pm
@@ -6,7 +6,11 @@ has expect => (is => 'ro', required => 1);
 
 has perform => (is => 'ro', required => 1);
 
+has dependencies => (is => 'ro', default => sub { [] });
+
 sub expected_effect { $_[0]->expect->() }
 sub run { $_[0]->perform->() }
 
+sub but { my ($self, @but) = @_; ref($self)->new(%$self, @but); }
+
 1;
diff --git a/lib/DX/Op/Exists.pm b/lib/DX/Op/Exists.pm
new file mode 100644
index 0000000..a7758dd
--- /dev/null
+++ b/lib/DX/Op/Exists.pm
@@ -0,0 +1,21 @@
+package DX::Op::Exists;
+
+use DX::Op::SetScope;
+use Moo;
+
+has vars => (is => 'ro', required => 1);
+has body => (is => 'ro', required => 1);
+
+with 'DX::Role::Op';
+
+sub run {
+  my ($self, $state) = @_;
+  my $ret_op = DX::Op::SetScope->new(
+    scope => $state->scope,
+    next => $self->next
+  );
+  $state->assign_vars(map +($_ => {}), @{$self->vars})
+        ->push_return_then($ret_op, $self->body);
+}
+
+1;
diff --git a/lib/DX/Op/MemberOf.pm b/lib/DX/Op/MemberOf.pm
index 7da83b8..4493620 100644
--- a/lib/DX/Op/MemberOf.pm
+++ b/lib/DX/Op/MemberOf.pm
@@ -17,7 +17,8 @@ sub run {
   my ($member, $of) = @args{qw(member of)};
   die "member bound" if $member->is_bound;
   my $set = $state->facts->{$of->bound_value};
-  return $state->bind_root_set_then($member->id, $set, $self->next);
+  return $state->bind_root_set_then($member->id, $set, $self->next)
+               ->add_dependencies($member->id, $of->id);
 }
 
 1;
diff --git a/lib/DX/Op/Prop.pm b/lib/DX/Op/Prop.pm
index 2f6a9fe..bacdf7c 100644
--- a/lib/DX/Op/Prop.pm
+++ b/lib/DX/Op/Prop.pm
@@ -18,7 +18,11 @@ sub run {
   if ($args{of}->is_bound) {
     if ($args{value}->is_bound) {
       if ($args{of}->bound_value->$name eq $args{value}->bound_value) {
-        return $state->then($self->next);
+        return $state->add_dependencies(
+                         $args{of}->id => $args{value}->id,
+                         $args{value}->id => $args{of}->id,
+                       )
+                     ->then($self->next);
       }
       return $state->backtrack;
     }
@@ -26,7 +30,9 @@ sub run {
     if ($value->can("has_${name}") and not $value->${\"has_${name}"}) {
       return $state->backtrack;
     }
-    return $state->bind_value($args{value}->id, $value->$name);
+    return $state->bind_value($args{value}->id, $value->$name)
+                 ->add_dependencies($args{value}->id => $args{of}->id)
+                 ->then($self->next);
   }
   die "Can't yet handle unbound 'of' argument";
 }
diff --git a/lib/DX/Op/ProposeAction.pm b/lib/DX/Op/ProposeAction.pm
index ca9c38d..7031b4f 100644
--- a/lib/DX/Op/ProposeAction.pm
+++ b/lib/DX/Op/ProposeAction.pm
@@ -18,7 +18,9 @@ sub run {
   my ($self, $state) = @_;
   ($state, my %args) = $self->_expand_args($state, %{$self->_arg_map});
   my @vars = @args{sort keys %args};
-  my $action = $self->builder->(@vars);
+  my @deps = $state->action_dependencies(map $_->id, @vars);
+  my $action = $self->builder->(@vars)
+                    ->but(dependencies => \@deps);
   my ($id, $value) = $action->expected_effect;
   my $var = $state->by_id->{$id}->with_value($value)->with_action($action);
   $state->but(by_id => { %{$state->by_id}, $id => $var })
diff --git a/lib/DX/Result.pm b/lib/DX/Result.pm
new file mode 100644
index 0000000..008ea73
--- /dev/null
+++ b/lib/DX/Result.pm
@@ -0,0 +1,28 @@
+package DX::Result;
+
+use Moo;
+
+has _state => (is => 'ro', required => 1, init_arg => 'state');
+
+sub var_names {
+  sort keys %{$_[0]->_state->scope};
+}
+
+sub actions {
+  my ($self) = @_;
+  my $by_id = $self->_state->by_id;
+  return map $_->action, grep $_->has_action, values %$by_id;
+}
+
+sub dependent_actions {
+  my ($self, $action) = @_;
+  my $by_id = $self->_state->by_id;
+  return map $by_id->{$_}->action, @{$action->dependencies};
+}
+
+sub value_for {
+  my ($self, $name) = @_;
+  $self->_state->scope_var($name)->bound_value;
+}
+
+1;
diff --git a/lib/DX/ResultStream.pm b/lib/DX/ResultStream.pm
index e439ce9..5816b03 100644
--- a/lib/DX/ResultStream.pm
+++ b/lib/DX/ResultStream.pm
@@ -1,5 +1,6 @@
 package DX::ResultStream;
 
+use DX::Result;
 use Moo;
 
 has for_state => (is => 'ro', required => 1);
@@ -38,9 +39,7 @@ sub next {
     $self->_set_is_exhausted(1);
     return;
   }
-  return +{
-    map +($_ => $state->scope_var($_)->copy), keys %{$state->scope}
-  };
+  return DX::Result->new(state => $state->copy_vars);
 }
 
 sub results {
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index 3c449da..2ae880d 100644
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -26,23 +26,27 @@ sub add_rule {
 
 sub _make_rule {
   my ($self, $vars, @body) = @_;
-  my $head = $self->_expand_and_link(DX::Op::Return->new, @body);
+  my $head = $self->expand_and_link(DX::Op::Return->new, @body);
   [ $vars, $head ];
 }
 
-sub _expand_and_link {
+sub expand_and_link {
   my ($self, $last, @body) = @_;
   return reduce { $b->but(next => $a) }
            $last,
-           reverse map $self->expand(@$_), @body;
+           reverse map $self->expand($_), @body;
 }
 
 sub expand {
-  my ($self, $type, @rest) = @_;
-  if ($self->can(my $expand_meth = "_expand_op_${type}")) {
-    return $self->$expand_meth(@rest);
+  my ($self, $thing) = @_;
+  if (ref($thing) eq 'ARRAY') {
+    my ($type, @rest) = @$thing;
+    if ($self->can(my $expand_meth = "_expand_op_${type}")) {
+      return $self->$expand_meth(@rest);
+    }
+    return $self->_expand_call(@$thing);
   }
-  return $self->_expand_call($type, @rest);
+  return $thing;
 }
 
 sub _expand_call {
@@ -58,7 +62,7 @@ sub _expand_op_not {
   my ($self, @contents) = @_;
   my $cut = DX::Op::Cut->new(next => DX::Op::Backtrack->new);
   DX::Op::Not->new(
-    body => $self->_expand_and_link($cut, @contents)
+    body => $self->expand_and_link($cut, @contents)
   );
 }
 
@@ -109,7 +113,7 @@ sub _expand_op_exists {
   my ($self, $vars, @body) = @_;
   DX::Op::Exists->new(
     vars => $vars,
-    body => $self->_expand_and_link(DX::Op::Return->new, @body)
+    body => $self->expand_and_link(DX::Op::Return->new, @body)
   );
 }
 
diff --git a/lib/DX/Solver.pm b/lib/DX/Solver.pm
index 51fcdbe..e94e050 100644
--- a/lib/DX/Solver.pm
+++ b/lib/DX/Solver.pm
@@ -18,8 +18,7 @@ sub query {
   my ($self, $vars, @terms) = @_;
   my $rule_set = $self->rule_set;
   push @terms, map +[ materialize => $_ ], @$vars;
-  my $head = reduce { $b->but(next => $a) }
-               reverse map $rule_set->expand(@$_), @terms;
+  my $head = $rule_set->expand_and_link(undef, @terms);
   my $state = DX::State->new(
     next_op => $head,
     return_stack => [],
diff --git a/lib/DX/State.pm b/lib/DX/State.pm
index e87682a..051d0d2 100644
--- a/lib/DX/State.pm
+++ b/lib/DX/State.pm
@@ -21,6 +21,8 @@ has rule_set => (is => 'ro');
 
 has facts => (is => 'ro');
 
+has dependencies => (is => 'ro', default => sub { {} });
+
 sub scope_var {
   my ($self, $name) = @_;
   $self->by_id->{$self->scope->{$name}};
@@ -157,4 +159,38 @@ sub push_return_then {
   );
 }
 
+sub add_dependencies {
+  my ($self, @pairs) = @_;
+  my %deps = %{$self->dependencies};
+  while (my ($from, $to) = splice(@pairs, 0, 2)) {
+    unless ($deps{$from}{$to}) {
+      $deps{$from} = { %{$deps{$from}||{}}, $to => 1 };
+    }
+  }
+  $self->but(dependencies => \%deps);
+}
+
+sub action_dependencies {
+  my ($self, @ids) = @_;
+  my @found;
+  my $deps = $self->dependencies;
+  my $by_id = $self->by_id;
+  my %seen;
+  my @queue = @ids;
+  while (my $id = shift @queue) {
+    $seen{$id}++;
+    push @found, $id if $by_id->{$id}->has_action;
+    push @queue, grep !$seen{$_}, keys %{$deps->{$id}};
+  }
+  return @found;
+}
+
+sub copy_vars {
+  my ($self) = @_;
+  my $by_id = $self->by_id;
+  $self->but(by_id => {
+    map +($_ => $by_id->{$_}->copy), keys %$by_id
+  });
+}
+
 1;
diff --git a/lib/DX/Var.pm b/lib/DX/Var.pm
index 2a1f83c..f2c11dd 100644
--- a/lib/DX/Var.pm
+++ b/lib/DX/Var.pm
@@ -22,7 +22,7 @@ has bound_value => (is => 'lazy', predicate => 1, clearer => 1, builder => sub {
   return;
 });
 
-has action => (is => 'ro');
+has action => (is => 'ro', predicate => 1);
 
 sub is_bound {
   my ($self) = @_;
diff --git a/t/basic.t b/t/basic.t
index 10e5d62..aba5c58 100644
--- a/t/basic.t
+++ b/t/basic.t
@@ -78,7 +78,7 @@ sub make_state {
 
 my $stream = DX::ResultStream->new(for_state => make_state([ 'S' ], $op));
 
-is($stream->next->{'S'}->bound_value, $_)
+is($stream->next->value_for('S'), $_)
   for qw(jim.example.com joe.example.com bob.example.com);
 
 is($stream->next, undef, 'No more');
@@ -100,7 +100,7 @@ sub bound_values {
   map {
     my $v = $_;
     +{
-       map +($_ => $v->{$_}->bound_value), keys %$v
+       map +($_ => $v->value_for($_)), $v->var_names,
     }
   } @_
 }
diff --git a/t/basic_rule.t b/t/basic_rule.t
index 72b9621..95d2666 100644
--- a/t/basic_rule.t
+++ b/t/basic_rule.t
@@ -47,7 +47,7 @@ $solver->add_rule(
 
 my $s = $solver->query([ 'S' ], [ server => 'S' ]);
 
-is_deeply([ map $_->{S}->bound_value->{name}, $s->results ], [ sort @servers ]);
+is_deeply([ map $_->value_for('S')->{name}, $s->results ], [ sort @servers ]);
 
 $solver->add_rule(
   shell => [ 'S' ] => [ member_of => S => [ value => 'shells' ] ])
@@ -69,7 +69,7 @@ $s = $solver->query(
      );
 
 is_deeply(
-  [ sort map $_->{Srv}->bound_value->{name}, $s->results ],
+  [ sort map $_->value_for('Srv')->{name}, $s->results ],
   [ qw(joe.example.com kitty.scsys.co.uk) ]
 );
 
diff --git a/t/dot_ssh.t b/t/dot_ssh.t
index 6e0a1c6..1c752a7 100644
--- a/t/dot_ssh.t
+++ b/t/dot_ssh.t
@@ -4,6 +4,7 @@ use DX::Solver;
 use DX::SetOver;
 use DX::Observer::FromCode;
 use DX::Action::FromCode;
+use File::Spec;
 use Test::Exception;
 
 {
@@ -39,6 +40,9 @@ my %protos = (
 my %empty = (
   '.ssh' => My::PathStatus->new(
     path => '.ssh'
+  ),
+  '.ssh/authorized_keys' => My::PathStatus->new(
+    path => '.ssh/authorized_keys'
   )
 );
 
@@ -75,7 +79,7 @@ $solver->add_rule(@$_) for (
 %path_status = %protos;
 
 sub paths_for_simple {
-  join ' ', map $_->{PS}->bound_value->path, $solver->query(
+  join ' ', map $_->value_for('PS')->path, $solver->query(
     [ qw(PS) ], [ path_status => 'PS' ], @_
   )->results;
 }
@@ -127,7 +131,7 @@ lives_ok {
   )->results
 };
 
-is(join(' ', map $_->{PS}->bound_value->path, @res), '.ssh');
+is(join(' ', map $_->value_for('PS')->path, @res), '.ssh');
 
 delete $solver->rule_set->rules->{'path_status_at/2'};
 
@@ -159,7 +163,7 @@ $solver->add_rule(
 $ob_res{'.ssh'} = $protos{'.ssh'};
 
 sub paths_for {
-  join ' ', map $_->{PS}->bound_value->path, $solver->query([ 'PS' ], @_)->results;
+  join ' ', map $_->value_for('PS')->path, $solver->query([ 'PS' ], @_)->results;
 }
 
 is(
@@ -198,6 +202,9 @@ $solver->add_rule(@$_) for (
   [ directory_at => [ qw(PS P) ],
     [ path_status_at => qw(PS P) ],
     [ is_directory => 'PS' ] ],
+  [ file_at => [ qw(PS P) ],
+    [ path_status_at => qw(PS P) ],
+    [ is_file => 'PS' ] ],
 );
 
 %path_status = ();
@@ -251,7 +258,9 @@ is(scalar(@res),1,'Single result');
 
 is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed');
 
-ok(my $action = $res[0]->{PS}->action);
+is(
+  scalar(my ($action) = $res[0]->actions), 1
+);
 
 my ($type, $value) = $action->run;
 
@@ -265,6 +274,96 @@ is(scalar(@res),1,'Single result');
 
 is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');
 
-ok(!$res[0]->{PS}->action, 'No action');
+ok(!$res[0]->actions, 'No action');
+
+$solver->add_rule(@$_) for (
+  [ catfile => [ qw(DirPath FileName FilePath) ],
+    DX::Op::FromCode->new(code => sub {
+      my ($self, $state) = @_;
+      my ($dir_path, $file_name, $file_path)
+        = map $state->scope_var($_), qw(DirPath FileName FilePath);
+      die "No." unless $dir_path->is_bound;
+      die "No." unless $file_name->is_bound;
+      die "No." if $file_path->is_bound;
+      my $cat_file = File::Spec->catfile(
+        map $_->bound_value, $dir_path, $file_name
+      );
+      $state->bind_value($file_path->id, $cat_file)
+            ->add_dependencies(
+                $file_path->id => $dir_path->id,
+                $file_path->id => $file_name->id,
+              )
+            ->then($self->next);
+    }) ],
+  [ file_in => [ qw(DirStatus FileName FileStatus) ],
+    [ is_directory => qw(DirStatus) ],
+    [ exists => [ qw(DirPath) ],
+      [ path => qw(DirStatus DirPath) ],
+      [ exists => [ qw(FilePath) ],
+        [ catfile => qw(DirPath FileName FilePath) ],
+        [ file_at => qw(FileStatus FilePath) ] ] ] ],
+  [ is_file => [ qw(PS) ],
+    [ not => [ exists_path => 'PS' ] ],
+    [ act => [ 'PS' ],
+        sub {
+          my ($ps_var) = @_;
+          my ($id, $value) = ($ps_var->id, $ps_var->bound_value);
+          DX::Action::FromCode->new(
+            expect => sub {
+              ($id => My::PathStatus->new(
+                path => $value->path,
+                info => My::PathStatusInfo->new(
+                  is_file => 1, mode => ''
+                )
+              ))
+            },
+            perform => sub {
+              $ob_res{$value->path} = $protos{$value->path};
+              (path_status => $value);
+            }
+          )
+        } ] ]
+);
+
+%path_status = ();
+%ob_res = %empty;
+
+sub keys_file {
+  $solver->query([ qw(D F) ],
+     [ directory_at => 'D' => \'.ssh' ],
+     [ file_in => 'D' => \'authorized_keys' => 'F' ],
+   );
+}
+
+@res = keys_file()->results;
+
+is(scalar @res, 1, 'One result');
+
+is(scalar(my @act = $res[0]->actions), 2, 'Two actions');
+
+is(scalar(my ($poss) = grep !@{$_->dependencies}, @act), 1, 'One possible');
+
+($type, $value) = $poss->run;
+
+$solver->facts->{$type}->remove_value($value);
+
+@res = keys_file()->results;
+
+is(scalar @res, 1, 'One result');
+
+is(
+  scalar(($poss) = grep !@{$_->dependencies}, $res[0]->actions), 1,
+  'One possible'
+);
+
+($type, $value) = $poss->run;
+
+$solver->facts->{$type}->remove_value($value);
+
+@res = keys_file()->results;
+
+is(scalar @res, 1, 'One result');
+
+is(scalar($res[0]->actions), 0, 'No actions');
 
 done_testing;