xcat-core/xCAT-server-2.0/sbin/xcatd

#!/usr/bin/env perl
# IBM(c) 2007 EPL license http://www.eclipse.org/legal/epl-v10.html
BEGIN
{
    $::XCATROOT = $ENV{'XCATROOT'} ? $ENV{'XCATROOT'} : '/opt/xcat';
}
use lib "$::XCATROOT/lib/perl";
use Storable qw(freeze thaw);
use xCAT::Utils;
use File::Path;
use xCAT::Client submit_request;

use IO::Socket::SSL;
if (xCAT::Utils->isLinux()) {
        eval { require Socket6 };
        eval { require IO::Socket::INET6 };
        eval { require IO::Socket::SSL::inet6 };
} else {
		eval { require Socket };
        eval { require IO::Socket::INET };
}

use IO::Socket;
use IO::Handle;
use IO::Select;
use XML::Simple;
use xCAT::Table;
use Data::Dumper;
use Getopt::Long;
use Sys::Syslog;
use xCAT::NotifHandler;
use xCAT_monitoring::monitorctrl;


Getopt::Long::Configure("bundling");
Getopt::Long::Configure("pass_through");


use Storable qw(dclone);
use POSIX qw(WNOHANG setsid);
use strict;
my $pidfile;
GetOptions(
  'pidfile|p=s' => \$pidfile
);

my $quit = 0;
my $port;
my $sport;
my $domain;
my $xcatdir;
my $sitetab=xCAT::Table->new('site');
unless ($sitetab) {
    print ("ERROR: Unable to open basic site table for configuration\n");
}

my ($tmp) = $sitetab->getAttribs({'key'=>'xcatdport'},'value');
unless ($tmp) {
  die "ERROR:Need xcatdport defined in site table, try chtab key=xcatdport site.value=3001";
}
$port = $tmp->{value};
$sport = $tmp->{value}+1;


my $plugins_dir=$::XCATROOT.'/lib/perl/xCAT_plugin';
($tmp) = $sitetab->getAttribs({'key'=>'xcatconfdir'},'value');
$xcatdir = (($tmp and $tmp->{value}) ? $tmp->{value} : "/etc/xcat");

$sitetab->close;
my $progname;
$SIG{PIPE} = sub { die "SIGPIPE $$progname encountered a broken pipe (probably Ctrl-C by client)" };
$progname = \$0;
sub daemonize {
  chdir('/');
  umask 0;
  my $pid;
  defined($pid = xCAT::Utils->xfork) or die "Can't fork: $!";
  if ($pid) {
    if ($pidfile) {
      open(PFILE, '>', $pidfile);
      print PFILE $pid;
      close (PFILE);
    } else {
      printf ("xCATd starting as PID $pid \n");
    }
    exit;
  }
  open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
  open STDOUT, '>/dev/null';
  open STDERR, '>/dev/null';
  $0='xcatd';
  $progname = \$0;
  setsid or die "Can't start new session";
}
  
