better naming and help command for KeyMangler

[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 { Account DotSshDir } {
  home_dir_on Account HomeDir
  directory_in HomeDir '.ssh' DotSshDir
  mode DotSshDir '0700'
}

rule authorized_keys_on { Account AuthorizedKeysFile } {
  dot_ssh_on Account DotSshDir
  file_in DotSshDir 'authorized_keys' AuthorizedKeysFile
  mode AuthorizedKeysFile '0600'
}

rule key_installed_on { Account PubKeyLine } {
  authorized_keys_on Account AuthorizedKeysFile
  contains_line AuthorizedKeysFile PubKeyLine
}

rule key_not_installed_on { Account PubKeyLine } {
  authorized_keys_on Account AuthorizedKeysFile
  not_contains_line AuthorizedKeysFile PubKeyLine
}

rule my_config_dir ConfigDir {
  home_dir_on '' HomeDir
  directory_in HomeDir '.keymangler' ConfigDir
}

rule my_config_file { ConfigType ConfigFile } {
  my_config_dir ConfigDir
  file_in ConfigDir ConfigType ConfigFile
}

rule config_contains_line { ConfigType Line } {
  my_config_file ConfigType ConfigFile
  contains_line ConfigFile Line
}

rule config_not_contains_line { ConfigType Line } {
  my_config_file ConfigType ConfigFile
  not_contains_line ConfigFile Line
}

rule known_account Account {
  config_contains_line 'accounts' Account
}

rule known_key Key {
  config_contains_line 'keys' Key
}
rule known_dead DeadKey {
  config_contains_line 'keys.dead' DeadKey
}

rule not_known_account Account {
  config_not_contains_line 'accounts' Account
}
rule not_known_key Key {
  config_not_contains_line 'keys' Key
}
rule not_known_dead DeadKey {
  config_not_contains_line 'keys.dead' DeadKey
}

rule all_known_installed_on Account {
  foreach Key { known_key Key } {
    key_installed_on Account Key
  }
}

rule all_dead_not_installed_on Account {
  foreach Key { known_dead Key } {
    key_not_installed_on Account Key
  }
}

rule account_synchronized Account {
  all_known_installed_on Account
  all_dead_not_installed_on Account
}

rule all_synchronized {} {
  foreach Account { known_account Account } {
    account_synchronized Account
  }
}

rule unknown_installed_on { Account Key } {
  key_installed_on Account Key
  not { known_key Key }
  not { known_dead Key }
}

rule known_installed_on { Account Key } {
  key_installed_on Account Key
  known_key Key
}

rule dead_installed_on { Account Key } {
  key_installed_on Account Key
  known_dead Key
}

oo::class create ConfigSet {
  constructor mytype {
    namespace import ::DX::*
    variable type $mytype
  }
  method add Value {
    variable type
    ensure "known_$type {'$Value'}"
  }
  method rm Value {
    variable type
    ensure "not_known_$type {'$Value'}"
  }
  method list {} {
    variable type
    query* "known_$type Value" {puts $Value}
  }
}

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 Account
      findall KnownKeys Key {
        known_installed_on Account Key
      }
      findall UnknownKeys Unknown {
        unknown_installed_on Account Unknown
      }
      findall DeadKeys Dead {
        dead_installed_on Account Dead
      }
    } {
      puts "Host: $A"
      foreach key $KnownKeys {
        puts "  Known: [lindex $key 2]"
      }
      foreach unknown $UnknownKeys {
        puts "  Unknown: [lindex $unknown 2]"
      }
      foreach dead $DeadKeys {
        puts "  Dead: [lindex $dead 2]"
      }
      puts ""
    }
  }

  method -n args {
    variable mode solve
    my {*}$args
  }

  export -n

  method push {{account -}} {
    variable mode
    if {"$account" eq "-"} {
      $mode { all_synchronized }
    } else {
      $mode "account_synchronized {'$account'}"
    }
  }

  method help {} {
    puts {Usage:}
    puts {}
    puts {  # Config commands}
    puts {  $ km {key,dead,account} add 'new value'}
    puts {  $ km {key,dead,account} rm 'old value'}
    puts {  $ km {key,dead,account} list}
    puts {}
    puts {  # What keys are installed where?}
    puts {  $ km status}
    puts {}
    puts {  # Update remote authorized_keys files (-n is dry-run)}
    puts {  $ km [-n] sync user@host}
    puts {  $ km [-n] sync}
    puts {}
  }
}

KeyMangler create km