xcat-core/xCAT-server/sbin/xcatd

if (defined $reqs and (scalar(@{$reqs}) == 1)) {
      $onlyone=1;
  }

   foreach (@{$reqs}) {
    my $pfd;
    my $parfd; #use a private variable so it won't trounce itself recursively
    my $child;
    delete $_->{noderange};
    if ($onlyone and not ($_->{'_xcatdest'} and thishostisnot($_->{'_xcatdest'}))) {
        $SIG{CHLD}='DEFAULT';
        ${"xCAT_plugin::".$modname."::"}{process_request}->($_,$dispatch_cb,\&do_request);
        return;
    }

    socketpair($pfd, $parfd,AF_UNIX,SOCK_STREAM,PF_UNSPEC) or die "socketpair: $!";
    $parfd->autoflush(1);
    $pfd->autoflush(1);
    $child = xCAT::Utils->xfork;
    if ($child) {
       $dispatch_children++;
       $dispatched_children{$child}=1;
       $child_fdset->add($pfd);
       next;
    }
    unless (defined $child) {
       $dispatch_cb->({error=>['Fork failure dispatching request'],errorcode=>[1]});
    }
    $SIG{CHLD}='DEFAULT';
      $dispatch_parentfd = $parfd;
     if (ref($_->{'_xcatdest'}) eq 'ARRAY') {
         $_->{'_xcatdest'} = $_->{'_xcatdest'}->[0];
     }
     if ($_->{'_xcatdest'} and thishostisnot($_->{'_xcatdest'})) {
        $ENV{XCATHOST} =  ( $_->{'_xcatdest'} =~ /:/ ? $_->{'_xcatdest'} : $_->{'_xcatdest'}.":3001" );
        $$progname.=": connection to ".$ENV{XCATHOST};
        eval {
        undef $_->{'_xcatdest'};
        xCAT::Client::submit_request($_,\&dispatch_callback,$xcatdir."/cert/server-cred.pem",$xcatdir."/cert/server-cred.pem",$xcatdir."/cert/ca.pem"); 
        };
        if ($@) {
            my $errstr=$@;
	   dispatch_callback({error=>["Unable to dispatch command to ".$ENV{XCATHOST}.", command will not make changes to that server ($errstr)"],errorcode=>[1]}); 
	    xCAT::MsgUtils->message("S","Error dispatching request: ".$errstr);
	}
     } else {
        $$progname.=": locally executing";
        $SIG{CHLD}='DEFAULT';
        ${"xCAT_plugin::".$modname."::"}{process_request}->($_,\&dispatch_callback,\&do_request);
     }
     xexit;
  }
 while (($dispatch_children > 0) and ($child_fdset->count > 0)) { relay_dispatch($child_fdset) }
 while (relay_dispatch($child_fdset)) { } #Potentially useless drain.
}