my %cmd_handlers;
sub do_installm_service { 
  #This function servers as a handler for messages from installing nodes

my $socket;
if (xCAT::Utils->isLinux()) {
  $socket = IO::Socket::INET6->new(LocalPort=>$sport,
                                     Proto    => 'tcp',
                                     ReuseAddr => 1,
                                     Listen => 64);
} else {
	 $socket = IO::Socket::INET->new(LocalPort=>$sport,
                                     Proto    => 'tcp',
                                     ReuseAddr => 1,
                                     Listen => 64);
}

  unless ($socket) {
    syslog("local4|err","xcatd unable to open install monitor services on $sport");
    die;
  }
  until ($quit) {
    $SIG{ALRM} = sub { die "XCATTIMEOUT"; }; 
    my $conn;
    next unless $conn = $socket->accept;

my @clients;
if (xCAT::Utils->isLinux()) {
    @clients = gethostbyaddr($conn->peeraddr,AF_INET6);
} else {
    @clients = gethostbyaddr($conn->peeraddr,AF_INET);
}

    my $validclient=0;
    my $node;
    foreach my $client (@clients) {
        $client =~ s/\..*//;
        ($node) = noderange($client); #ensure this is coming from a node IP at least
        if ($node) {  #Means the source isn't a valid deal...
        $validclient=1;
        last;
        }
    }
    unless ($validclient) {
        close($conn);
        next;
    }
	my $tftpdir = "/tftpboot/";
    eval {
      alarm(2);
      print $conn "ready\n";
      while (my $text = <$conn>) {
        alarm(0);
        print $conn "done\n";
        $text =~ s/\r//g;
        if ($text =~ /next/) {
          my %request = (
            command => [ 'nodeset' ],
            node => [ $node ],
            arg => [ 'next' ],
            );
          close($conn);
          my $pid=xCAT::Utils->xfork();
          unless ($pid) { #fork off the nodeset and potential slowness
            plugin_command(\%request,undef,\&convey_response);
            exit(0);
          }
        } elsif ($text =~ /^unlocktftpdir/) { #TODO: only nodes in install state should be allowed
            close($conn);
            mkpath("$tftpdir/xcat/$node");
	    chmod 01777,"$tftpdir/xcat/$node";
	    chmod 0666,glob("$tftpdir/xcat/$node/*");
	} elsif ($text =~ /locktftpdir/) {
	    chmod 0755,"$tftpdir/xcat/$node";
	    chmod 0644,glob("$tftpdir/xcat/$node/*");
	} elsif ($text =~ /^setnetboot/) { 
	    $text =~ s/^setnetboot\s+//;
	    my $kname;
	    my $iname;
	    my $kcmdline;
	    ($kname,$iname,$kcmdline) = split(/\s+/,$text,3);
	    chomp($kcmdline);
	    my $noderestab = xCAT::Table->new('noderes',-create=>1);
	    $noderestab->setNodeAttribs($node,{kernel=>"xcat/$node/$kname",initrd=>"xcat/$node/$iname",kcmdline=>$kcmdline});
	    my $chaintab = xCAT::Table->new('chain',-create=>1);
	    $chaintab->setNodeAttribs($node,{currstate=>'netboot',currchain=>'netboot'});
	    $noderestab->close;
	    $chaintab->close;
	    undef $noderestab;
	    undef $chaintab;
	    my %request = (
	       command => [ 'nodeset' ],
	       node => [ $node ],
	       arg => [ 'enact' ],
	    );
          my $pid=xCAT::Utils->xfork();
          unless ($pid) { #fork off the nodeset and potential slowness
            plugin_command(\%request,undef,\&convey_response);
            exit(0);
          }
	}
        alarm(2);
      }
      alarm(0);
    };
    if ($@) {
      if ($@ =~ /XCATTIMEOUT/) {
        syslog("local4|err","xcatd installmonitor timed out talking to $node");
      } else {
        syslog("local4|err","xcatd: possible BUG encountered by xCAT install monitor service: ".$@);
      }
    }
  }
}
    

