#!/usr/bin/perl -T

use strict;
require 'bigint.pl';
use Sys::Syslog; 

# emergency_stop
#
# Utility to shut down compute nodes of a cluster in case of emergency.
# See http://t8web.lanl.gov/people/dsteck/nightshade/emergency.html
#   for more information.
#
# written 9/10/02 by D. Steck and T. Bhattacharya


### local settings
my $logfile='/var/log/emergencylog';
my $nodebegin = 1;   #
my $nodeend = 36;    #
my $nodestem = 'cn'; # node names are cn1 - cn36
my $clustername = 'nightshade.lanl.gov';
my $shutdownopt = '-h'; # '-k' for test, '-h' is real thing
my $powercontrol = 'vacm'; # set to 'vacm' or 'apm' for appropriate poweroff
my $vash = '/usr/local/bin/vash';
my $vashopts = '-c localhost -u power -p 0ffug\\)';
my $wall = '/usr/bin/wall';
my $rsh = '/usr/bin/rsh';
my $ruptime = '/usr/bin/ruptime';
my $shutdowncmd = '/sbin/shutdown';

%ENV = ();
my $nl = "\n";

### log request to system log
if ($shutdownopt eq '-h') {
  openlog($0, 'cons,pid', 'authpriv');
  syslog('alert', "received shutdown request, see $logfile for details");
  closelog();
}

### log request to dedicated log file
die ('Error: cannot open file ' . $logfile) unless
  open (logfile, ">>$logfile");

print logfile localtime(time) . 
              " $0 [ $$ ]: shutdown request received, copy follows\n";
print logfile ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n";

### time go through input email, perform authentication checks
my $check1 = 0;
my $check2 = 0;
my $datestr = '';
my $authcode = '';
while (<>) {

  ### authenticate by looking for authentication strings
  if (/^(X-Date:.*)$/) {$datestr = $1; $check1 = 1;}
  if (/^X-AuthCode:\s*([\da-f]*)$/i) {$authcode = $1; $check1 = 1;}

  ### authenticate by looking if this is from fahrenheit.lanl.gov
  ###   make an attempt to defeat spoofing, and assume that the message
  ###   is delivered directly from fahrenheit to the cluster
  ###   i.e., we check only the first receive line for the right stuff
  if ($check2 == 0) {
    if (/received/i) {
      if ( /from 127.0.0.1 \(fahrenheit.lanl.gov \[128.165.59.190\]\)/ ) {
        $check2 = -1;
      } else {$check2 = -2;}
    }
  } elsif ($check2 == -1) {
    if (/^\t\s*by $clustername/) {
	$check2 = 1;
    } else {
        $check2 = -2;
    }
  }

  print logfile $_;
}

print logfile "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n";


### Decrypt authorization code and verify result
my $msg = pack('H*',$authcode);
my $emsg;

my $modulus =
     '1c630ce7db21dee339eb573d8dc92ffbe228465010cdef2df8f4ba90ae0bc71d';
my $pblckey = 
     '129dad94f1d26ff9790d1f9a713672e39fdc34fd3633681b46cd0c26b6e53675';

if ($check1) {

  ### 5-line pure perl RSA routine, modified to act inline
  ### http://www.cypherspace.org/~adam/rsa/pureperl.html
  my ($n, $k, $x, $z);

  $n = $modulus;
  $_ = $pblckey; 
  s/^.(..)*$/0$&/; # char = hex pair; so add leading 0 if needed
  ($k=unpack('B*',pack('H*',$_))) =~ s/^0*//;  # hex->binary, strip leading 0's
  $x=0;
  $z = $n =~ s/./$x=&badd(&bmul($x,16),hex $&)/ge; 

  while ( length $msg )  { # while $msg has unencoded stuff
    my ($d,$r,$c,$t);
    $d = 1;
    my $w=((2*$d-1+$z)&~1)/2;  # Size of next parcel that we want to handle

    $_ = substr($msg,0,$w); # get parcel
    $msg = substr($msg,$w); # remove from unprocessed $msg

    $r=1;
    $_=substr($_."\0"x$w,$c=0,$w); # Pad $_ with "\0" to have $w chars if needed 
    s/.|\n/$c=&badd(&bmul($c,256),ord $&)/ge; 

    $_=$k;
    s/./$r=&bmod(&bmul($r,$r),$x),$&?$r=&bmod(&bmul($r,$c),$x):0,""/ge;

    ($r,$t)=&bdiv($r,256),$_=pack('C',$t).$_ while $w-- + 1 - 2 * $d;
    $emsg .= $_;
  }

  $emsg =~ s/\0*$//;

  ### decrypted message should match the X-Date header line
  if ( $emsg ne $datestr ) {
    print logfile localtime(time) .
           " $0 [ $$ ]: shutdown request failed, authentication key invalid\n";
    print logfile "  authcode='$authcode' message = '$emsg'\n";
    exit 1;
  }

  ### additionally, the X-Date header should not be too old, in local
  ###   cluster's time; this requires that the local clock be updated
  ###   REGULARLY via ntp (e.g. via rdate -s time.nist.gov as an hourly
  ###   cron job); also note that X-Date is in the format of the time
  ###   function, to avoid daylight savings and whatnot problems.
  my $nowtime = time;
  my $xdatetime = $1 if $datestr =~ /^X-Date: ([0-9]+)$/;
  # my $xdatetime = $datestr =~ s/[^0-9]*//g;
  if ( abs($nowtime - $xdatetime) > 300 ) {
    print logfile localtime(time) .
             " $0 [ $$ ]: shutdown request failed, excessive time mismatch, " . 
             ' current time = ' . localtime($nowtime) . 
             ', X-Date time = ' . localtime($xdatetime) . $nl;
    exit 1;
  }

} else {
  ### stop if we didn't match enough info to check authentication code
  print logfile localtime(time) .
          " $0 [ $$ ]: shutdown request failed, authentication key not found\n";
  exit 1;
}


