pl_mom.pl

   1 #!/usr/bin/perl -w
   2
   3 use POSIX qw(setsid);
   4 use Sys::Syslog;
   5 use Sys::Hostname;
   6 use RPC::XML;
   7 #use LWP::Simple;
   8
   9 $debug = 0;
  10 $proc = "pl_mom";
  11 $alias_addr = "pl-mom\@planet-lab.org";
  12 $from_addr = "support\@planet-lab.org";
  13
  14 if (! $debug) {
  15     $kill_thresh = 90;
  16     $reboot_thresh = 95;
  17     $log_thresh = 85;
  18     $change_thresh = 5;
  19     $min_thresh = 10;
  20     #$bwcap_default = "off";
  21     $bwcap_default = "1.5Mbit";
  22     $cutoff_default = "16200000000";  # 16GB, for 1.5Mbit cap
  23     $bwmon_sleep = 900;
  24
  25     $sendmail = "/usr/sbin/sendmail -t -f$from_addr";
  26     $vservers = "/etc/vservers";
  27     $pidfile = "/var/run/$proc.pid";
  28     $rebootfile = "/var/lib/misc/pl_mom.reboot";
  29     $daily_log = "/var/lib/misc/pl_mom.daily";
  30     $daily_stamp = "/var/lib/misc/pl_mom.stamp";
  31     $configfile = "/etc/planetlab/pl_mom.conf";
  32     $capfile = "/var/lib/misc/pl_mom.oldcaps";
  33 } else {
  34     $kill_thresh = 2;
  35     $reboot_thresh = 20;
  36     $log_thresh = 2;
  37     $change_thresh = 5;
  38     $min_thresh = 2;
  39     $bwcap_default = "1Kbit";
  40     $cutoff_default = "10800";
  41     $bwmon_sleep = 10;
  42
  43     $sendmail = "cat";
  44     $vservers = "./debug";
  45     $pidfile = "./$proc.pid";
  46     $rebootfile = "./debug/pl_mom.reboot";
  47     $daily_log = "./debug/pl_mom.daily";
  48     $daily_stamp = "./debug/pl_mom.stamp";
  49     $configfile = "./debug/pl_mom.conf";
  50     $capfile = "./debug/pl_mom.oldcaps";
  51 }
  52
  53 $sleep = 30;
  54
  55 # daemonize the program
  56 if (! $debug) {
  57     &daemonize;
  58 }
  59
  60 system("echo $$ > $pidfile");
  61
  62 read_config_file();
  63
  64 # Check to see whether pl_mom rebooted the node
  65 if (-e $rebootfile) {
  66     unlink($rebootfile);
  67     syslog ("warning", "pl_mom: Sending shutdown mail");
  68     shutdown_mail();
  69 }
  70
  71 my $pid = fork();
  72 if (! $pid) {
  73     syslog ("info", "pl_mom: Launching reboot kicker");
  74     reboot_kicker();
  75     die (0);
  76 }
  77 $pid = fork();
  78 if (! $pid) {
  79     syslog ("info", "pl_mom: Launching bandwidth monitor");
  80     if ($bwcap_default =~ /off/) {
  81         syslog("info", "pl_mom: Max rate unlimited by default");
  82     }
  83     reset_bandwidth_caps();
  84     bandwidth_monitor();
  85     die (0);
  86 }
  87
  88 while (1) {
  89     $used = int(swap_used());
  90
  91     if (defined($old_used)) {
  92         if ($used >= $old_used + $change_thresh) {
  93             syslog ("info", "pl_mom: %d%% swap consumed in last %d seconds",
  94                     $used - $old_used, $sleep);
  95         }
  96     }
  97
  98     if ($used >= $log_thresh) {
  99         if (! defined($old_used) || $used != $old_used) {
 100             syslog ("info", "pl_mom: Swap used: %d%%", $used);
 101         }
 102         get_slice_info();
 103         my $hog = memory_hog();
 104         if ($hog) {
 105             if ($used < $kill_thresh) {
 106                 if (! defined($Warning{$hog})) {
 107                     $Warning{$hog} = "sent";
 108                     syslog ("warning", "pl_mom: Slice $hog is ".
 109                             "using $Slice{$hog}{mem_pct}%% of memory");
 110                     #slice_warning_mail($hog);
 111                 }
 112             } else {
 113                 my $id = `id -u $hog`;
 114                 chomp($id);
 115                 my $top = `/usr/sbin/chcontext --ctx $id /usr/bin/top -b -n 1`;
 116                 syslog ("warning", "pl_mom: Resetting slice $hog");
 117                 if (! $debug) {
 118                     slice_reset($hog);
 119                 }
 120                 syslog ("warning", "pl_mom: Sending mail to slice $hog");
 121                 slice_reset_mail($hog, $top);
 122             }
 123         }
 124     }
 125
 126     sleep ($sleep);
 127
 128     $old_used = $used;
 129 }
 130
 131 sub reboot_kicker {
 132     while (1) {
 133         $used = swap_used();
 134
 135         if ($used >= $reboot_thresh) {
 136             syslog ("warning", "pl_mom: Rebooting node");
 137
 138             system("touch $rebootfile");
 139             if (! $debug) {
 140                 #system("shutdown -r now");
 141                 system("/bin/sync; /sbin/reboot -f");
 142             }
 143             die (0);
 144         }
 145
 146         sleep (1);
 147     }
 148 }
 149
 150 sub bandwidth_monitor {
 151     while (1) {
 152         # See if a new day has started for bandwidth monitoring
 153         chomp($now = `date -u +%D`);
 154         if (-e $daily_stamp) {
 155             chomp($stamp = `cat $daily_stamp`);
 156         }
 157         if (! defined($stamp) || !($stamp =~ $now)) {
 158             open (STAMP, ">$daily_stamp") ||
 159                 die "Can't open file $daily_stamp for writing: $!\n";
 160             print STAMP "$now\n";
 161             close STAMP;
 162             unlink ($daily_log);
 163
 164             # Could save the list of capped slices in a file in order to
 165             # avoid re-sending mails if the daemon restarts.
 166             # Also may want a list of slices that are exempt from capping.
 167             if (defined(%Start)) { undef %Start; }
 168             if (defined(%Now))   { undef %Now; }
 169             if (defined(%Cap))   { undef %Cap; }
 170
 171             reset_bandwidth_caps();
 172
 173             syslog("info", "pl_mom: Beginning bandwidth monitoring for $now");
 174         }
 175
 176         get_slice_names();
 177         get_baseline_counts();
 178         get_slice_limits();
 179
 180         foreach $slice ( sort (keys %Start) ) {
 181             if (defined $Now{$slice}) {
 182                 $today = $Now{$slice} - $Start{$slice};
 183                 if (! (defined ($Cutoff{$slice})||$bwcap_default =~ /off/)) {
 184                     $Cutoff{$slice} = $cutoff_default;
 185                     $Maxrate{$slice} = $bwcap_default;
 186                 }
 187                 if ($debug) {
 188                     if ($today) {
 189                         $cutoff = defined($Cutoff{$slice})
 190                             ? $Cutoff{$slice} : "<none>";
 191                         print "Slice $slice sent $today bytes; ".
 192                             "cutoff $cutoff\n";
 193                     }
 194                 }
 195                 if (defined ($Cutoff{$slice}) &&
 196                     $today >= $Cutoff{$slice} &&
 197                     ! defined($Cap{$slice})) {
 198                     $Cap{$slice} = "sent";
 199                     bw_cap_mail($slice);
 200                     log_bandwidth_cap($slice, $Maxrate{$slice});
 201                     cap_bandwidth($slice, $Maxrate{$slice});
 202                 }
 203             } else {
 204                 # Token bucket for this slice is gone!
 205             }
 206         }
 207
 208         sleep($bwmon_sleep);
 209     }
 210 }
 211
 212 sub read_config_file {
 213     if (-e $configfile) {
 214         open (CONFIG, "<$configfile") ||
 215             print "Cannot open $configfile; $!\n";
 216         while (<CONFIG>) {
 217             if (m/^(.*)=(.*)$/) {
 218                 ${$1} = $2;
 219                 if ($debug) {
 220                     print "read_config_file: $1 = ${$1}\n";
 221                 }
 222             }
 223         }
 224         close CONFIG;
 225     }
 226 }
 227
 228 sub get_slice_names {
 229     # Read slice names from /etc/passwd
 230     if (defined (%Name)) { undef %Name; }
 231     open (PASSWD, "</etc/passwd") ||
 232         print "Cannot open /etc/passwd; $!\n";
 233     while (<PASSWD>) {
 234         my ($slicename, $passwd, $sliceid) = split(/:/);
 235         $Name{$sliceid} = $slicename;
 236     }
 237     close PASSWD;
 238 }
 239
 240 sub get_baseline_counts {
 241     `touch $daily_log`;
 242     open (BASE, "+<$daily_log") ||
 243         print "Cannot open $daily_log; $!\n";
 244     while (<BASE>) {
 245         my ($slice, $bytecount) = split(/ /);
 246         $Start{$slice} = $bytecount;
 247     }
 248
 249     my $status = `tc -s -d qdisc show`;
 250     my $sliceid = 0xffff;
 251     @Lines = split(/\n/, $status);
 252     foreach $line ( @Lines ) {
 253         if ($line =~ /qdisc pfifo (.*): dev/) {
 254             $sliceid = hex($1);
 255             # "Capped" buckets all begin with 0x1000. Ignore the root
 256             # (0x1000) and default (0x1fff) buckets, as well as
 257             # "exempt" buckets that begin with 0x2000 (or anything
 258             # other than 0x1000).
 259             if (($sliceid & 0xf000) == 0x1000 &&
 260                 $sliceid != 0x1000 && $sliceid != 0x1fff) {
 261                 $sliceid = $sliceid & 0x0fff;
 262             } else {
 263                 $sliceid = 0xffff;
 264             }
 265         } else {
 266             if ($line =~ /Sent (.*) bytes/) {
 267                 my $bytes = $1;
 268                 if ($sliceid != 0xffff) {
 269                     my $slice = $Name{$sliceid};
 270                     if ($debug && $bytes) {
 271                         print "Slice: $slice ($sliceid), bytes $bytes\n";
 272                     }
 273                     if (! defined($Start{$slice})) {
 274                         print BASE "$slice $bytes\n";
 275                         $Start{$slice} = $bytes;
 276                     }
 277                     $Now{$slice} = $bytes;
 278                 }
 279             }
 280         }
 281     }
 282     close (BASE);
 283 }
 284
 285 sub get_slice_limits {
 286     if (defined %Maxrate) { undef %Maxrate; }
 287     if (defined %Cutoff)  { undef %Cutoff; }
 288     if (-e $vservers) {
 289         my $result = `grep -H "^BWAVGRATE" $vservers/*.conf`;
 290         chomp ($result);
 291         my @Lines = split(/\n/,$result);
 292         foreach $line ( @Lines ) {
 293             if ($line =~ /\/([^\/]*).conf:BWAVGRATE=(.*)[Mm]bit/) {
 294                 $slice = $1;
 295                 $limit = $2."Mbit";
 296                 $cutoff = ($2 * 1000000 * 86400)/8;
 297             } else {
 298                 if ($line =~ /\/([^\/]*).conf:BWAVGRATE=(.*)[Kk]bit/) {
 299                     $slice = $1;
 300                     $limit = $2."Kbit";
 301                     $cutoff = ($2 * 1000 * 86400)/8;
 302                 } else {
 303                     die "Could not parse line $line";
 304                 }
 305             }
 306             $Maxrate{$slice} = $limit;
 307             $Cutoff{$slice} = $cutoff;
 308         }
 309     }
 310 }
 311
 312 sub reset_bandwidth_caps {
 313     if (-e $capfile) {
 314         open(CAP, "<$capfile") or die "Cannot open $capfile: $!";
 315         while (<CAP>) {
 316             chomp();
 317             ($slicename, $oldcap) = split(/ /);
 318             syslog("info", "pl_mom: Restoring bandwidth cap of $oldcap ".
 319                    "to $slicename");
 320             cap_bandwidth ($slicename, $oldcap);
 321         }
 322         close CAP;
 323         unlink($capfile);
 324     }
 325 }
 326
 327 sub log_bandwidth_cap {
 328     ($slicename, $cap) = @_;
 329     syslog("warning", "pl_mom: Capping bandwidth of slice ".
 330            "$slicename at $cap until midnight GMT.");
 331     # Save current cap to $capfile
 332     system("echo $slicename `bwlimit getcap $slicename` >> $capfile");
 333 }
 334
 335 sub send_mail {
 336     # Arg 0: recipient addresses, comma-separated string
 337     # Arg 1: subject line
 338     # Arg 2: body of message
 339     my $to = "To: $_[0]\n";
 340     my $from = "From: $from_addr\n";
 341     my $subject = "Subject: $_[1]\n";
 342     my $msg = $_[2];
 343
 344     if ($debug) {
 345         print $to;
 346         print $subject;
 347     } else {
 348         open(SENDMAIL, "|$sendmail") or die "Cannot open $sendmail: $!";
 349         print SENDMAIL $to;
 350         print SENDMAIL $from;
 351         print SENDMAIL $subject;
 352         print SENDMAIL "Content-type: text/plain\n\n";
 353         print SENDMAIL $msg;
 354         close(SENDMAIL);
 355     }
 356 }
 357
 358 sub cap_bandwidth {
 359     ($slicename, $cap) = @_;
 360     system("bwlimit setcap $slicename $cap");
 361     system("bwlimit on $slicename");
 362 }
 363
 364 sub get_date {
 365     my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdat)
 366         = localtime(time);
 367     my $date = sprintf("%4d-%02d-%02d %02d:%02d:%02d",
 368                        $year+1900, $mon+1, $mday, $hour, $min, $sec);
 369     return $date;
 370 }
 371
 372 sub bw_cap_mail {
 373     my ($slicename) = @_;
 374     my $hostname = hostname();
 375     my $date = get_date();
 376     my $sent = int($Cutoff{$slicename}/(1024*1024));
 377     my $bwcap = $Maxrate{$slicename};
 378
 379     send_mail("$alias_addr, $slicename\@slices.planet-lab.org",
 380               "$proc capped bandwidth of slice $slicename on $hostname",
 381               "Slice $slicename has transmitted more than ${sent}MB today".
 382               " on $hostname.  ".
 383               "Its bandwidth will be capped at $bwcap until midnight GMT.".
 384               "\n\n$date $hostname bwcap $slicename\n");
 385 }
 386
 387 sub shutdown_mail {
 388     my $hostname = hostname();
 389     my $date = get_date();
 390     send_mail($alias_addr,
 391               "$proc rebooted $hostname",
 392               "Swap space was exhausted on $hostname and so $proc rebooted ".
 393               "it.\n\nAs of $date, the node has successfully come back ".
 394               "online.\n\n$date $hostname reboot\n");
 395 }
 396
 397 sub slice_reset_mail {
 398     my $hog = $_[0];
 399     my $top = $_[1];
 400     my $hog_mem = sprintf ("%0.f", $Slice{$hog}{pmem}/1000);
 401     my $hog_pct = $Slice{$hog}{mem_pct};
 402     my $hostname = hostname();
 403     my $date = get_date();
 404     send_mail("$alias_addr, $hog\@slices.planet-lab.org",
 405               "$proc reset slice $hog on $hostname",
 406               "As of $date, swap space is nearly exhausted on $hostname.\n\n".
 407               "Slice $hog is being reset since it is the largest consumer ".
 408               "of physical memory at ${hog_mem}MB ($hog_pct%).\n\n".
 409               "Please reply to this message explaining the nature of your ".
 410               "experiment, and what you are doing to address the problem.\n".
 411               "\nOutput of 'top -b -n 1' in your slice prior to reset:\n".
 412               "$top\n\n$date $hostname reset $hog\n");
 413 }
 414
 415 sub slice_warning_mail {
 416     my $hog = $_[0];
 417     my $hog_mem = sprintf ("%0.f", $Slice{$hog}{pmem}/1000);
 418     my $hog_pct = $Slice{$hog}{mem_pct};
 419     my $hostname = hostname();
 420     my $date = get_date();
 421
 422     if ($hog =~ /^root$/) {
 423         $to = $alias_addr;
 424     } else {
 425         $to = "$alias_addr, $hog\@slices.planet-lab.org";
 426     }
 427
 428     send_mail($to,
 429               "$proc may reset slice $hog on $hostname",
 430               "As of $date, swap space is over $log_thresh% full on ".
 431               "$hostname.\n\nSlice $hog is the largest consumer ".
 432               "of physical memory at ${hog_mem}MB ($hog_pct%).\n".
 433               "Please check the memory usage of your slice to avoid a ".
 434               "reset.\n\n$date $hostname warning $hog\n");
 435 }
 436
 437 sub unkillable_alarm_mail {
 438     my $hog = $_[0];
 439     my $hog_mem = sprintf ("%0.f", $Slice{$hog}{pmem}/1000);
 440     my $hog_pct = $Slice{$hog}{mem_pct};
 441     my $hostname = hostname();
 442     my $date = get_date();
 443
 444     if ($hog =~ /^root$/) {
 445         $to = $alias_addr;
 446     } else {
 447         $to = "$alias_addr, $hog\@slices.planet-lab.org";
 448     }
 449
 450     send_mail($to,
 451               "$proc: alarm for slice $hog on $hostname",
 452               "As of $date, swap space is over $log_thresh% full on ".
 453               "$hostname.\n\nSlice $hog is the largest consumer ".
 454               "of physical memory at ${hog_mem}MB ($hog_pct%).\n".
 455               "The slice will not be reset, but please verify its behavior.\n".
 456               "\n$date $hostname alarm $hog\n");
 457 }
 458
 459 sub slice_reset {
 460     my $slice = $_[0];
 461     my $sliceid = $Slice{$slice}{ctx};
 462     system("chcontext --ctx $sliceid sudo kill -9 -1");
 463     system("/etc/init.d/vserver-init start $slice");
 464 }
 465
 466 sub swap_used {
 467     open (SWAP, "</proc/swaps") ||
 468         die "Cannot open /proc/swaps; $!\n";
 469
 470     $line = <SWAP>;
 471     $line = <SWAP>;
 472     $line =~ s/[\t ]+/ /g;
 473
 474     my ($filename, $type, $size, $used, $priority) = split(/ /, $line);
 475     close SWAP;
 476
 477     return 100*($used/$size);
 478 }
 479
 480 sub get_slice_info {
 481     if (! $debug) {
 482         $content = `curl -s http://127.0.0.1:3100/slicestat`;
 483     } else {
 484         #$content = `cat ../pl_mom-deploy/slicestat`
 485         $content = `curl -s http://127.0.0.1:3100/slicestat`;
 486     }
 487     my @lines = split(/\n/, $content);
 488     %Slice = ();
 489     foreach $line (@lines) {
 490         my ($slice, $ctx, $cpu_pct, $mem_pct, $pmem, $vmem, $ntasks)
 491             = split(/,/,$line);
 492         $Slice{$slice}{ctx} = $ctx;
 493         $Slice{$slice}{cpu_pct} = $cpu_pct;
 494         $Slice{$slice}{mem_pct} = $mem_pct;
 495         $Slice{$slice}{pmem} = $pmem;
 496         $Slice{$slice}{vmem} = $vmem;
 497         $Slice{$slice}{ntasks} = $ntasks;
 498     }
 499 }
 500
 501 sub memory_hog {
 502     @keys = sort { $Slice{$b}{mem_pct} <=> $Slice{$a}{mem_pct} } (keys %Slice);
 503     foreach $key (@keys) {
 504         if ($Slice{$key}{mem_pct} >= $min_thresh) {
 505             if ($key =~ /^root$/ || $key =~ /slicestat/ || $key =~ /netflow/) {
 506                 if (! defined ($Warning{$key})) {
 507                     $Warning{$key} = "sent";
 508                     syslog ("warning", "pl_mom: Sending alarm mail to ".
 509                             "unkillable slice $key, using ".
 510                             "$Slice{$key}{mem_pct}%% of memory");
 511                     unkillable_alarm_mail($key);
 512                 }
 513             } else {
 514                 return $key;
 515             }
 516         } else {
 517             #syslog ("info", "pl_mom: No killable slice using > ".
 518             #    "$min_thresh%% memory");
 519             return;
 520         }
 521     }
 522 }
 523
 524 sub daemonize {
 525     chdir '/'                 or die "Can't chdir to /: $!";
 526     open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
 527     open STDOUT, '>>/dev/null' or die "Can't write to /dev/null: $!";
 528     open STDERR, '>>/dev/null' or die "Can't write to /dev/null: $!";
 529     defined(my $pid = fork)   or die "Can't fork: $!";
 530     exit if $pid;
 531     setsid                    or die "Can't start a new session: $!";
 532     umask 0;
 533 }