sub do_udp_service { #This function opens up a UDP port
  #It will do similar to the standard service, except:
  #-Obviously, unencrypted and messages are not guaranteed
  #-For that reason, more often than not plugins designed with
  #-this method will not expect to have a callback
  #Also, this throttles to handle one message at a time, so no forking either
  #Explicitly, to handle whatever operations nodes periodically send during discover state
  #Could be used for heartbeating and such as desired

my $socket;
   my $select = new IO::Select;
if (xCAT::Utils->isLinux()) {
  $socket = IO::Socket::INET6->new(LocalPort => $port,
                                     Proto     => 'udp',
                                     Domain => AF_INET);
} else {
  $socket = IO::Socket::INET->new(LocalPort => $port,
                                     Proto     => 'udp',
                                     Domain => AF_INET);
}

  $select->add($socket);
  openlog("xCAT UDP",'','local4');
  unless ($socket) {
    syslog("err","xCAT UDP service unable to open port $port: $!");
    closelog();
    die "Unable to start UDP on $port";
  }
  my $data;
  my $part;
  my $sport;
  my $client;
  my $peerhost;
  my %packets;
  until ($quit) {
    eval { 
	while (1) {	
        until ($select->can_read(5)) {if ($quit) { last; }} #Wait for data
	while ($select->can_read(0)) { #Pull all buffer data that can be pulled
	   $part = $socket->recv($data,1500);
           ($sport,$client) = sockaddr_in($part);
           $packets{inet_ntoa($client)} = [$part,$data];
	}
      foreach my $pkey (keys %packets) {
        ($sport,$client) = sockaddr_in($packets{$pkey}->[0]);
        $data=$packets{$pkey}->[1];
        $peerhost=gethostbyaddr($client,AF_INET)."\n";
        my $req = eval { XMLin($data, SuppressEmpty=>undef,ForceArray=>1) };
        if ($req and $req->{command} and ($req->{command}->[0] eq "findme")) {
          $req->{'_xcat_clienthost'}=gethostbyaddr($client,AF_INET)."\n";
          $req->{'_xcat_clientip'}=inet_ntoa($client);
          $req->{'_xcat_clientport'}=$sport;
          if (defined($cmd_handlers{"findme"})) {
            $req->{cacheonly}->[0] = 1;
            plugin_command($req,undef,\&convey_response);
  	    if ($req->{cacheonly}->[0]) {
		delete $req->{cacheonly};
                plugin_command($req,undef,\&convey_response);
	    }
          }
        }
        if ($quit) { last; }
        while ($select->can_read(0)) { #grab any incoming requests during run
	   $part = $socket->recv($data,1500);
           ($sport,$client) = sockaddr_in($part);
           $packets{inet_ntoa($client)} = [$part,$data];
	}
        #Some of those 'future' packets might be stale dupes of this packet, so...
	delete $packets{$pkey}; #Delete any duplicates of current packet
      }
      if ($quit) { last; }
    }
    };
    if ($@) {
      syslog("local4|err","xcatd: possible BUG encountered by xCAT UDP service: ".$@);
    }
  }
}



sub scan_plugins {
  my @plugins=glob($plugins_dir."/*.pm");
  foreach (@plugins) {
    /.*\/([^\/]*).pm$/;
    my $modname = $1;
    require "$_";
    no strict 'refs';
    my $cmd_adds=${"xCAT_plugin::".$modname."::"}{handled_commands}->();
    foreach (keys %$cmd_adds) {
      my $value = $_;
      if (defined($cmd_handlers{$_})) {
        my $add=1;
        #This next bit of code iterates through the handlers.
        #If the value doesn't contain an equal, and has an equivalent entry added by 
        # another plugin already, don't add (otherwise would hit the DB multiple times)
        # a better idea, restructure the cmd_handlers as a multi-level hash
        # prove out this idea real quick before doing that
        foreach (@{$cmd_handlers{$_}}) {
          if (($_->[1] eq $cmd_adds->{$value}) and (($cmd_adds->{$value} !~ /=/) or ($_->[0] eq $modname))) {
            $add = 0;
          }
        }
        if ($add) { push @{$cmd_handlers{$_}},[$modname,$cmd_adds->{$_}]; }
        #die "Conflicting handler information from $modname";
      } else {
        $cmd_handlers{$_} = [ [$modname,$cmd_adds->{$_}] ];
      }
    }
  }
}
scan_plugins;
daemonize;
$SIG{CHLD} = sub { while (waitpid(-1,WNOHANG) > 0) {} };
$SIG{TERM} = $SIG{INT} = sub { printf("Asked to quit...\n"); $quit++ };
  
my $pid = xCAT::Utils->xfork;
defined $pid or die "Unable to fork for UDP/TCP";
unless ($pid) {
  $$progname="xcatd: UDP listener";
  do_udp_service;
  exit(0);
}
$pid = xCAT::Utils->xfork;
defined $pid or die "Unable to fork installmonitor";
unless ($pid) {
  $$progname="xcatd: install monitor";
  do_installm_service;
  exit(0);
}
$$progname="xcatd: SSL listener";
openlog("xCAT SSL","","local4");
my $listener = IO::Socket::SSL->new(
    LocalPort => $port,
    Listen => 64,
    Reuse => 1,
    SSL_key_file=>$xcatdir."/cert/server-key.pem",
    SSL_cert_file=>$xcatdir."/cert/server-cert.pem",
    SSL_ca_file=>$xcatdir."/cert/ca.pem",
    SSL_verify_mode=> 1
    );