### stop if email was from the wrong source
if ($check2 < 1) {
  print logfile localtime(time) .
                 " $0 [ $$ ]: shutdown request failed," . 
                 " message apparently not from fahrenheit.lanl.gov\n";
  exit 1;
}

### authenticate by checking to see who invoked wrapper
my ($ruser,$passwd,$uid,$gid,$quota,$comment,$gcos,$dir,$shell) = 
  getpwuid $<;
$ruser =~ /([-\@\w.]+)/g; $ruser = $1;
if ($ruser ne 'mail') {
  print logfile localtime(time) .
                " $0 [ $$ ]: shutdown request failed, called by user $ruser\n"; 
  exit 1;
}

### all tests passed, so go ahead
$< = $>; # set real to effective uid
print logfile localtime(time) . " $0 [ $$ ]: shutdown request authenticated\n";

my $bcastmsg;
$bcastmsg = <<EOF1;
*************************************************************************
  Emergency condition detected in Rm 135!
  All compute nodes will be shut DOWN in 5 minutes!
  Processes on compute nodes will receive SIGTERM signals in 3 minutes!
*************************************************************************


EOF1
open(bcast, "|$wall"); print bcast $bcastmsg; close(bcast);

sleep 180;


print logfile localtime(time) . " $0 [ $$ ]: sending shutdown commands\n";

$bcastmsg = <<EOF2;
*************************************************************************
  Emergency condition detected in Rm 135!
  Sending shutdown commands to all compute nodes!
  All compute nodes will shut DOWN in 2 minutes!
*************************************************************************


EOF2
open(bcast, "|$wall"); print bcast $bcastmsg; close(bcast);


### send shutdown command to all nodes, and wait for shutdowns to complete
my $i;
my @childarray;
for ($i=$nodebegin; $i<=$nodeend; $i++) {  

  my $child = fork();
  if ($child == 0) {
    exec "$rsh $nodestem$i $shutdowncmd $shutdownopt -f -t 100 +2";
    print logfile localtime(time) .
               " $0 [ $$ ]: $nodestem$i shutdown command failed \n";
    exit 1;

  } else {
    push @childarray, $child;
  }
    
}

### wait for all shutdown commands to terminate
wait;
print logfile localtime(time) . " $0 [ $$ ]: shutdowns completed\n";


### wait 2 minutes and then power off
if ( ($shutdownopt eq '-h') & ($powercontrol eq 'vacm') ) {
  sleep 120;
  print logfile localtime(time) . " $0 [ $$ ]: beginning poweroff sequence\n";

  for ($i=$nodebegin; $i<=$nodeend; $i++) {
    open(vacm, 
        "$vash $vashopts -x 'ipc localhost emp:power_off:cn$i' |");
    while(<vacm>) {
      if (/JOB_COMPLETED/) {
        print logfile localtime(time) . 
               " $0 [ $$ ]: cn$i powered off successfully\n";
      } elsif (/JOB_ERROR/) {
        print logfile localtime(time) . 
               " $0 [ $$ ]: error powering off cn$i\n";
      }
    }
    close(vacm);
    sleep 1;
  }
} elsif ( $shutdownopt eq '-h' ) {
  ### wait 5 minutes and then dump a copy of ruptime to log
  sleep 300;
  print logfile localtime(time) . " $0 [ $$ ]: ruptime follows:\n";
  open(ruptime, "$ruptime|");
  while(<ruptime>) {
    print logfile;
  }
  close(ruptime);
}

print logfile localtime(time) . " $0 [ $$ ]: poweroff sequence completed\n";



$bcastmsg = <<EOF3;
*************************************************************************
  Emergency condition detected in Rm 135!
  All compute nodes have been shut down!
*************************************************************************


EOF3
open(bcast, "|$wall"); print bcast $bcastmsg; close(bcast);

exit 0;