From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 24 Feb 2014 20:50:31 +0000 (+0000)
Subject: KeyMangler example app
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=91d1f2390ba5142362b25713fa534cbba335d382;p=scpubgit%2FDKit.git

KeyMangler example app
---

diff --git a/bin/dx b/bin/dx
new file mode 100644
index 0000000..32e0830
--- /dev/null
+++ b/bin/dx
@@ -0,0 +1,7 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use DX::Tcl;
+
+DX::Tcl->new->run(@ARGV);
diff --git a/bin/km b/bin/km
new file mode 100644
index 0000000..b2cd39b
--- /dev/null
+++ b/bin/km
@@ -0,0 +1,7 @@
+#!/usr/bin/env perl
+
+use App::KeyMangler;
+
+my $tcl = App::KeyMangler->new;
+
+$tcl->run(@ARGV);
diff --git a/examples/keyman b/examples/keyman
index 07021f0..5a4d7d8 100644
--- a/examples/keyman
+++ b/examples/keyman
@@ -48,10 +48,19 @@ rule not_known_account A { config_not_contains_line 'accounts' A }
 rule not_known_key K { config_not_contains_line 'keys' K }
 rule not_known_dead D { config_not_contains_line 'keys.dead' D }
 
-rule account_synchronized A {
+rule all_known_installed_on A {
   foreach K { known_key K } { key_installed_on A K }
 }
 
+rule all_dead_not_installed_on A {
+  foreach K { known_dead K } { key_not_installed_on A K }
+}
+
+rule account_synchronized A {
+  all_known_installed_on A
+  all_dead_not_installed_on A
+}
+
 rule all_synchronized {} {
   foreach A { known_account A } { account_synchronized A }
 }
@@ -59,4 +68,15 @@ rule all_synchronized {} {
 rule unknown_installed_on { A K } {
   key_installed_on A K
   not { known_key K }
+  not { known_dead K }
+}
+
+rule known_installed_on { A K } {
+  key_installed_on A K
+  known_key K
+}
+
+rule dead_installed_on { A K } {
+  key_installed_on A K
+  known_dead K
 }
diff --git a/lib/App/KeyMangler.pm b/lib/App/KeyMangler.pm
new file mode 100644
index 0000000..bcc939a
--- /dev/null
+++ b/lib/App/KeyMangler.pm
@@ -0,0 +1,174 @@
+package App::KeyMangler;
+
+use Moo;
+
+extends 'DX::Tcl';
+
+sub BUILD {
+  my ($self) = @_;
+  our $Tcl_Data ||= do { local $/; my $data = <DATA>; close(DATA); $data };
+  $self->tcl->Eval($Tcl_Data);
+}
+
+sub run {
+  my ($self, @args) = @_;
+  if (@args) {
+    my $res = $self->tcl->call(km => @args);
+    print $res;
+  } else {
+    $self->repl
+  }
+}
+
+1;
+
+__DATA__
+
+rule dot_ssh_on { A D } {
+  home_dir_on A H
+  directory_in H '.ssh' D
+  mode D '0700'
+}
+
+rule authorized_keys_on { A F } {
+  dot_ssh_on A D
+  file_in D 'authorized_keys' F
+  mode F '0600'
+}
+
+rule key_installed_on { A K } {
+  authorized_keys_on A F
+  contains_line F K
+}
+
+rule key_not_installed_on { A K } {
+  authorized_keys_on A F
+  not_contains_line F K
+}
+
+rule my_config_dir D {
+  home_dir_on '' H
+  directory_in H '.keymangler' D
+}
+
+rule my_config_file { C F } {
+  my_config_dir D
+  file_in D C F
+}
+
+rule config_contains_line { C L } {
+  my_config_file C F
+  contains_line F L
+}
+
+rule config_not_contains_line { C L } {
+  my_config_file C F
+  not_contains_line F L
+}
+
+rule known_account A { config_contains_line 'accounts' A }
+rule known_key K { config_contains_line 'keys' K }
+rule known_dead D { config_contains_line 'keys.dead' D }
+
+rule not_known_account A { config_not_contains_line 'accounts' A }
+rule not_known_key K { config_not_contains_line 'keys' K }
+rule not_known_dead D { config_not_contains_line 'keys.dead' D }
+
+rule all_known_installed_on A {
+  foreach K { known_key K } { key_installed_on A K }
+}
+
+rule all_dead_not_installed_on A {
+  foreach K { known_dead K } { key_not_installed_on A K }
+}
+
+rule account_synchronized A {
+  all_known_installed_on A
+  all_dead_not_installed_on A
+}
+
+rule all_synchronized {} {
+  foreach A { known_account A } { account_synchronized A }
+}
+
+rule unknown_installed_on { A K } {
+  key_installed_on A K
+  not { known_key K }
+  not { known_dead K }
+}
+
+rule known_installed_on { A K } {
+  key_installed_on A K
+  known_key K
+}
+
+rule dead_installed_on { A K } {
+  key_installed_on A K
+  known_dead K
+}
+
+oo::class create ConfigSet {
+  constructor mytype {
+    namespace import ::DX::*
+    variable type $mytype
+  }
+  method learn V {
+    variable type
+    ensure "known_$type {'$V'}"
+  }
+  method forget V {
+    variable type
+    ensure "not_known_$type {'$V'}"
+  }
+  method list {} {
+    variable type
+    query* "known_$type V" {puts $V}
+  }
+}
+
+oo::class create KeyMangler {
+  constructor {} {
+    namespace import ::DX::*
+    ConfigSet create key key
+    ConfigSet create dead dead
+    ConfigSet create account account
+    variable mode ensure
+  }
+
+  method key args { key {*}$args }
+  method dead args { dead {*}$args }
+  method account args { account {*}$args }
+
+  method status {} {
+    query* {
+      known_account A
+      findall Known K { known_installed_on A K }
+      findall Unknown U { unknown_installed_on A U }
+      findall Dead D { dead_installed_on A D }
+    } {
+      puts "Host: $A"
+      foreach k $Known { puts "  Known: [lindex $k 2]" }
+      foreach u $Unknown { puts "  Unknown: [lindex $u 2]" }
+      foreach d $Dead { puts "  Dead: [lindex $d 2]" }
+      puts ""
+    }
+  }
+
+  method -n args {
+    variable mode solve
+    my {*}$args
+  }
+
+  export -n
+
+  method sync {{account -}} {
+    variable mode
+    if {"$account" eq "-"} {
+      $mode { all_synchronized }
+    } else {
+      $mode "account_synchronized {'$account'}"
+    }
+  }
+}
+
+KeyMangler create km
diff --git a/lib/DX/Lib/FS/Action/RewriteFile.pm b/lib/DX/Lib/FS/Action/RewriteFile.pm
index 625f2df..b1b8a08 100644
--- a/lib/DX/Lib/FS/Action/RewriteFile.pm
+++ b/lib/DX/Lib/FS/Action/RewriteFile.pm
@@ -10,11 +10,11 @@ has from => (is => 'ro', required => 1, handles => [ 'path' ]);
 
 has add_lines => (is => 'ro', default => sub { [] });
 
-has remove_lines => (is => 'ro', default => sub { {} });
+has remove_lines => (is => 'ro', default => sub { [] });
 
 has final_content => (is => 'lazy', init_arg => undef, builder => sub {
   my ($self) = @_;
-  my %remove = %{$self->remove_lines};
+  my %remove = map +($_ => 1), @{$self->remove_lines};
   join("\n",
     (grep !$remove{$_}, $self->from->lines->all),
     @{$self->add_lines},
@@ -27,7 +27,7 @@ sub but_add {
 }
 
 sub but_remove {
-  $_[0]->but(remove_lines => { %{$_[0]->remove_lines}, $_[1] => 1 });
+  $_[0]->but(remove_lines => [ @{$_[0]->remove_lines}, $_[1] ]);
 }
 
 sub expected_effect {
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index 0fada41..ba0f3c5 100644
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -72,19 +72,19 @@ sub _expand_op_cut { return DX::Op::Cut->new }
 sub _expand_op_fail { return DX::Op::Backtrack->new }
 
 sub _expand_op_not {
-  my ($self, @contents) = @_;
+  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)
   );
 }
 
 sub _expand_op_findall {
-  my ($self, $coll_name, $var_name, @contents) = @_;
+  my ($self, $coll_name, $var_name, $contents) = @_;
   DX::Op::FindAll->new(
     coll_name => $coll_name,
     var_name => $var_name,
-    body => $self->expand_and_link(DX::Op::Return->new, @contents),
+    body => $self->expand_and_link(DX::Op::Return->new, @$contents),
   );
 }
 
diff --git a/lib/DX/Tcl.pm b/lib/DX/Tcl.pm
new file mode 100644
index 0000000..2a9955a
--- /dev/null
+++ b/lib/DX/Tcl.pm
@@ -0,0 +1,261 @@
+package DX::Tcl;
+
+use strictures 1;
+use curry;
+use DX::Solver;
+use DX::Lib::FS;
+use Term::ReadLine;
+use Devel::Dwarn;
+use Tcl;
+use Safe::Isa;
+use Moo;
+
+has solver => (is => 'lazy', builder => sub {
+  my $solver = DX::Solver->new(observation_policy => sub { 1 });
+  DX::Lib::FS->new->load_into($solver);
+  $solver;
+});
+
+has tcl => (is => 'lazy', builder => sub {
+  my ($self) = @_;
+  my $tcl = Tcl->new;
+  $tcl->CreateCommand('DX::_call' => $self->curry::weak::handle_tcl_call);
+  our $Tcl_Data ||= do { local $/; my $data = <DATA>; close(DATA); $data };
+  $tcl->Eval($Tcl_Data);
+  $tcl->call(namespace => import => 'DX::*');
+  return $tcl;
+});
+
+sub handle_tcl_call {
+  my ($self, undef, undef, undef, $call, @args) = @_;
+  return $self->${\"_tcl_${call}"}(@args);
+  #Dwarn(\@stuff);
+  return 1;
+}
+
+sub _tcl_rule_names {
+  my ($self) = @_;
+  return [ map /(.*)\/(\d+)/, keys %{$self->solver->rule_set->rules} ];
+}
+
+sub _tcl_add_rule {
+  my ($self, $name, $args, $raw_body) = @_;
+  my @args = $self->tcl->SplitList($args);
+  #warn $raw_body;
+  my $body = $self->_expand_tcl_data($raw_body);
+  #Dwarn([ $name, \@args, @$body ]);
+  $self->solver->add_rule($name => \@args => @$body);
+  return;
+}
+
+sub _tcl_first_result {
+  my ($self, $type, $raw_query) = @_;
+  my $query = $self->_expand_tcl_data($raw_query);
+  my $rs = $self->solver->$type(@$query);
+  my $result = $rs->next;
+  return $result ? $self->_implode_result($result) : 'false';
+}
+
+sub _tcl_each_result {
+  my ($self, $type, $raw_query) = @_;
+  my $query = $self->_expand_tcl_data($raw_query);
+  my $rs = $self->solver->$type(@$query);
+  return [ map $self->_implode_result($_), $rs->results ];
+}
+
+sub _tcl_ensure_result {
+  my ($self, $raw_query) = @_;
+  my $query = $self->_expand_tcl_data($raw_query);
+  my $result = $self->solver->ensure(@$query);
+  return $result ? $self->_implode_result($result) : 'false';
+}
+
+sub _implode_result {
+  my ($self, $result) = @_;
+  my $imploded = $self->_implode_hashref($result->all_values);
+  if (my @act = $result->actions) {
+    my @flat_act = map +($_->[0], $self->_implode_hashref($_->[1])),
+                     map [ %{$_->as_structure} ], @act;
+    unshift @$imploded, +(_actions => \@flat_act);
+  }
+  return $imploded;
+}
+
+sub _implode_hashref {
+  my ($self, $values) = @_;
+  my @flat;
+  my %meta;
+  foreach my $key (sort keys %$values) {
+    my $v = $values->{$key};
+    if ($v->$_does('DX::Role::Set')) {
+      $meta{$key}{is_list} = 1;
+      push @flat, ($key => [ map "$_", $v->all ]);
+    } elsif (ref($v) and ref($v) eq 'ARRAY') {
+      $meta{$key}{is_list} = 1;
+      push @flat, ($key => [ map "$_", @$v ]);
+    } else {
+      push @flat, ($key => "$v");
+    }
+  }
+  my @flat_meta = map +($_ => [ %{$meta{$_}} ]), sort keys %meta;
+  return [ (@flat_meta ? (_meta => \@flat_meta) : ()), @flat ];
+}
+
+sub _expand_tcl_data {
+  my ($self, $data) = @_;
+  my ($type, @rest) = $self->tcl->SplitList($data);
+  die "No type" unless $type;
+  if ($type eq 'seq') {
+    return [ map $self->_expand_tcl_data($_), @rest ];
+  } elsif ($type eq 'call') {
+    my ($name, @args) = @rest;
+    return [ $name => map $self->_expand_tcl_data($_), @args ];
+  } elsif ($type eq 'var') {
+    return $rest[0];
+  } elsif ($type eq 'value') {
+    return \$rest[0]
+  }
+  die "Unknown type ${type}";
+}
+
+sub run { shift->repl }
+
+sub repl {
+  my ($self) = @_;
+  my $rl = Term::ReadLine->new;
+  my $tcl = $self->tcl;
+  my $cmd;
+
+  while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
+    $cmd .= "${line}\n";
+    my $out;
+    if ($tcl->call(info => complete => $cmd)) {
+      if (eval { $out = $tcl->Eval($cmd); 1 }) {
+        print $out;
+        if (length($out) and $out !~ /\n$/) { print "\n" }
+      } else {
+        $tcl->Eval(q{puts $::errorInfo});
+      }
+      $cmd = '';
+    }
+  }
+}
+
+1;
+
+__DATA__
+namespace eval DX {
+
+  variable current_body {}
+
+  proc rule {name args body} {
+    setup_eval_scope
+    _call add_rule $name $args [expand_body $body]
+  }
+
+  proc query {body {out ""}} {
+    setup_eval_scope
+    set res [_call first_result query [expand_body $body]]
+    return [format_response $res $out]
+  }
+
+  proc query* {body {out ""}} {
+    setup_eval_scope
+    set each_res [_call each_result query [expand_body $body]]
+    if [string length $out] {
+      set join_by ""
+    } else {
+      set join_by "--\n"
+    }
+    return [join [lmap res $each_res {format_response $res $out}] $join_by]
+  }
+
+  proc solve {body {out ""}} {
+    setup_eval_scope
+    set res [_call first_result solve [expand_body $body]]
+    return [format_response $res $out]
+  }
+
+  proc ensure {body {out ""}} {
+    setup_eval_scope
+    set res [_call ensure_result [expand_body $body]]
+    return [format_response $res $out]
+  }
+
+  proc format_response {res out {i ""}} {
+    if {[llength $res] < 2} {
+      return "${i}$res\n";
+    }
+    if [string length $out] {
+      return [dict with res $out]
+    }
+    set flat ""
+    if [dict exists $res _actions] {
+      foreach {n v} [dict get $res _actions] {
+        append flat "$n -> \n";
+        append flat [format_response $v "" "  "]
+      }
+      append flat "->\n";
+    }
+    dict for {k v} $res {
+      if ![string match _* $k] {
+        if {[dict exists $res _meta $k is_list]
+            && [dict get $res _meta $k is_list]} {
+          append flat "$i$k:\n"
+          foreach l $v { append flat "$i  $l\n" }
+        } else {
+          append flat "$i$k: $v\n"
+        }
+      }
+    }
+    return $flat
+  }
+
+  proc expand_body body {
+    variable current_body
+    set save_body $current_body
+    set current_body {seq}
+    namespace eval ::DX::Eval $body
+    set final_body $current_body
+    set current_body $save_body
+    return $final_body
+  }
+
+  proc body_add {name raw_args} {
+    variable current_body
+    lappend current_body [concat call $name [::DX::mangle_args $raw_args]]
+  }
+
+  proc setup_eval_scope {} {
+    set rules [ _call rule_names ];
+    foreach {name arity} $rules {
+      if ![llength [info procs ::DX::Eval::$name]] {
+        namespace inscope ::DX::Eval proc $name args [
+          concat DX::body_add $name {$args}
+        ]
+      }
+    }
+  }
+
+  proc mangle_arg {arg} {
+    if [regexp {^'(.*)'$} $arg -> value] {
+      return [list value $value]
+    }
+    if {[llength $arg] > 1} {
+      return [expand_body $arg]
+    }
+    return [list var $arg]
+  }
+
+  proc mangle_args {raw} {
+    return [lmap x $raw { mangle_arg $x }]
+  }
+
+  namespace eval ::DX::Eval {
+    proc findall args { DX::body_add findall $args }
+    proc foreach args { DX::body_add foreach $args }
+    proc not args { DX::body_add not $args }
+  }
+
+  namespace export rule query query* solve ensure
+}
diff --git a/t/findall.t b/t/findall.t
index 47fee23..deb95d7 100644
--- a/t/findall.t
+++ b/t/findall.t
@@ -35,10 +35,10 @@ $solver->add_rule(has_shell => [ 'Srv', 'Shell' ],
 );
 
 my @r = $solver->query(
-  [ findall => X => S =>
+  [ findall => X => S => [
     [ member_of => 'S', \'server' ],
     [ has_shell => 'S', \'bash' ],
-  ]
+  ] ]
 )->results;
 
 is_deeply(