unless ($listener) {
  kill $pid;
  syslog("err","xCAT service unable to open SSL services on $port: $!");
  closelog();
  die "ERROR:Unable to start xCAT service on port $port.";
}
closelog();

#setup signal in NotifHandler so that the cache can be updated
xCAT::NotifHandler::setup($$);

#start the monitoring process
xCAT_monitoring::monitorctrl::start($$);

my $peername;
until ($quit) {
  next unless my $connection=$listener->accept;
  my $child = xCAT::Utils->xfork(); #Yes we fork, IO::Socket::SSL is not threadsafe..
  
  unless (defined $child) {
    die "xCATd cannot fork";
  }

  if ($child == 0) {
    $listener->close;
    my $peerhost=undef;
    my $peer=$connection->peer_certificate("owner");
    if ($peer) {
      $peer =~ m/CN=([^\/]*)/;
      $peername = $1;
    } else {
      $peername=undef;
    }
    $sitetab=xCAT::Table->new('site');
    my ($tmp) = $sitetab->getAttribs({'key'=>'domain'},'value');
    if (defined $tmp->{value}) {
        $domain = $tmp->{value};
    }
    $sitetab->close;

if (xCAT::Utils->isLinux()) {
    $peerhost = gethostbyaddr($connection->peeraddr,AF_INET6);
} else {
    $peerhost = gethostbyaddr($connection->peeraddr,AF_INET);
}


    unless ($peerhost) { $peerhost = gethostbyaddr($connection->peeraddr,AF_INET); }
    $peerhost =~ s/\.$domain\.*$//;
    $peerhost =~ s/-eth\d*$//;
    $peerhost =~ s/-myri\d*$//;
    $peerhost =~ s/-ib\d*$//;
    #printf('info'.": xcatd: connection from ".($peername ? $peername . "@" . $peerhost : $peerhost)."\n");
    $$progname="xCATd SSL: Instance for ".($peername ? $peername ."@".$peerhost : $peerhost);
    service_connection($connection,$peername,$peerhost);
    exit(0);
  }
  $connection->close(SSL_no_shutdown => 1); #Without no shutdown, you can guess what the client ends up thinking..
}
$listener->close;

#stop the monitoring process
xCAT_monitoring::monitorctrl::stop($$);

my $parent_fd;
my %resps;