sub thishostisnot {
  my $comparison = shift;

  # use "ip addr" for linux, since ifconfig 
  # doesn't list "ip addr add" aliases for linux
  # 
  my $cmd = ($^O !~ /^aix/i) ? "/sbin/ip addr" : "ifconfig -a";
  my @ips = split /\n/,`$cmd`;
  my $comp=inet_aton($comparison);
  unless ($comp) {
      return 1;
  }
  foreach (@ips) {
    if (/^\s*inet/) {
      my @ents = split(/\s+/);
      my $ip=$ents[2];
      $ip =~ s/\/.*//;
      if (inet_aton($ip) and 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');
  yield; #parent must get timeslice anyway before an ack could possibly return
  my $parsel = new IO::Select;
  $parsel->add($parent_fd);
  my $selbits = $parsel->bits;
  my $rsp;
  while ($selbits && ($rsp = select($selbits, undef, undef, 5))) { #block up to five seconds
         if ($quit) {  # Obey quit flag
             xexit 0;
         }
         if ($rsp == 0) { #This means the filedescriptor was removed
             last;
         }
         if ($rsp < 0) { # A signal caused select to skip out, do-over
             next;
         }
         #At this point, the only possibility is a positive return, meaning parent_fd requires attention of some sort
         $rsp = <$parent_fd>;
         if ($rsp) { #If data actually came in, last, otherwise, remove it from the IO::Select, but both should amount to the same thing
             last;
         } else {
             $parsel->remove($parent_fd);
             last;
         }
    }
    yield; #If still around, it means a peer process still hasn't gotten to us, so might as well yield
    $selbits = $parsel->bits;
}

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..
    if ($@ =~ /^SIGPIPE/) {
         xCAT::MsgUtils->message("S","xcatd: Unexpected client disconnect");
        if ($sock) {
            eval {
                print $sock XMLout({error=>"Generic PIPE error occurred.  $@"},RootName=>'xcatresponse',NoAttr=>1);
            };
        }
    } elsif ($@ =~ /Client abort requested/) {
    } else {
        my $errstr="A fatal error was encountered, the following information may help identify a bug: $@";
        chomp($errstr);
         xCAT::MsgUtils->message("S","xcatd: possible BUG encountered by xCAT TCP service: ".$@);
        if ($sock) {
            eval {
                print $sock XMLout({error=>$errstr},RootName=>'xcatresponse',NoAttr=>1);
            };
        }
    }
  }
  $SIG{ALRM}= sub { die "$$ failed shutting down" };
  alarm(10);
  foreach (keys %tables) {
    $tables{$_}->commit;
  }
  $sock->close(SSL_fast_shutdown=>1);
  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;
  my $goneclient=0;
  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
      eval {
        print $sock $line; 
      };
      if ($@ and $@ =~ /PIPE/) {
          $goneclient=1;
          print "Piped while writing to client\n";
          last;
      }
      if ($line =~ /<\/xcatresponse>/) {
        last;
      }
    }                       
    if ($line) { 
      print $rfh "nfin\n"; #Notify convey_response message done
    } else {
      $fds->remove($rfh);      
      close($rfh);             
    }
  }
   foreach my $rin ($clientselect->can_read(0)) {
      my $subselect = new IO::Select;
      $subselect->add($rin);
      my $clientintr="";
      my $subdata;
      while ($subselect->can_read(1)) {
         if ($subdata=<$rin>) {
            $clientintr.=$subdata;
         } else {
            $subselect->remove($rin);
            close($rin);
         }
      }
      unless ($clientintr) {
         next;
      }
      $clientintr=XMLin($clientintr, SuppressEmpty=>undef,ForceArray=>1 );
      if ($clientintr->{abortcommand}->[0]) {
          print "Aborting...";
         foreach (keys %plugin_children) {
            print "Sending INT to $_\n";
            kill 2, $_;
         }
         foreach my $cin ($fds->handles) {
            print $cin "die\n";
            $fds->remove($cin);
            close($cin);
         }
         die "Client abort requested";
      }
   }
  yield; #Give other processes, including children, explicit control, to avoid uselessly aggressive looping
  if ($goneclient) {
    die "SIGPIPE $$progname encountered a broken pipe (Sudden client disconnect)"
  }
  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) {
     xCAT::MsgUtils->message("S","Unable to open policy data, denying");
    return 0;
  }
  my @policies = $policytable->getTable;
  $policytable->close;
  my $rule;
  RULE: foreach $rule (@policies) {
    if ($rule->{name} and $rule->{name} ne '*') {
      #TODO: more complex matching (lists, wildcards)
      next unless ($peername and $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 '*') {
      my $parms;
      if ($request->{arg}) {
         $parms = join(' ',@{$request->{arg}});
      } else {
         $parms = "";
      }
      my $patt = $rule->{parameters};
      unless ($parms =~ /$patt/) {
         next;
      }
    }
    if ($rule->{noderange} and $rule->{noderange} ne '*') {
      my $matchall=0;
      if ($rule->{rule} =~ /allow/i or $rule->{rule} =~ /accept/i) {
          $matchall=1;
      }
      if (defined $request->{noderange}->[0]) {
        my @tmpn=noderange($request->{noderange}->[0]);
        $request->{node}=\@tmpn;
      }
      unless (defined $request->{node}) {
          next RULE;
      }
      my @reqnodes = @{$request->{node}};
      my %matchnodes;
      foreach (noderange($rule->{noderange})) {
          $matchnodes{$_}=1;
      }
      REQN: foreach (@reqnodes) {
          if (defined ($matchnodes{$_})) {
              if ($matchall) {
                  next REQN;
              } else {
                last REQN;
              }
          } elsif ($matchall) {
                  next RULE;
          }
      }
    }
    # 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 };
        if ($peerhost) { $logst .= " from " . $peerhost };
         xCAT::MsgUtils->message("S",$logst);
        return 1;
      } else {
        my $logst = "xCAT: Denying ".$request->{command}->[0];
        if ($peername) { $logst .= " for " . $peername };
        if ($peerhost) { $logst .= " from " . $peerhost };
         xCAT::MsgUtils->message("S",$logst);
        return 0;
      }
    } else { #Shouldn't be possible....
       xCAT::MsgUtils->message("S","Impossible line in xcatd reached");
      return 0;
    }
  }
  #Reached end of policy table, reject by default.
   xCAT::MsgUtils->message("S","Request matched no policy rule: ".$request->{command}->[0]);
  return 0;
}