KeyMangler example app

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

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