sub plugin_command {
  my $req = shift;
  my $sock = shift;
  my $callback = shift;
  my %handler_hash;
  use xCAT::NodeRange;
  $Main::resps={};  
  my @nodes;
  if ($req->{node}) {
    @nodes = @{$req->{node}};
  } elsif ($req->{noderange}) {
    @nodes = noderange($req->{noderange}->[0]);
    if (nodesmissed) {
      my $rsp = {errorcode=>1,error=>"Invalid nodes in noderange:".join(',',nodesmissed)};
      if ($sock) {
        print $sock XMLout($rsp,RootName=>'xcatresponse' ,NoAttr=>1);
      }
      return ($rsp);
    }
  }
  if (@nodes) { $req->{node} = \@nodes; }
  if (defined($cmd_handlers{$req->{command}->[0]})) {
    my $hdlspec;
    foreach (@{$cmd_handlers{$req->{command}->[0]}}) {
      $hdlspec =$_->[1];
      my $ownmod = $_->[0];
      if ($hdlspec =~ /:/) { #Specificed a table lookup path for plugin name
        my $table;
        my $cols;
        ($table,$cols) = split(/:/,$hdlspec);
        my @colmns=split(/,/,$cols);
        my @columns;
        my $hdlrtable=xCAT::Table->new($table);
        unless ($hdlrtable) {
          #TODO: proper error handling
        }
        my $node;
        my $colvals = {};
        foreach my $colu (@colmns) {
          if ($colu =~ /=/) { #a value redirect to a pattern/specific name
            my $coln; my $colv;
            ($coln,$colv) = split(/=/,$colu,2);
            $colvals->{$coln} = $colv;
            push (@columns,$coln);
          } else {
            push (@columns,$colu);
          }
        }
            

        unless (@nodes) { #register the plugin in the event of usage
          $handler_hash{$ownmod} = 1;
        }
        foreach $node (@nodes) {
          my $attribs = $hdlrtable->getNodeAttribs($node,\@columns);
          unless (defined($attribs)) { next; } #TODO: This really ought to craft an unsupported response for this request
          foreach (@columns) {
            my $col=$_;
            if (defined($attribs->{$col})) {
              if ($colvals->{$col}) { #A pattern match style request.
                if ($attribs->{$col} =~ /$colvals->{$col}/) {
                  $handler_hash{$ownmod}->{$node} = 1;
                  last;
                }
              } else {
                $handler_hash{$attribs->{$col}}->{$node} = 1;
                last;
              }
            }
          }
        }
	$hdlrtable->close;
      } else {
        unless (@nodes) {
          $handler_hash{$hdlspec} = 1;
        }
        foreach (@nodes) { #Specified a specific plugin, not a table lookup
          $handler_hash{$hdlspec}->{$_} = 1;
        }
      }
    }
  } else {
    return 1;  #TODO: error back that request has no known plugin for it
  }
  my $children=0;
  $SIG{CHLD} = sub {while (waitpid(-1, WNOHANG) > 0) { $children--; } };
  my $check_fds;
  if ($sock) { 
    $check_fds = new IO::Select;
  }  
  foreach (keys %handler_hash) {
    my $modname = $_;
    if (-r $plugins_dir."/".$modname.".pm") {
      require $plugins_dir."/".$modname.".pm";
      $children++;
      my $pfd; #will be referenced for inter-process messaging.
      my $child;
      if ($sock) { #If $sock not passed in, don't fork..
        socketpair($pfd, $parent_fd,AF_UNIX,SOCK_STREAM,PF_UNSPEC) or die "socketpair: $!";
        #pipe($pfd,$cfd);
        $parent_fd->autoflush(1);
        $pfd->autoflush(1);
        $child = xCAT::Utils->xfork;
      } else {
        $child = 0;
      }
      unless (defined $child) { die "Fork failed"; }
      if ($child == 0) {
        my $oldprogname=$$progname;
        $$progname=$oldprogname.": $modname instance";
        if ($sock) { close $pfd; }
        unless ($handler_hash{$_} == 1) {
          my @nodes = sort {($a =~ /(\d+)/)[0] <=> ($b =~ /(\d+)/)[0] || $a cmp $b } (keys %{$handler_hash{$_}});
          $req->{node}=\@nodes;
        }
        no strict  "refs";
	dispatch_request($req,$callback,$modname);
        #${"xCAT_plugin::".$modname."::"}{process_request}->($req,$callback,\&do_request);
        $$progname=$oldprogname;
        if ($sock) { 
          close($parent_fd);
          exit(0);
        } 
      } else {
        close $parent_fd;
        $check_fds->add($pfd);
      }
    }
  }
  unless ($sock) { return $Main::resps };
  while ($children > 0) {
    relay_fds($check_fds,$sock);
  }
  #while (relay_fds($check_fds,$sock)) {}
  my %done;
  $done{serverdone} = {};
  if ($req->{transid}) {
    $done{transid}=$req->{transid}->[0];
  }
  if ($sock) { print $sock XMLout(\%done,RootName => 'xcatresponse',NoAttr=>1); }
}

my $dispatch_dnf=0;
my $dispatch_cb;
my $dispatch_parentfd;
sub dispatch_callback {
   my $rspo = shift;
   my $rsp = {%$rspo}; # deep copy
   delete $rsp->{serverdone};
   unless (%$rsp) { return; }
   if ($dispatch_dnf) {
      $dispatch_cb->($rsp);
   } else {
      print $dispatch_parentfd freeze($rsp);
      print $dispatch_parentfd "\nENDOFFREEZE6sK6xa\n";
      <$dispatch_parentfd>; #Block until parent acks data
   }
}

sub relay_dispatch {
   my $fds = shift;
   my @ready_ins = $fds->can_read(0);
   foreach my $rin (@ready_ins) {
      my $data;
      if ($data = <$rin>) {
         while ($data !~ /ENDOFFREEZE6sK6xa/) {
            $data .= <$rin>;
         }
         my $response = thaw($data);
         print $rin "fin\n";
         $dispatch_cb->($response);
      } else {
         $fds->remove($rin);
         close($rin);
      }
   }
   return scalar(@ready_ins);
}

