From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 3 Feb 2014 06:51:15 +0000 (+0000)
Subject: observers
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FDKit.git;a=commitdiff_plain;h=5ef4d923edc14eadf67d64e92001f2f7bfa63986

observers
---

diff --git a/lib/DX/ObservationRequired.pm b/lib/DX/ObservationRequired.pm
index 057c40e..156afd1 100644
--- a/lib/DX/ObservationRequired.pm
+++ b/lib/DX/ObservationRequired.pm
@@ -2,7 +2,7 @@ package DX::ObservationRequired;
 
 use Moo;
 
-has observation => (is => 'ro', required => 1);
+has observer => (is => 'ro', required => 1);
 
 has resume => (is => 'ro', required => 1);
 
diff --git a/lib/DX/Observer/FromCode.pm b/lib/DX/Observer/FromCode.pm
new file mode 100644
index 0000000..7d6beed
--- /dev/null
+++ b/lib/DX/Observer/FromCode.pm
@@ -0,0 +1,9 @@
+package DX::Observer::FromCode;
+
+use Moo;
+
+has code => (is => 'ro', required => 1);
+
+sub run { $_[0]->code->(); }
+
+1;
diff --git a/lib/DX/Op/Observe.pm b/lib/DX/Op/Observe.pm
new file mode 100644
index 0000000..c458d2c
--- /dev/null
+++ b/lib/DX/Op/Observe.pm
@@ -0,0 +1,30 @@
+package DX::Op::Observe;
+
+use DX::ObservationRequired;
+use Moo;
+
+with 'DX::Role::Op';
+
+has vars => (is => 'ro', required => 1);
+has builder => (is => 'ro', required => 1);
+
+has _arg_map => (is => 'lazy', builder => sub {
+  my ($self) = @_;
+  my $name = 'arg0';
+  +{ map +($name++, $_), @{$self->vars} };
+});
+
+sub run {
+  my ($self, $state) = @_;
+  ($state, my %args) = $self->_expand_args($state, %{$self->_arg_map});
+  my @vars = map $_->bound_value, @args{sort keys %args};
+  my $observer = $self->builder->(@vars);
+  $state->return_from_run(
+    DX::ObservationRequired->new(
+      observer => $observer,
+      resume => $state->then($self->next)
+    )
+  );
+}
+
+1;
diff --git a/lib/DX/ResultStream.pm b/lib/DX/ResultStream.pm
index 6bf251f..17f0bd7 100644
--- a/lib/DX/ResultStream.pm
+++ b/lib/DX/ResultStream.pm
@@ -8,17 +8,32 @@ has _current_state => (is => 'rw');
 
 has is_exhausted => (is => 'rwp');
 
