#!/usr/bin/perl -w

###############################################################################
#                                                                             #
#  kanif, a TakTuk wrapper for cluster management.                            #
#  Perl implementation, copyright(C) 2007 Guillaume Huard.                    #
#                                                                             #
#  This program is free software; you can redistribute it and/or modify       #
#  it under the terms of the GNU General Public License as published by       #
#  the Free Software Foundation; either version 2 of the License, or          #
#  (at your option) any later version.                                        #
#                                                                             #
#  This program is distributed in the hope that it will be useful,            #
#  but WITHOUT ANY WARRANTY; without even the implied warranty of             #
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              #
#  GNU General Public License for more details.                               #
#                                                                             #
#  You should have received a copy of the GNU General Public License          #
#  along with this program; if not, write to the Free Software                #
#  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA #
#                                                                             #
#  Contact: Guillaume.Huard@imag.fr                                           #
#           ENSIMAG - Laboratoire ID                                          #
#           51 avenue Jean Kuntzmann                                          #
#           38330 Montbonnot Saint Martin                                     #
#                                                                             #
###############################################################################

$SIG{PIPE} = 'IGNORE';

###############################################################################
# PACKAGE DIAGNOSTIC                                                          #
# Prints monitoring information and error messages                            #
###############################################################################

package diagnostic;
use strict;

our $current_level=2;

sub print_info($$$)
  {
    my $level = shift;
    my $level_name = shift;
    my $content = shift;

    if ($level >= $current_level)
      {
        print "[KANIF $level_name] -- $content\n";
      }
  }

sub system()
  {
    print_info(3,"ERROR: SYSTEM", $!);
  }

sub error($)
  {
    print_info(3,"ERROR",shift);
  }

sub warning($)
  {
    print_info(2,"WARNING",shift);
  }

sub monitoring($)
  {
    print_info(1,"MONITORING",shift);
  }

sub debug($)
  {
    print_info(0,"DEBUG",shift);
  }

###############################################################################
# PACKAGE SIGNALS                                                             #
# signals handling                                                            #
###############################################################################

package signals;
use strict;
use Time::HiRes;

our $last_time = [ 0, 0 ];

sub sigint()
  {
    my $current_time = [ Time::HiRes::gettimeofday ];
    if (Time::HiRes::tv_interval($last_time, $current_time) < 1)
      {
        if (defined($main::write_channel))
          {
            print $main::write_channel "network cancel\n";
            print $main::write_channel "broadcast kill 9\n";
          }
        $arguments::option->{sequential} = 0;
        $main::terminate = 1;
        main::check_if_done();
      }
    else
      {
        output::skip_prompt();
        my $result = $main::result;
        my $deployment = $main::deployment;
        $last_time = $current_time;
        output::title(\*STDERR, "CURRENT STATE");
        print STDERR "Connections initialized : $deployment->{initialized}\n";
        print STDERR "Connections failed : $deployment->{failed}\n";
        print STDERR "Connections lost : $deployment->{lost}\n";
        print STDERR "Commands started : $result->{started}\n";
        print STDERR "Commands failed : $result->{failed}\n";
        print STDERR "Commands terminated : $result->{terminated}\n";
        print STDERR "Type within 1 second : Ctrl-C to quit this program\n";
        print STDERR "                       ".
                     "Ctrl-Z to cancel ongoing connections\n";
        output::restore_prompt();
      }
  }

sub sigtstp()
  {
    my $current_time = [ Time::HiRes::gettimeofday ];
    if ((Time::HiRes::tv_interval($last_time, $current_time) < 1) and
        defined($main::write_channel))
      {
        print STDERR "\n";
        print $main::write_channel "resign\n";
      }
  }

$SIG{TSTP} = \&sigtstp;
$SIG{INT} = \&sigint;

###############################################################################
# PACKAGE ARGUMENTS                                                           #
# Parse optional arguments and cluster specifications                         #
###############################################################################

package arguments;

use strict;
use Getopt::Long;
use Data::Dumper;

sub get_cluster_interval($$$);
sub get_environment($);
sub parse_kanif_arguments();
sub read_cluster_config();
sub read_cluster_specs();

our $clusters = {};
our @clusters_spec = ();

our $option = {
               all => 0,
               'dry-run' => 0,
               exclude => [],
               'flat-deployment' => 0,
               head => 0,
               help => 0,
               interactive => 0,
               list => [],
               monitoring => 0,
               nodes => [],
               postprocess => 4,
               sequential => 0,
               'taktuk-options' => "-s",
               version => 0
             };

our %getopt_config = (
           'a|all' => \$option->{all},
           'f|file=s' => \$option->{conf},
           'F|flat-deployment' => \$option->{'flat-deployment'},
           'H|head' => \$option->{head},
           'h|help' => \$option->{help},
           'i|interactive' => \$option->{interactive},
           'l|login=s' => \$option->{user},
           'M|list=s' => \@{$option->{list}},
           'm|monitoring' => \$option->{monitoring},
           'n|nodes=s' => \@{$option->{nodes}},
           'o|remote-opts=s' => \$option->{'remote-opts'},
           'p|postprocess=i' => \$option->{postprocess},
           'q|dry-run' => \$option->{'dry-run'},
           'r|remote-cmd=s' => \$option->{'remote-cmd'},
           's|sequential' => \$option->{sequential},
           'T|taktuk-options=s' => \$option->{'taktuk-options'},
           't|timeout=f' => \$option->{timeout},
           'u|upper-limit=f' => \$option->{'upper-limit'},
           'V|version' => \$option->{version},
           'w|wcoll=s' => \@{$option->{nodes}},
           'x|exclude=s' => \@{$option->{exclude}}
          );