sub dispatch_request {
   my $req = shift;
   $dispatch_cb = shift;

   my $modname = shift;
   my $reqs = [];
   my $child_fdset = new IO::Select;
   no strict  "refs";

   #Hierarchy support.  Originally, the default scope for noderange commands was
   #going to be the servicenode associated unless overriden.
   #However, assume for example that you have blades and a blade is the service node
   #rpower being executed by the servicenode for one of its subnodes would have to
   #reach it's own management module.  This has the potential to be non-trivial for some quite possible network configurations.
   #Since plugins may commonly experience this, a preprocess_request implementation
   #will for now be required for a command to be scaled through service nodes
   #If the plugin offers a preprocess method, use it to set the request array
   if (defined(${"xCAT_plugin::".$modname."::"}{preprocess_request})) {
    $reqs = ${"xCAT_plugin::".$modname."::"}{preprocess_request}->($req,$dispatch_cb,\&do_request);
   } else { #otherwise, pass it in without hierarchy support
    $reqs = [$req];
   }

  my $childrn=0;
  $SIG{CHLD} = sub {while (waitpid(-1, WNOHANG) > 0) { $childrn--; } };
   #TODO: calls to dispatch must be parallelized
   foreach (@{$reqs}) {
    my $pfd;
    my $child;
    delete $_->{noderange};
    socketpair($pfd, $dispatch_parentfd,AF_UNIX,SOCK_STREAM,PF_UNSPEC) or die "socketpair: $!";
    $dispatch_parentfd->autoflush(1);
    $pfd->autoflush(1);
    $child = xCAT::Utils->xfork;
    if ($child) {
       $child_fdset->add($pfd);
       $childrn++;
       next;
    }
    unless (defined $child) {
       $dispatch_cb->({error=>['Fork failure dispatching request'],errorcode=>[1]});
    }
     if ($_->{'_xcatdest'} and thishostisnot($_->{'_xcatdest'})) {
        $ENV{XCATHOST} =  ( $_->{'_xcatdest'} =~ /:/ ? $_->{'_xcatdest'} : $_->{'_xcatdest'}.":3001" );
        eval {
        undef $_->{'_xcatdest'};
        xCAT::Client::submit_request($_,\&dispatch_callback,$xcatdir."/cert/server-key.pem",$xcatdir."/cert/server-cert.pem",$xcatdir."/cert/ca.pem"); 
        };
        if ($@) {
	   dispatch_callback({error=>["Error dispatching command to ".$ENV{XCATHOST}.""],errorcode=>[1]}); 
	   syslog("local4|err","Error dispatching request: ".$@);
	}
     } else {
        ${"xCAT_plugin::".$modname."::"}{process_request}->($_,\&dispatch_callback,\&do_request);
     }
     exit;
  }
 while ($childrn > 0) { relay_dispatch($child_fdset) }
 while (relay_dispatch($child_fdset)) { } #Potentially useless drain.
}

sub thishostisnot {
  my $comparison = shift;
  my @ips = split /\n/,`/sbin/ip addr`;
  my $comp=inet_aton($comparison);
  foreach (@ips) { 
    if (/^\s*inet/) {
	my @ents = split(/\s+/);
	my $ip=$ents[2];
	$ip =~ s/\/.*//;
	if (inet_aton($ip) eq $comp) { 
	  return 0;
	}
	#print Dumper(inet_aton($ip));
    }
  }
  return 1;
}
sub do_request {
  my $req = shift;
  my $second = shift;
  my $rsphandler = \&build_response;
  my $sock = undef;
  if ($second) {
    if (ref($second) eq "CODE") {
      $rsphandler = $second;
    } elsif (ref($second) eq "GLOB") {
      $sock = $second;
    }
  }

  #my $sock = shift; #If no sock, will return a response hash
  if ($cmd_handlers{$req->{command}->[0]}) {
     return plugin_command($req,$sock,$rsphandler);
  } elsif ($req->{command}->[0] eq "noderange" and $req->{noderange}) {
     my @nodes = noderange($req->{noderange}->[0]);
     my %resp;
     if (nodesmissed) {
       $resp{warning}="Invalid nodes in noderange:".join ',',nodesmissed;
     }
     $resp{serverdone} = {};
     @{$resp{node}}=@nodes;
     if ($req->{transid}) {
       $resp{transid}=$req->{transid}->[0];
     }
     if ($sock) { 
       print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1); 
     } else {
       return (\%resp);
     }
  } else {
     my %resp=(error=>"Unsupported request");
     $resp{serverdone} = {};
     if ($req->{transid}) {
       $resp{transid}=$req->{transid}->[0];
     }
     if ($sock) { 
       print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
     } else {
       return (\%resp);
     }
  }
}

