--- /dev/null
+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
--- /dev/null
+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
+}
projects / scpubgit/DKit.git / commitdiff