sub read_cluster_config()
  {
    my $fd = undef;
    my $name = undef;
    my $result = undef;
    my $state = 0;
    my $line_num = 0;
    my $prefix;
    my $suffix;
    my $current_cluster = undef;
    my $current_hosts = undef;

    if (defined($option->{conf}))
      {
        $name = $option->{conf};
      }
    elsif (-f "$ENV{HOME}/.kanif.conf")
      {
        $name = "$ENV{HOME}/.kanif.conf";
      }
    elsif (-f "/etc/kanif.conf")
      {
        $name = "/etc/kanif.conf";
      }
    elsif (-f "/etc/c3.conf")
      {
        $name = "/etc/c3.conf";
      }
        
    if (defined($name))
      {
        $result = open $fd, "<", $name;
        warn "Cannot open $name: $!" if not $result;
      }
    if ($result)
      {
        while (defined(my $line = <$fd>))
          {
            $line_num++; 
            $line =~ s/^\s*([^#]*?)\s*(?:#.*)?$/$1/o;
            my @words = split /\s+/, $line;
            while (scalar(@words))
              {
                my $word = shift @words;
                my $cluster = undef;
                my $nodes = undef;

                $cluster = $clusters->{$current_cluster}
                    if defined($current_cluster);
                if (defined($cluster) and exists($cluster->{nodes}))
                  {
                    $nodes = $cluster->{nodes};
                  }

                if (($state == 0) and ($word eq "cluster"))
                  {
                    $state = 1;
                  }
                elsif ($state == 1)
                  {
                    $state = 2;
                    $clusters->{$word} = {};
                    $current_cluster = $word;
                    $clusters->{default} = $word
                        if not exists($clusters->{default});
                  }
                elsif (($state == 2) and ($word eq "{"))
                  {
                    $state = 3;
                  }
                elsif (($state == 3) and ($word =~ m/^([^:]*)(?::([^:]*))?$/o))
                  {
                    if (length($1))
                      {
                        $state = 4;
                        $cluster->{external} = $1;
                        $cluster->{internal} = defined($2)?$2:$1;
                        $cluster->{nodes} = [];
                      }
                    else
                      {
                        $state = 7;
                        $cluster->{indirect} = $2;
                      }
                  }
                elsif (($state == 5) and ($word =~ m/^exclude(\[.*)?$/o))
                  {
                    my $range = $1;
                    $range = shift @words if not defined($range);
                    if (defined($range))
                      {
                        if (exists($current_hosts->{exclude}))
                          {
                            $current_hosts->{exclude} .=
                                         ",".$prefix.$range.$suffix;
                          }
                        else
                          {
                            $current_hosts->{exclude} = $prefix.$range.$suffix;
                          }
                      }
                    else
                      {
                        $state = 4;
                        push @$nodes, { name=>$word, alive=>1 };
                      }
                  }
                elsif (($state == 4) or ($state == 5))
                  {
                    push @$nodes, $current_hosts if defined($current_hosts);
                    $current_hosts = undef;
                    if ($word eq "dead")
                      {
                        if (scalar(@words))
                          {
                            foreach my $host (@words)
                              {
                                push @$nodes, { name=>$host, alive=>0 };
                              }
                            @words = ();
                          }
                        else
                          {
                            $state = 4;
                            push @$nodes, { name=>$word, alive=>1 };
                          }
                      }
                    elsif ($word eq "}")
                      {
                        $state = 0;
                      }
                    else
                      {
                        if ($word =~ m/^([^[]*)\[([0-9]+)-([0-9]+)\](.*)$/o)
                          {
                            $prefix = $1;
                            my $min = $2;
                            my $max = $3;
                            $suffix = $4;
                            $current_hosts = { prefix=>$prefix, min=>$min,
                                               max=>$max, suffix=>$suffix };
                            $state = 5;
                          }
                        else
                          {
                            push @$nodes, { name=>$word, alive=>1 };
                            $state = 4;
                          }
                      }
                  }
                elsif (($state == 7) and ($word eq "}"))
                  {
                    $state = 0;
                  }
                else
                  {
                    warn "Syntax error in $name line $line_num word $word";
                  }
              }
          }
        warn "File $name ended unexpectedly" if $state != 0;
        close $fd;
      }
  }

sub get_cluster_interval($$$)
  {
    my $name = shift;
    my $range_min = shift;
    my $range_max = shift;

    my @result = ();

    $range_max = $range_min if not defined($range_max);
    $range_max++ if defined($range_max);
    $name = $clusters->{default} if not $name;
    if (defined($name) and exists($clusters->{$name}))
      {
        if (exists($clusters->{$name}->{indirect}))
          {
            diagnostic::warning("Indirect clusters still not supported\n");
          }
        elsif ($arguments::option->{head})
          {
            push @result, $clusters->{$name}->{internal};
          }
        else
          {
            my $nodes = $clusters->{$name}->{nodes};

            foreach my $node (@$nodes)
              {
                my ($min, $max, $count) = (-1, -1, 1);
                if (exists($node->{prefix}))
                  {
                    $min = $node->{min};
                    $max = $node->{max};
                    $count = $max - $min + 1;
                  }
                if (not defined($range_max) or $range_max)
                  {
                    # First case : current node interval is not in the range
                    if (defined($range_min) and ($range_min >= $count))
                      {
                        $range_min -= $count;
                        $range_max -= $count;
                      }
                    else
                      {
                        # Current node interval do not match range beginning
                        if ($range_min)
                          {
                            $range_max -= $range_min;
                            $count -= $range_min;
                            $min += $range_min;
                            $range_min = 0;
                          }
                        # More nodes in the range than in current interval
                        if (defined($range_max) and ($range_max > $count))
                          {
                            $range_max -= $count;
                          }
                        # Otherwise we take a subset of current interval
                        elsif (defined($range_max))
                          {
                            $count -= $range_max;
                            $max -= $count;
                            $range_max = 0;
                          }
                        if (exists($node->{prefix}))
                          {
                            my $host_spec = output::get_host_string(
                                            $node->{prefix}, $min, $max, [],
                                            $node->{suffix});
                            $host_spec .= "/".$node->{exclude}
                                if (exists($node->{exclude}));
                            push @result, $host_spec;
                          }
                        else
                          {
                            push @result, $node->{name} if $node->{alive};
                          }
                      }
                  }
              }
          }
      }
    return @result;
  }

sub read_cluster_specs()
  {
    while (scalar(@ARGV) and
           ($ARGV[0] =~ m/^([^:]*):(?:([0-9]+)(?:-([0-9]+))?)?$/o))
      {
        push @clusters_spec, get_cluster_interval($1,$2,$3);
        shift @ARGV;
      }
  }

sub get_environment($)
  {
    my $prefix = shift;

    foreach my $key (keys(%ENV))
      {
        if ($key =~ m/^${prefix}_(.*)$/)
          {
            my $name = lc($1);
            $name =~ tr/_/-/;
            $option->{$name} = $ENV{$key};
          }
      }
  }

sub parse_kanif_arguments()
  {
    #get_environment('C3');
    #get_environment('DSH');
    get_environment('KANIF');
    Getopt::Long::Configure('bundling');
    GetOptions(%getopt_config);
    if ($arguments::option->{all} or (exists($ARGV[0]) and ($ARGV[0] =~ m/:/)))
      {
        read_cluster_config();
        diagnostic::debug(Dumper($clusters));
        read_cluster_specs();
        diagnostic::debug(Dumper(@clusters_spec));
        if ($arguments::option->{all})
          {
            @clusters_spec = ();
            foreach my $name (keys(%$clusters))
              {
                push @clusters_spec, get_cluster_interval($name,undef,undef)
                    if ($name ne 'default');
              }
          }
      }
    my $nodes = $arguments::option->{nodes};
    my $exclude = join(',', @{$arguments::option->{exclude}});
    foreach my $node (@$nodes)
      {
        if ($node eq "-")
          {
            push @{$arguments::option->{list}}, $node;
          }
        else
          {
            $node .= "/".$exclude if $exclude and ($node !~ /\//);
            push @clusters_spec, $node;
          }
      }
    if (not scalar(@clusters_spec)
            and not scalar(@{$arguments::option->{list}}))
      {
        read_cluster_config();
        push @clusters_spec, get_cluster_interval(undef,undef,undef);
      }
  }

###############################################################################
# PACKAGE  INPUT                                                              #
###############################################################################

package input;

use strict;
use IO::Select;

sub add_stream($$);
sub new();
sub readloop();

our $select;
our %buffer;
our %handle;

sub add_stream($$)
  {
    my $self = shift;
    my $fd = shift;
    my $handle = shift;

    binmode($fd);
    $self->{select}->add($fd);
    $self->{buffer}->{$fd} = "";
    $self->{handle}->{$fd} = $handle;
  }

sub new()
  {
    my $data = {};
    $data->{select} = IO::Select->new;
    die "Cannot create select object" unless $data->{select};
    $data->{buffer} = {};
    $data->{handle} = {};
    bless($data, shift);
    return $data;
  }

sub readloop()
  {
    my $self = shift;

    while ($self->{select}->count())
      {
        my @handles = $self->{select}->can_read();
        while (scalar(@handles))
          {
            my $handle = shift @handles;
            my $result = sysread($handle, $self->{buffer}->{$handle}, 4096, 
                                 length($self->{buffer}->{$handle}));
            if (defined($result))
              {
                my $new_handle = &{$self->{handle}->{$handle}}($handle,
                                        \$self->{buffer}->{$handle}, $result);
                $self->add_stream($new_handle, $self->{handle}->{$handle})
                    if (defined($new_handle));
                $self->remove_stream($handle) unless $result; 
              }
            else
              {
                diagnostic::error("While reading : $!")
                    if (not exists($!{EINTR}));
              } 
          }
      }
  }

sub remove_stream($)
  {
    my $self = shift;
    my $fd = shift;

    $self->{select}->remove($fd);
    delete $self->{buffer}->{$fd};
    delete $self->{handle}->{$fd};
  }

###############################################################################
# PACKAGE OUTPUT                                                              #
###############################################################################

package output;

use strict;
use Data::Dumper;

our $prompt_state = 0;
our $has_prompt = 0;

sub convert_output($$);
sub gather_output($);
sub get_host_string($$$$$);
sub get_host_parts($);
sub group_host_list(@);
sub no_flush($);
sub print_conf();
sub print_help();
sub print_hosts_output($$$);
sub print_failures();
sub print_result();
sub skip_prompt();
sub restore_prompt();
sub title($$);

sub convert_output($$)
  {
    my $host = shift;
    my $line = shift;

    if (($arguments::option->{postprocess} > 0) and
        ($arguments::option->{postprocess} < 3))
      {
        chomp $line;
        $line =~ s/\n/\n$host: /gm;
        $line = "$host: $line\n";
      }
    return $line;
  }

sub gather_output($)
  {
    my $output = shift;
    my %temp;
    my %pid;

    foreach my $host (keys(%$output))
      {
        foreach my $pid (keys(%{$output->{$host}}))
          {
            if (exists($temp{$output->{$host}->{$pid}}))
              {
                push @{$temp{$output->{$host}->{$pid}}}, $host;
              }
            else
              {
                $temp{$output->{$host}->{$pid}} = [ $host ];
                $pid{$output->{$host}->{$pid}} = $pid;
              }
          }
      }
    %$output = ();
    foreach my $content (keys(%temp))
      {
        my @hosts = sort (@{$temp{$content}});
        my $string;

        $string = group_host_list(@hosts);
        $output->{$string}->{$pid{$content}} = $content;
      }
  }

sub get_host_string($$$$$)
  {
    my $prefix = shift;
    my $min = shift;
    my $max = shift;
    my $intervals = shift;
    my $suffix = shift;

    if (defined($prefix))
      {
        if (scalar(@$intervals) or ($min < $max))
          {
            my $string = $prefix."[";

            while (scalar(@$intervals))
              {
                my $min = shift @$intervals;
                my $max = shift @$intervals;

                $string .= $min;
                if ($min < $max)
                  {
                    $string .= "-".$max;
                  }
                $string .= ",";
              }
            $string .= $min;
            if ($min < $max)
              {
                $string .= "-".$max;
              }
            return $string."]".$suffix;
          }
        else
          {
            return $prefix.$min.$suffix;
          }
      }
    else
      {
        return "";
      }
  }

sub get_host_parts($) {
    my $host = shift;
    if ($host =~ m/^([^0-9]*)([0-9]+)(.*)$/o) {
        return ($1, $2, $3);
    } else {
        return ($host, "", "");
    }
}

sub group_host_list(@)
  {
    my ($prefix, $min, $max, $suffix) = (undef, undef, undef, undef);
    my $intervals = [];
    my $new_host = "";
    my $string = "";
    my $number = scalar(@_);

    my @sorted_list = sort {
        my ($a_prefix, $a_number, $a_suffix) = get_host_parts($a);
        my ($b_prefix, $b_number, $b_suffix) = get_host_parts($b);
        if (($a_prefix lt $b_prefix) ||
            (($a_prefix eq $b_prefix) && ($a_suffix lt $b_suffix)) ||
            (($a_prefix eq $b_prefix) && ($a_suffix eq $b_suffix) &&
             ($a_number < $b_number))) {
            return -1;
        }
        if (($a_prefix eq $b_prefix) && ($a_suffix eq $b_suffix) &&
            ($a_number == $b_number)) {
            return 0;
        }
        return 1;
    } @_;

    foreach my $host (@sorted_list)
      {
        my ($host_prefix, $number, $host_suffix) = get_host_parts($host);
        if (length($number))
          {
            if (defined($prefix) and ($host_prefix eq $prefix)
                and ($host_suffix eq $suffix))
              {
                if ($number <= $max+1)
                  {
                    $max = $number>$max?$number:$max;
                  }
                else
                  {
                    push @$intervals, $min, $max;
                    $min = $max = $number;
                  }
              }
            else
              {
                $new_host =
                    get_host_string($prefix, $min, $max, $intervals, $suffix);
                ($prefix, $min, $max, $suffix) =
                    ($host_prefix, $number, $number, $host_suffix);
              }
          }
        else
          {
            $new_host =
                    get_host_string($prefix, $min, $max, $intervals, $suffix);
            ($prefix, $min, $max, $suffix) = (undef, undef, undef, undef);
            $new_host .= ", " if length($new_host);
            $new_host .= $host;
          }
        $string .= ", " if length($string) and length($new_host);
        $string .= $new_host;
        $new_host = "";
      }
    $new_host = get_host_string($prefix, $min, $max, $intervals, $suffix);
    $string .= ", " if length($string) and length($new_host);
    $string .= $new_host." ($number HOST".($number>1?"S":"").")";
    return $string;
  }

sub no_flush($)
  {
    my $new_fd = shift;
    my $old_fd=select($new_fd);
    $|=1;
    select($old_fd);
  }

sub print_conf()
  {
    my $option = $arguments::option;
    print "Configuration:\n";
    foreach my $key (keys(%$option))
      {
        my $name = $key;
        $name =~ tr/-/_/;
        print("KANIF_".uc($name)."=$option->{$key}\n")
            if defined($option->{$key}) and not ref($option->{$key});
      }
    print "\nRemote machines:\n";
    print "Names: @clusters_spec\n" if scalar(@clusters_spec);
    print "Files: @{$option->{list}}\n"
        if scalar(@{$option->{list}});
    print "\nTakTuk command:\n";
    print "$main::taktuk_command\n";
  }

sub print_help()
  {
    print "Usage:\n";
    if ($main::command eq "kash")
      {
        print "kash [options] [machines specifications] command line\n";
      }
    elsif (($main::command eq "kaput") or ($main::command eq "kaget"))
      {
        print "$main::command [options] [machines specifications] ".
              "src1 [ src2 ... ] dest\n";
      }
    else
      {
        print "kanif should be invoked either as kash, kaput or kaget\n";
        return;
      }
    print <<END;

Options are:
-a, --all                 : deploys on all the nodes of the default cluster
-f, --file conf-file      : specifies another configuration file
-F, --flat-deployment     : deploys all remote peers from the root node
-H, --head                : deploys only on clusters head node
-h, --help                : prints this help
-i, --interactive         : asks confirmation before any action
-l, --login login         : specifies a login name to use for remote connections
-M, --list filename       : gives a file which contains machine names to deploy
-m, --monitoring          : turns monitoring mode on
-n, --nodes hosts set     : specifies a set of remote hosts
-o, --remote-opts opts    : gives additional options for the connection command
-p, --postprocess level   : sets the level of the pretty-printing postprocess
-q, --dry-run             : does nothing and prints configuration informations
-r, --remote-cmd name     : sets the command used for remote connections
-s, --sequential          : commands are executed sequentially (one at a time)
-T, --taktuk-options opts : additionnal options for taktuk (power users only)
-t, --timeout value       : connections timeout
-u, --upper-limit value   : commands execution timeout
-V, --version             : prints kanif version
-w, --wcoll hosts set     : synonym for -n
-x, --exclude hosts set   : set to exclude from deployment (applies to -n only)
END
  }

sub print_hosts_output($$$)
  {
    my $stream = shift;
    my $title = shift;
    my $hosts = shift;

    title($stream, $title)
        if (scalar(keys(%$hosts)) and $arguments::option->{postprocess} > 2);
    foreach my $host (keys(%$hosts))
      {
        foreach my $pid (keys(%{$hosts->{$host}}))
          {
            if (length($hosts->{$host}->{$pid}))
              {
                if ($arguments::option->{postprocess} > 2)
                  {
                    title($stream, $host);
                  }
                print $stream convert_output($host, $hosts->{$host}->{$pid});
              }
          }
      }
  }

sub print_failures()
  {
    my $result = $main::result;
    my $number;
    my $status = $result->{status};
    my $connector = $result->{connector};

    if ($arguments::option->{postprocess} > 1)
      {
        if (scalar(@$status) or scalar(@$connector))
          {
            skip_prompt;
            if ($number = scalar(@$status))
              {
                output::title(\*STDERR, "FAILED COMMANDS ON:");
                print STDERR output::group_host_list(@$status),"\n";
              }
            if ($number = scalar(@$connector))
              {
                output::title(\*STDERR, "FAILED CONNECTIONS TO:");
                print STDERR output::group_host_list(@$connector),"\n";
              }
            restore_prompt;
          }
      }
  }

sub print_result()
  {
    my $result = $main::result;
    my $number;

    if ($arguments::option->{postprocess} > 1)
      {
        if (scalar(%{$result->{output}}) or scalar(%{$result->{error}}))
          {
            skip_prompt;
            if ($arguments::option->{postprocess} >= 4)
              {
                output::gather_output($result->{output});
                output::gather_output($result->{error});
              }
            output::print_hosts_output(\*STDOUT, "STDOUT", $result->{output});
            output::print_hosts_output(\*STDERR, "STDERR", $result->{error});
            restore_prompt;
          }
      }
  }

sub skip_prompt()
  {
    if ($has_prompt and $prompt_state)
      {
        print "\n";
        $prompt_state = 0;
      }
  } 

sub restore_prompt()
  {
    if ($has_prompt and not $prompt_state and $main::is_idle and
        not $main::terminate)
      {
        print "kash> ";
        $prompt_state = 1;
      }
  } 

sub title($$)
  {
    my $stream = shift;
    my $title = shift;

    print $stream '-'x80, "\n";
    print $stream $title, "\n";
    print $stream '-'x80, "\n";
  }

###############################################################################
# PACKAGE MAIN                                                                #
###############################################################################

package main;

use strict;
use bytes;
use File::Basename;
use Data::Dumper;
use Fcntl;
use POSIX 'setsid';
use IO::Select;

our $MAJOR_VERSION="1.2.2";
our $REVISION=sprintf "%d", q$Rev: 556 $ =~ /(\d+)/g;

our $command = basename($0);
our %command_handler = (
                        kash  => \&kash,
                        kaget => \&kaget,
                        kaput => \&kaput
                       );
our %message_handler = (
                        connector => \&kash_connector,
                        output    => \&kash_output,
                        error     => \&kash_error,
                        info      => \&kash_info,
                        status    => \&kash_status,
                        state     => \&kash_state
                       );

our $taktuk_command;
our $taktuk_pid;
our $exec_command;
our $input;
our @current_lines = ();
our @current_commands = ();
our $ask_message;
our $read_channel = undef;
our $write_channel = undef;
our $file_read = undef;
our $file_write = undef;
our $read_size = 4096;
our $result;
our $deployment = { initialized => 0, failed => 0, lost => 0, count => undef,
                    numbered => 0, logical => [], name => [] };
our $first_time = 1;
our $is_idle = 1;
our $terminate = 0;
our $kash_terminated = 0;
our $interactive_blocked = 0;

sub ask($);
sub check_if_done();
sub execute_commands();
sub init_result();
sub kaget();
sub kaget_output($);
sub kaget_status($);
sub kaput();
sub kash();
sub kash_callback($$$);
sub kash_connector($);
sub kash_error($);
sub kash_info($);
sub kash_output($);
sub kash_status($);
sub kash_state($);
sub sequential_starting($$$);
sub sequential_execution();
sub taktuk_callback($$$);
sub write_callback($$$);

sub ask($)
  {
    my $message = shift;
    my $answer;

    if ($arguments::option->{interactive})
      {
        print STDERR $message, " ([yes]/no) ?\n" unless $interactive_blocked;
        $interactive_blocked = 0;
        if (scalar(@current_lines))
          {
            $answer = shift @current_lines;
          }
        elsif ($kash_terminated)
          {
            $answer = "yes";
          }
        else
          {
            $interactive_blocked = 1;
            return 0;
          }
        #chomp $answer;
        $answer = lc($answer);
        if (("yes" =~ m/^$answer/) or not length($answer))
          {
            return 1;
          }
        elsif ("no" =~ m/^$answer/)
          {
            return 0;
          }
        else
          {
            print STDERR $message, " ([yes]/no) ?\n";
            $interactive_blocked = 1;
            return 0;
          }
      }
    else
      {
        return 1;
      }
  }

sub check_if_done()
  {
    my $executed = 0;

    if (defined($deployment->{count}) and
        (($result->{terminated} + $result->{failed}) >= $deployment->{count}))
      {
        diagnostic::monitoring("All tasks terminated");
        output::print_result;
        init_result;
        $is_idle = 1;
        output::restore_prompt(); # if $deployment->{count};
        execute_commands;
      }
    if ($terminate)
      {
        if (defined($write_channel))
          {
            diagnostic::monitoring("Closing write channel");
            close($write_channel) or diagnostic::error("close error");
            $write_channel = undef;
          }
        $input->remove_stream(\*STDIN);
      }
  }

sub execute_commands()
  {
    my $done = 0;

    while (not $done)
      {
        if (not $interactive_blocked)
          {
            @current_commands = ();
            &{$command_handler{$command}};
          }
        if (scalar(@current_commands))
          {
            if ($arguments::option->{sequential})
              {
                $done = sequential_execution;
              }
            else
              {
                if (ask($ask_message." on remote hosts"))
                  {
                    foreach my $command (@current_commands)
                      {
                        print $write_channel "broadcast $command\n";
                      }
                    $done = 1;
                  }
              }
            $is_idle = not $done;
            $done = 1 if $interactive_blocked;
          }
        else
          {
            $done = 1;
          }
      }
  }

sub init_result()
  {
    $result = {started => 0, failed => 0, terminated => 0, current => 0,
         printed => 0,
         output=>{}, error=>{}, connector=>[], status=>[], status_max => 0};
  }

sub kaget()
  {
    my $dest;
    #$message_handler{output} = \&kaget_output;
    #$message_handler{status} = \&kaget_status;
    shift(@ARGV) unless $first_time;
    $dest = "$ARGV[$#ARGV]";
    if ($first_time and ($#ARGV > 0))
      {
        if (not -d $dest and not mkdir $dest)
          {
            diagnostic::error("Cannot create destination directory $dest");
            @ARGV = ();
            $first_time = 0;
          }
      }
    if ($#ARGV > 0)
      {
        my $src = $ARGV[0];
        diagnostic::monitoring("Getting $src");
        my $file = basename($src);
        @current_commands = ("get [ $src ] [ $dest/$file-\$host ]");
        $ask_message = "Get $src";
      }
    else
      {
        diagnostic::monitoring("Got all files");
        diagnostic::error("Kaget requires at least 2 arguments")
            if $first_time;
        $terminate = 1;
        @current_commands = ();
      }
  }

sub kaget_output($)
  {
    my ($host, $pid, $line) = split / /,shift,3;
    my $fd=undef;
    
    if (exists($result->{output}->{$host}->{$pid}))
      {
        $fd = $result->{output}->{$host}->{$pid};
      }
    else
      {
        my $basename = basename($ARGV[0]);
        my $dirname = "$ARGV[$#ARGV]/$host";
        my $directory_error = 0;
        if (not -d $dirname)
          {
            diagnostic::monitoring("Creating directory $dirname");
            if (not mkdir $dirname)
              {
                diagnostic::error("Cannot create directory $dirname");
                $directory_error = 1;
              }
          }
        if (not $directory_error)
          {
            if (not open($fd,"| cd $dirname && tar x"))
              {
                diagnostic::error("Cannot open: $!");
                $fd = "";
              }
          }
        else
          {
            $fd = "";
          }
        $result->{output}->{$host}->{$pid} = $fd;
      }
    print $fd $line if $fd;
  }

sub kaget_status($)
  {
    my $argument = shift;
    my ($host, $pid, $code) = split / /,$argument,3;

    my $fd = $result->{output}->{$host}->{$pid};
    close($fd) if $fd;
    delete $result->{output}->{$host}->{$pid};
    kash_status($argument);
  }

sub kaput()
  {
    if ($#ARGV > 0)
      {
        my $dest = $ARGV[$#ARGV];
        my $source = shift @ARGV;
        my $file = basename($source);
        my $dir = dirname($source);
        @current_commands = ("put [ $source ] [ $dest ]");
        $ask_message = "Put $file";
      }
    else
      {
        diagnostic::error("Kaput requires at least 2 arguments")
            if $first_time;
        $terminate = 1;
        @current_commands = ();
      }
  }

sub kash()
  {
    if (scalar(@ARGV))
      {
        if ($first_time)
          {
            @current_commands = ("$exec_command [ @ARGV ]");
            $ask_message = "Execute @ARGV";
          }
        else
          {
            $terminate = 1;
          }
      }
    else
      {
        if ($first_time)
          {
            $output::has_prompt = 1;
          }
        else
          {
            if (scalar(@current_lines))
              {
                my $command = "";
                while (($command =~ /^\s*$/o) and scalar(@current_lines))
                  {
                    $command = shift @current_lines;
                  }
                if ($command !~ /^\s*$/o)
                  {
                    @current_commands = ("$exec_command [ $command ]");
                    $ask_message = "Execute $command";
                  }
                else
                  {
                    output::restore_prompt;
                  }
              }
            else
              {
                $terminate |= $kash_terminated;
              }
          }
      }
  }

sub kash_callback($$$)
  {
    my $fd = shift;
    my $buffer = shift;
    my $result = shift;
    my $pos;

    $pos = index($$buffer, "\n");
    while ($pos >= 0)
      {
        $output::prompt_state = 0;
        push @current_lines, substr($$buffer, 0, $pos) if $pos;
        $$buffer = substr($$buffer, $pos+1);
        $pos = index($$buffer, "\n");
      }
    push @current_lines, $$buffer if $$buffer and not $result;
    $kash_terminated = 1 unless $result;
    execute_commands if $is_idle;
    check_if_done;
    return undef;
  }

sub kash_connector($)
  {
    my ($host, $peer, $line) = split / /,shift,3;

    diagnostic::monitoring("Connection errors : $line");
  }

sub kash_error($)
  {
    my ($host, $pid, $line) = split / /,shift,3;
    
    $result->{error}->{$host}->{$pid} = ""
                             if not exists($result->{error}->{$host}->{$pid});
    $result->{error}->{$host}->{$pid} .= $line;
    if ($arguments::option->{postprocess} < 2)
      {
        print STDERR output::convert_output($host,$line);
      }
  }

sub kash_info($)
  {
    my $line = shift;
    my @parts = split /\s/, $line;
    my $release = 0;
    my $has_taktuk = shift @parts eq "TakTuk";

    while (scalar(@parts)) {
        my $part = shift @parts;
        my $value = shift @parts;

        $release = $value if ($part eq "release");
    }

    if ($has_taktuk && ($release > 0)) {
        diagnostic::error("kanif requires at least TakTuk 3.3")
            if ($release < 361);
    } else {
        diagnostic::warning("Cannot recognize TakTuk version, ".
                            "proper execution not guaranteed");
      }
  }

sub kash_output($)
  {
    my ($host, $pid, $line) = split / /,shift,3;
    
    if (exists($result->{output}->{$host}->{$pid}))
      {
        $result->{output}->{$host}->{$pid} .= $line;
      }
    else
      {
        $result->{output}->{$host}->{$pid} = $line;
      }
    if ($arguments::option->{postprocess} < 2)
      {
        print output::convert_output($host,$line);
      }
  }

sub kash_status($)
  {
    my ($host, $pid, $code) = split / /,shift,3;

    diagnostic::monitoring("execution on $host terminated with status $code");
    if ($code)
      {
        push @{$result->{status}}, $host;
        $result->{status_max} = $code if $code>$result->{status_max};
        $result->{failed}++;
        diagnostic::monitoring("Command failed on $host");
      }
    else
      {
        $result->{terminated}++;
        diagnostic::monitoring("Command terminated on $host");
      }
  }

use constant TAKTUK_READY => 0;
use constant TAKTUK_NUMBERED => 1;
use constant TAKTUK_TERMINATED => 2;
use constant CONNECTION_FAILED => 3;
use constant CONNECTION_INITIALIZED => 4;
use constant CONNECTION_LOST => 5;
use constant COMMAND_STARTED => 6;
use constant COMMAND_FAILED => 7;
use constant COMMAND_TERMINATED => 8;
use constant UPDATE_FAILED => 9;
use constant PIPE_STARTED => 10;
use constant PIPE_FAILED => 11;
use constant PIPE_TERMINATED => 12;
use constant FILE_RECEPTION_STARTED =>13;
use constant FILE_RECEPTION_FAILED =>14;
use constant FILE_RECEPTION_TERMINATED =>15;
use constant FILE_SEND_FAILED =>16;

sub kash_state($)
  {
    my ($host, $position, $rank, $count, $peer, $code) = split / /,shift,6;

    if ($code eq CONNECTION_INITIALIZED)
      {
        $deployment->{initialized}++;
      }
    elsif ($code eq CONNECTION_FAILED)
      {
        diagnostic::monitoring("Connection from $host to $peer failed");
        $deployment->{failed}++;
        push @{$result->{connector}}, $peer;
      }
    elsif ($code eq CONNECTION_LOST)
      {
        diagnostic::monitoring("Lost connection to $peer (from $host)");

        # TODO : All of this should only apply to remaining nodes
        # (a connection loss might indice the loss of several nodes)
        # TakTuk 3.7 do not provide sufficient information to do this 
        # For next time round, make sure we don't include this
        # host in the number that are deployed, otherwise it'll hang:
        $deployment->{count}--;
        # TODO : to do only if logical exists for the given position
        $deployment->{numbered}--;
        $deployment->{lost}++;
        # TODO : update logical and name

        push @{$result->{connector}}, $peer;
        $result->{failed}++;

        # TODO : only if the lost connection 
        sequential_execution;
        check_if_done;
      }
    elsif ($code eq TAKTUK_NUMBERED)
      {
        if (not $count)
          {
            output::skip_prompt();
            print "No host have been deployed\n";
            $terminate = 1;
          }
        if (not defined($deployment->{count}))
          {
            $deployment->{count} = $count;
            output::print_failures();
          }
        $deployment->{numbered}++ if $rank;
        sequential_starting($host, $position, $rank);
        check_if_done;
      }
    elsif ($code eq COMMAND_STARTED)
      {
        $result->{started}++;
        diagnostic::monitoring("Command started on $host");
      }
    elsif ($code eq COMMAND_FAILED)
      {
        $result->{failed}++;
        diagnostic::monitoring("Command failed on $host");
        sequential_execution;
        check_if_done;
      }
    elsif ($code eq COMMAND_TERMINATED)
      {
        sequential_execution;
        check_if_done;
      }
    elsif ($code eq FILE_RECEPTION_STARTED)
      {
        $result->{started}++;
        diagnostic::monitoring("File reception started on $host");
      }
    elsif ($code eq FILE_RECEPTION_FAILED)
      {
        $result->{failed}++;
        diagnostic::monitoring("File reception failed on $host");
        sequential_execution;
        check_if_done;
      }
    elsif ($code eq FILE_RECEPTION_TERMINATED)
      {
        $result->{terminated}++;
        diagnostic::monitoring("File reception terminated on $host");
        sequential_execution;
        check_if_done;
      }
    elsif ($code eq FILE_SEND_FAILED)
      {
        $result->{failed} = $deployment->{count};
        diagnostic::monitoring("File send failed on $host");
        # No sequential execution here
        check_if_done;
      }
  }

sub sequential_starting($$$)
  {
    if ($arguments::option->{sequential})
      {
        my $host = shift;
        my $position = shift;
        my $rank = shift;

        $deployment->{logical}->[$position] = $rank;
        $deployment->{name}->[$position] = $host;
        sequential_execution
            if $deployment->{numbered} == $deployment->{count};
      }
  }

sub sequential_execution()
  {
    my $done = 0;
    my $executed = 0;

    if ($arguments::option->{sequential} and
        defined($deployment->{count}) and
        ($deployment->{numbered} == $deployment->{count}) and
        scalar(@current_commands))
      {
        while (not $done)
          {
            if (not $interactive_blocked)
              {
                do
                  {
                    $result->{current}++;
                  }
                while (not exists($deployment->{logical}->[$result->{current}]))
                    and ($result->{current} <= $#{$deployment->{logical}});
              }

            if (exists($deployment->{logical}->[$result->{current}]))
              {
                my $number = $deployment->{logical}->[$result->{current}];
                if (ask($ask_message." on ".
                    $deployment->{name}->[$result->{current}]))
                  {
                    foreach my $command (@current_commands)
                      {
                        print $write_channel "$number $command\n";
                      }
                    $done = 1;
                    $executed = 1;
                  }
                else
                  {
                    $result->{terminated}++;
                  }
              }
            else
              {
                $done = 1;
                diagnostic::error("Internal bug in sequential execution")
                    if ($result->{terminated} + $result->{failed}
                        != $deployment->{count});
              }
          }
      }
    else
      {
        $executed = 1;
      }
    return $executed;
  }

sub myprint($$$)
  {
    my $handle = shift;
    my $buffer = shift;
    my $result = shift;
    print $$buffer, "\n";
    $$buffer = "";
    return undef;
  }

sub taktuk_callback($$$)
  {
    my $handle = shift;
    my $buffer = shift;
    my $result = shift;
    my $done = 0;

    $done = 1 unless $result;
    while (not $done)
      {
        my $pos = undef;
        my $size = undef;
        $pos = index($$buffer," ");
        if ($pos >= 0)
          {
            $size = substr($$buffer, 0, $pos);
          }
        else
          {
            $done = 1;
          }
        if (not $done and (length($$buffer) - $pos > $size))
          {
            my $message = substr($$buffer, $pos+1, $size);
            $$buffer = substr($$buffer, $pos+1+$size);
            my ($message_code, $args) = split / /,$message,2;
            if (exists($message_handler{$message_code}))
              {
                &{$message_handler{$message_code}}($args);
              }
            else
              {
                diagnostic::error("FATAL: protocol internal error");
                exit 1;
              }
          }
        else
          {
            $done = 1;
          }
      }
    return undef;
  }

sub write_callback($$$)
  {
    my $handle = shift;
    my $buffer = shift;
    my $result = shift;
    my $new_input = undef;

    if ($result)
      {
        my $offset = 0;
        while ($result)
          {
            my $nb_write;

            $nb_write = syswrite($file_write, $$buffer, $result, $offset);
            if (defined($nb_write))
              {
                $result -= $nb_write;
                $offset += $nb_write;
              }
            else
              {
                diagnostic::error("Write error");
              }
          }
        $$buffer = "";
      }
    else
      {
        syswrite($file_write, "\n", 1) or diagnostic::error("Write error");
        while (not defined($new_input)
               and scalar(@{$arguments::option->{list}}))
          {
            my $filename = shift @{$arguments::option->{list}};
            if (not open($new_input, $filename))
              {
                diagnostic::error("Cannot open $filename");
                $new_input = undef;
              }
          }
        if (not defined($new_input))
          {
            close($file_write) or diagnostic::error("close error");
          }
      }
    return $new_input;
  }

arguments::parse_kanif_arguments();
init_result();
$diagnostic::current_level = 1 if $arguments::option->{monitoring};

my $default_remote_cmd = "ssh -o StrictHostKeyChecking=no -o BatchMode=yes";
my $remote_cmd = defined($arguments::option->{'remote-cmd'})?
           $arguments::option->{'remote-cmd'}:$default_remote_cmd;
$remote_cmd .= " ".$arguments::option->{'remote-opts'}
                              if defined($arguments::option->{'remote-opts'});

$taktuk_command = "taktuk";
$taktuk_command .= " $arguments::option->{'taktuk-options'}";
$taktuk_command .= " -d-1" if $arguments::option->{'flat-deployment'};
$taktuk_command .= " -c '$remote_cmd'" if $remote_cmd ne $default_remote_cmd;
$taktuk_command .= " -l $arguments::option->{user}"
                                       if defined($arguments::option->{user});
$taktuk_command .= " -t $arguments::option->{timeout}"
                                    if defined($arguments::option->{timeout});
$taktuk_command .= ' -o connector='.
                   '\'($user_scalar="connector $host $peer $line"),'.
                   '(length($user_scalar)." ".$user_scalar)\'';
$taktuk_command .= ' -o default='.
                   '\'($user_scalar="$type $host $pid $line$eol"),'.
                   '(length($user_scalar)." ".$user_scalar)\'';
$taktuk_command .= ' -o status='.
                   '\'($user_scalar="status $host $pid $line"),'.
                   '(length($user_scalar)." ".$user_scalar)\'';
$taktuk_command .= ' -o state='.
                   '\'($user_scalar="state $host $position $rank $count '.
                   '$peer $line"),(length($user_scalar)." ".$user_scalar)\'';
$taktuk_command .= ' -o info='.
                   '\'($user_scalar="info $line$eol"),'.
                   '(length($user_scalar)." ".$user_scalar)\'';
# Actually we do want to see taktuk errors and warning
#$taktuk_command .= ' -o taktuk';
# When a list option is given, we proceed in two steps :
# first open a pipe for upcoming taktuk process
# later transmit the file to taktuk using the opened pipe
# This is done this way to allow hosts inputs from stdin
if (scalar(@{$arguments::option->{list}}))
  {
    if (pipe($file_read, $file_write))
      {
        fcntl($file_read, F_SETFD, 0);
        $taktuk_command .= " -f '<&=".fileno($file_read)."'";
      }
    else
      {
        $file_write = undef;
        diagnostic::error("Cannot pipe");
      }
  }
$taktuk_command .= " -m ".join(" -m ",@arguments::clusters_spec)
    if scalar(@arguments::clusters_spec);

$exec_command = "exec";
$exec_command .= " timeout ".$arguments::option->{'upper-limit'}
                              if defined($arguments::option->{'upper-limit'});

if ($arguments::option->{help})
  {
    output::print_help;
    exit 0;
  }
elsif ($arguments::option->{'dry-run'})
  {
    output::print_conf;
    exit 0;
  }
elsif ($arguments::option->{version})
  {
    print("kanif version $MAJOR_VERSION revision $REVISION\n");
    print("Designed and written by Guillaume Huard\n");
    exit 0;
  }
elsif (not exists($command_handler{$command}))
  {
    die "ERROR: this script must be invoked using one of the following names".
        "\nkash  - to execute commands on remote hosts".
        "\nkaput - to copy files to remote hosts".
        "\nkaget - to gather files from remote hosts\n";
    exit 0;
  }

my ($child_read, $child_write);
(pipe($child_read, $write_channel) and pipe($read_channel, $child_write))
    or die "$!";
output::no_flush($write_channel);
output::no_flush(\*STDOUT);
$taktuk_pid = fork();
die "Cannot launch TakTuk" if not defined($taktuk_pid);
if (not $taktuk_pid)
  {
    setsid;
    close($read_channel) or die "$!";
    close($write_channel) or die "$!";
    open(STDIN,"<&",$child_read) or die "$!";
    open(STDOUT,">&",$child_write) or die "$!";
    close($child_read) or die "$!";
    close($child_write) or die "$!";
    exec($taktuk_command) or die "$!";
  }
else
  {
    close($child_read) or die "$!";
    close($child_write) or die "$!";
  }

print $write_channel "version\n";

# Now serious stuff
$input = input->new;
die "Cannot create select object" unless $input;

if (defined($file_write))
  {
    # First call to add descriptors (if any) to the listened inputs
    my $new_handle = write_callback(undef, undef, 0);
    $input->add_stream($new_handle, \&write_callback) if defined($new_handle);
  }

execute_commands;
output::restore_prompt;
$first_time = 0;
binmode($read_channel);
$input->add_stream($read_channel, \&taktuk_callback);
$input->add_stream(\*STDIN, \&kash_callback);

$input->readloop;
output::print_result;
output::skip_prompt;