sub convey_response {
  my $resp=shift;
  #TODO: This is where the following will/may happen:
  #-Track transaction id
  #-Save output for deferred commands
  unless ($parent_fd) {
    build_response($resp);
    return;
  }
  print $parent_fd XMLout($resp,KeyAttr=>[], NoAttr=>1,RootName=>'xcatresponse');
  <$parent_fd>; #Block until parent acks data
#  KeyAttr => [], NoAttr => 1)
}

sub build_response {
# Handle responses from do_request calls made directly from a plugin
#   Merge this response into the full response hash.  We'll collect all
#   the responses and ship it back on the return to the plugin.
#   Note:  Need to create a new "deep clone" copy of each response structure
#      otherwise the next call will overwrite the reference we pushed on
#      the response array
  my $resp = shift;
  foreach (keys %$resp) {
    my $subresp = dclone($resp->{$_});
    push (@{$Main::resps->{$_}}, @{$subresp});
  }
}

sub service_connection {
  my $sock = shift;
  my $peername = shift;
  my $peerhost = shift;
  my $peerport = $sock->peerport;
  my %tables=();
  #some paranoid measures could reduce a third party abusing stage3 image to attempting to get USER/PASS for BMCs:
  # -Well, minimally, ignore requests if requesting node is not in spconfig mode (stage3)
  # -Option to generate a random password per 'getipmi' request.  This reduces the exposure to a D.O.S. hopefully
  #Give only 15 seconds of silence allowed or terminate connection.  Using alarm since we are in thread-unsafe world anyway
  my $timedout = 0;

  $SIG{ALRM} = sub { $timedout = 1; die; }; 
  eval {
    my $request;
    my $req=undef;
    alarm(15);
    while (<$sock>) {
      alarm(0);
      $request .= $_;
      #$req = eval { XMLin($request, ForceArray => [ 'attribute' , 'attributepair' ]) };
      if ($request =~ m/<\/xcatrequest>/) {
        $req = eval { XMLin($request, SuppressEmpty=>undef,ForceArray=>1) };
        #we have a full request..
        #printf $request."\n";
        $request="";
        if (validate($peername,$peerhost,$req)) {
          $req->{'_xcat_authname'} = [$peername];
          $req->{'_xcat_clienthost'} = [$peerhost];
          $req->{'_xcat_clientport'}= [$peerport];
          $$progname="xCATd SSL: ".$req->{command}->[0]." for ".($peername ? $peername ."@".$peerhost : $peerhost);
          if ($cmd_handlers{$req->{command}->[0]}) {
            return plugin_command($req,$sock,\&convey_response);
          } elsif ($req->{command}->[0] eq "noderange" and $req->{noderange}) {
            my @nodes = noderange($req->{noderange}->[0]);
            my %resp;
            if (nodesmissed) {
              $resp{warning}="Invalid nodes in noderange:".join ',',nodesmissed;
            }
            $resp{serverdone} = {};
            @{$resp{node}}=@nodes;
            if ($req->{transid}) {
              $resp{transid}=$req->{transid}->[0];
            }
            print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
            next;
          } else {
            my %resp=(error=>"Unsupported request");
            $resp{serverdone} = {};
            if ($req->{transid}) {
              $resp{transid}=$req->{transid}->[0];
            }
            print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
            next;
          }
        } else { 
          my %resp=(error=>"Permission denied for request");
          $resp{serverdone} = {};
          if ($req->{transid}) {
            $resp{transid}=$req->{transid}->[0];
          }
          my $response=XMLout(\%resp,RootName =>'xcatresponse',NoAttr => 1);
          print $sock $response;
          next;
        }
      }
      alarm(15);
    } 
  };
  if ($@) { # The eval statement caught a program bug..
    unless ($@ =~ /^SIGPIPE/) {
        syslog("local4|err","xcatd: possible BUG encountered by xCAT TCP service: ".$@);
    } else {
        syslog("local4|info","xcatd: Unexpected client disconnect");
    }
  }
  alarm(0);
  foreach (keys %tables) {
    $tables{$_}->commit;
  }
  $sock->close;
  if ($timedout == 1) {
    printf ("Client timeout");
  }
}

