KeyMangler example app

[scpubgit/DKit.git] / lib / App / KeyMangler.pm

diff --git a/lib/App/KeyMangler.pm b/lib/App/KeyMangler.pm
new file mode 100644 (file)
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