+has observation_policy => (is => 'ro', default => sub { sub { 0 } });
+
 sub next {
   my ($self) = @_;
   return if $self->is_exhausted;
-  my $start_state = do {
+  my $state = do {
     if (my $cur = $self->_current_state) {
       $cur->push_backtrack;
     } else {
       $self->for_state
     }
   };
-  my $state = $self->_current_state($start_state->run);
+  STATE: while ($state = $self->_current_state($state->run)) {
+    last if $state->isa('DX::State');
+    if ($state->isa('DX::ObservationRequired')) {
+      if ($self->observation_policy->($state->observer)) {
+        my ($type, $value) = $state->observer->run;
+        $state = $state->resume;
+        $state->facts->{$type}->set_value($value);
+      } else {
+        die "Observation refused";
+      }
+    } else {
+      die "WTF: ".$state;
+    }
+  }
   unless ($state) {
     $self->_set_is_exhausted(1);
     return;
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index 5861116..13b6696 100644
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -6,6 +6,7 @@ use DX::Op::MemberOf;
 use DX::Op::ApplyConstraint;
 use DX::Op::Return;
 use DX::Op::Cut;
+use DX::Op::Observe;
 use List::Util qw(reduce);
 
 has rules => (is => 'ro', default => sub { {} });
@@ -56,4 +57,12 @@ sub _expand_constrain {
   );
 }
 
+sub _expand_observe {
+  my ($self, $vars, $builder) = @_;
+  DX::Op::Observe->new(
+    vars => $vars,
+    builder => $builder,
+  );
+}
+
 1;
diff --git a/lib/DX/Solver.pm b/lib/DX/Solver.pm
index 05523ec..c425b27 100644
--- a/lib/DX/Solver.pm
+++ b/lib/DX/Solver.pm
@@ -12,6 +12,8 @@ has rule_set => (is => 'lazy', handles => [ 'add_rule' ], builder => sub {
 
 has facts => (is => 'ro', required => 1);
 
+has observation_policy => (is => 'ro');
+
 sub query {
   my ($self, $vars, @terms) = @_;
   my $rule_set = $self->rule_set;
@@ -27,7 +29,10 @@ sub query {
     rule_set => $rule_set,
   )->assign_vars(map +($_ => {}), @$vars);
   return DX::ResultStream->new(
-    for_state => $state
+    for_state => $state,
+    ($self->observation_policy
+      ? (observation_policy => $self->observation_policy)
+      : ()),
   );
 }
 
diff --git a/t/dot_ssh.t b/t/dot_ssh.t
index 58f36e6..7a3491d 100644
--- a/t/dot_ssh.t
+++ b/t/dot_ssh.t
@@ -2,6 +2,7 @@ use strictures 1;
 use Test::More;
 use DX::Solver;
 use DX::SetOver;
+use DX::Observer::FromCode;
 use Test::Exception;
 
 {
@@ -61,19 +62,19 @@ $solver->add_rule(@$_) for (
 
 %path_status = %protos;
 
-sub paths_for {
+sub paths_for_simple {
   join ' ', map $_->{PS}->path, $solver->query(
     [ qw(PS) ], [ path_status => 'PS' ], @_
   )->results;
 }
 
-is(paths_for(), '.ssh .ssh/authorized_keys');
+is(paths_for_simple(), '.ssh .ssh/authorized_keys');
 
-is(paths_for([ is_directory => 'PS' ]), '.ssh');
+is(paths_for_simple([ is_directory => 'PS' ]), '.ssh');
 
-is(paths_for([ is_file => 'PS' ]), '.ssh/authorized_keys');
+is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys');
 
-is(paths_for([ mode => 'PS', [ value => '0755' ] ]), '.ssh');
+is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh');
 
 $solver->add_rule(
   path_status_at => [ 'PS', 'P' ],
@@ -116,6 +117,61 @@ lives_ok {
 
 is(join(' ', map $_->{PS}->path, @res), '.ssh');
 
-#::Dwarn($solver->query([ qw(PS) ], [ path_status_at => 'PS', [ value => '.ssh' ] ])->results);
+delete $solver->rule_set->rules->{'path_status_at/2'};
+
+$solver->add_rule(
+  path_status_at => [ 'PS', 'P' ],
+    [ path_status => 'PS' ],
+    [ path => qw(PS P) ],
+    [ 'cut' ],
+);
+
+my %ob_res;
+
+$solver->add_rule(
+  path_status_at => [ 'PS', 'P' ],
+    [ observe => [ 'P' ],
+        sub {
+          my ($path) = $_[0];
+          DX::Observer::FromCode->new(
+            code => sub { (path_status => $ob_res{$path}) }
+          )
+        }
+    ],
+    [ path_status => 'PS' ],
+    [ path => qw(PS P) ],
+);
+
+%path_status = ('.ssh/authorized_keys' => $protos{'.ssh/authorized_keys'});
+
+$ob_res{'.ssh'} = $protos{'.ssh'};
+
+sub paths_for {
+  join ' ', map $_->{PS}->path, $solver->query([ 'PS' ], @_)->results;
+}
+
+is(
+  paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]),
+  '',
+  'no .ssh entry'
+);
+
+throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
+  qr/refused/;
+
+$solver->{observation_policy} = sub { 1 };
+
+is(
+  paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]),
+  '.ssh',
+  'observation'
+);
+
+is($path_status{'.ssh'}, $ob_res{'.ssh'});
+
+delete $solver->{observation_policy};
+
+lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
+  'No observation required anymore';
 
 done_testing;
diff --git a/t/observe.t b/t/observe.t
index 8fbac7f..7896be3 100644
--- a/t/observe.t
+++ b/t/observe.t
@@ -82,7 +82,7 @@ my @path_status = (
       my $path = $state->scope_var('P')->bound_value;
       $state->return_from_run(
         DX::ObservationRequired->new(
-          observation => sub { $paths{$path} = $observe_path{$path} },
+          observer => sub { $paths{$path} = $observe_path{$path} },
           resume => $state->then($self->next),
         )
       );
@@ -113,7 +113,7 @@ my $or_state = make_state([ 'P', 'PS' ],
 
 my $ob_req = $or_state->run;
 
-$ob_req->observation->();
+$ob_req->observer->();
 
 {
   my $res = $ob_req->resume->run;