sub relay_fds { #Relays file descriptors from pipes to children to the SSL socket
  my $fds = shift;
  my $sock = shift;
  unless ($sock) { return 0; }
  my $collate = ( scalar @_ > 0 ? shift  : 0);
  my @readyset = $fds->can_read(1);
  my $rfh;
  my $rc = @readyset;
  my $text;
  foreach $rfh (@readyset) { #go through each child, extract a complete, atomic message
    my $line;
    while ($line = <$rfh>) { #Will break on complete </xcatresponse> messages, avoid interleave
      print $sock $line; 
      if ($line =~ /<\/xcatresponse>/) {
        last;
      }
    }                       
    if ($line) { 
      print $rfh "fin\n"; #Notify convey_response message done
    } else {
      $fds->remove($rfh);      
      close($rfh);             
    }
  }
  return $rc;
}

sub validate {
  #BIG TODO, make this do something meaningful
  #here is where we check if  $peername is allowed to do $request.  $peername if set signifies client has a 
  #cert that the xCAT CA accepted.  This will be a policy table with $peername as key
  #things like 'stage2/stage3' and install images will have no client certificate.
  #A client key for something that a third party could easily tftp down themselves means nothing
  #however, privacy between the nodes can be maintained, and $peerhost will be checked just like 1.2.0.
# returns 1 if policy engine allows the action, 0 if denied
  my $peername=shift;
  my $peerhost=shift;
  my $request=shift;
  my $policytable = xCAT::Table->new('policy');
  unless ($policytable) {
    syslog("err","Unable to open policy data, denying");
    return 0;
  }
  my @policies = $policytable->getTable;
  $policytable->close;
  my $rule;
  foreach $rule (@policies) {
    if ($rule->{name} and $rule->{name} ne '*') {
      #TODO: more complex matching (lists, wildcards)
      next unless ($peername eq $rule->{name});
    }
    if ($rule->{time} and $rule->{time} ne '*') {
      #TODO: time ranges
    }
    if ($rule->{host} and $rule->{host} ne '*') {
      #TODO: more complex matching (lists, noderanges?, wildcards)
      next unless ($peerhost eq $rule->{host});
    }
    if ($rule->{commands} and $rule->{commands} ne '*') {
      #TODO: syntax for multiple commands
      next unless ($request->{command}->[0] eq $rule->{commands});
    }
    if ($rule->{parameters} and $rule->{parameters} ne '*') {
      next; #TODO: not ignore this field
    }
    if ($rule->{noderange} and $rule->{noderange} ne '*') {
      next; #TODO: not ignore this field
    }
    # If we are still in, that means this rule is the first match and dictates behavior.
    if ($rule->{rule}) {
      if ($rule->{rule} =~ /allow/i or $rule->{rule} =~ /accept/i) {
        my $logst = "xCAT: Allowing ".$request->{command}->[0];
        if ($peername) { $logst .= " for " . $peername };
        syslog("authpriv|info",$logst);
        return 1;
      } else {
        my $logst = "xCAT: Denying ".$request->{command}->[0];
        if ($peername) { $logst .= " for " . $peername };
        syslog("authpriv|info",$logst);
        return 0;
      }
    } else { #Shouldn't be possible....
      syslog("err","Impossible line in xcatd reached");
      return 0;
    }
  }
  #Reached end of policy table, reject by default.
  syslog("err","Request matched no policy rule: ".$request->{command}->[0]);
  return 0;
}