xrctl (26925B)
1 #!/usr/bin/perl 2 use strict; 3 use Getopt::Std; 4 use Term::ANSIColor qw(:constants); 5 6 # Versioning 7 my $VER = "__VER__"; 8 9 # -------------------------------------------------------------------------- 10 # xrctl: used to start, stop, restart etc. the XR balancer. 11 12 # Default configuration file to read and default logging facility 13 my $default_conf = '/etc/xrctl.xml'; 14 my $default_logger = 'logger'; 15 my $default_prefixtimestamp = undef; 16 17 # Default settings, must match xr's defaults 18 my $default_dispatchmode = 'least-connections'; 19 my $default_maxconnections = 0; 20 my $default_client_timeout = 30; 21 my $default_client_read_timeout = 30; 22 my $default_client_write_timeout = 30; 23 my $default_backend_timeout = 30; 24 my $default_backend_read_timeout = 3; 25 my $default_backend_write_timeout = 3; 26 my $default_buffersize = 2048; 27 my $default_wakeupinterval = 5; 28 my $default_checkupinterval = 0; 29 my $default_weight = 1; 30 my $default_hostmatch = '.'; 31 my $default_urlmatch = '.'; 32 my $default_backendcheck = 'connect::'; 33 my $default_timeinterval = 1; 34 my $default_hardmaxconnrate = 0; 35 my $default_softmaxconnrate = 0; 36 my $default_defertime = 500000; 37 my $default_hardmaxconnexcess = 0; 38 my $default_softmaxconnexcess = 0; 39 my $default_dnscachetimeout = 3600; 40 41 # Cmd line flags 42 my %opts = (v => 0, 43 c => $default_conf, 44 ); 45 usage() unless (getopts('vc:', \%opts)); 46 usage() if ($#ARGV == -1); 47 48 # Load configuration 49 my $xml; 50 open (my $if, $opts{c}) or die ("Cannot read configuration $opts{c}: $!\n"); 51 while (my $line = <$if>) { 52 $xml .= $line; 53 } 54 close ($if); 55 my $xp = new XMLParser($xml); 56 57 # Load up the system config. 58 my %sysconf; 59 my $sysblock = $xp->data('system'); 60 if ($sysblock ne '') { 61 my $sysxp = new XMLParser($xp->data('system')); 62 for my $tag qw(pscmd logger uselogger logdir 63 maxlogsize loghistory path prefixtimestamp) { 64 $sysconf{$tag} = $sysxp->data($tag); 65 msg("System config $tag: $sysconf{$tag}\n") if ($sysconf{$tag} ne ''); 66 } 67 if ($sysconf{path} eq '') { 68 msg ("No path in configuration, using environment\n"); 69 $sysconf{path} = $ENV{PATH}; 70 } 71 if ($sysconf{logger} ne 'logger') { 72 msg ("Using non-default logger\n"); 73 $default_logger = $sysconf{logger}; 74 } 75 if ($sysconf{pscmd} eq '') { 76 $sysconf{pscmd} = xfind_bin('ps'); 77 if (`uname` =~ /SunOS/) { 78 $sysconf{pscmd} .= ' -ef pid,comm'; 79 } else { 80 $sysconf{pscmd} .= ' ax -o pid,command'; 81 } 82 } 83 msg ("PS command: $sysconf{pscmd}\n"); 84 85 if ($sysconf{prefixtimestamp}) { 86 $default_prefixtimestamp = 1 if istrue($sysconf{prefixtimestamp}); 87 } else { 88 $default_prefixtimestamp = 1 89 if (!istrue($sysconf{uselogger}) or !find_bin('logger')); 90 } 91 msg ("Log lines will be prefixed with a timestamp\n") 92 if ($default_prefixtimestamp); 93 } 94 95 # Load up the service names. 96 my @service_name; 97 for (my $i = 0; ; $i++) { 98 my $serviceblock = $xp->data('service', $i) or last; 99 my $servicexp = new XMLParser($serviceblock) 100 or die ("No <service> blocks in configuration\n"); 101 my $name = $servicexp->data('name') 102 or die ("<service> block lacks <name>\n"); 103 push (@service_name, $name); 104 msg ("Service '$name' seen\n"); 105 } 106 die ("No service blocks seen\n") if ($#service_name == -1); 107 108 # Take action 109 $|++; 110 my $cmd = shift(@ARGV); 111 @ARGV = @service_name if ($#ARGV == -1); 112 msg ("Acting on command: $cmd\n"); 113 if ($cmd eq 'list') { 114 cmd_list(@ARGV); 115 } elsif ($cmd eq 'start') { 116 cmd_start(@ARGV); 117 } elsif ($cmd eq 'stop') { 118 cmd_stop(@ARGV); 119 } elsif ($cmd eq 'kill') { 120 cmd_kill(@ARGV); 121 } elsif ($cmd eq 'force') { 122 cmd_force(@ARGV); 123 } elsif ($cmd eq 'stopstart') { 124 cmd_stopstart(@ARGV); 125 } elsif ($cmd eq 'killstart') { 126 cmd_killstart(@ARGV); 127 } elsif ($cmd eq 'status') { 128 cmd_status(@ARGV); 129 } elsif ($cmd eq 'rotate') { 130 cmd_rotate(@ARGV); 131 } elsif ($cmd eq 'configtest') { 132 cmd_configtest(@ARGV); 133 } elsif ($cmd eq 'generateconfig') { 134 cmd_generateconfig(@ARGV); 135 } else { 136 die ("Missing or unknown action $cmd\n"); 137 } 138 139 # -------------------------------------------------------------------------- 140 # Top level commands 141 142 sub cmd_list { 143 for my $s (@_) { 144 print ("Service: $s\n"); 145 print (" Process name : ", process_name($s), "\n"); 146 print (" Logging : ", log_file($s), "\n"); 147 print (" XR command : ", xr_command($s), "\n"); 148 } 149 } 150 151 sub cmd_start { 152 my @to_start; 153 for my $s (@_) { 154 if (is_running($s)) { 155 warn("Cannot start service $s, already running\n"); 156 } else { 157 push(@to_start, $s); 158 } 159 } 160 for my $s (@to_start) { 161 print ("Service $s: "); 162 start_service($s); 163 print ("started\n"); 164 } 165 } 166 167 sub cmd_stop { 168 my @pids; 169 for my $s (@_) { 170 my @p = is_running($s); 171 if ($#p == -1) { 172 warn("Cannot stop service $s, not running\n"); 173 } else { 174 print ("Service $s: running at @p\n"); 175 push (@pids, @p); 176 } 177 } 178 for my $p (@pids) { 179 msg ("About to stop PID: '$p'\n"); 180 } 181 kill (15, @pids) if ($#pids > -1); 182 print ("Services @_: stopped\n"); 183 } 184 185 sub cmd_kill { 186 my @pids; 187 for my $s (@_) { 188 my @p = is_running($s); 189 if ($#p == -1) { 190 warn("Cannot kill service $s, not running\n"); 191 } else { 192 print ("Service $s: running at @p\n"); 193 push (@pids, @p); 194 } 195 } 196 for my $p (@pids) { 197 msg ("About to kill PID: '$p'\n"); 198 } 199 kill (9, @pids) if ($#pids > -1); 200 print ("Services @_: killed\n"); 201 } 202 203 sub cmd_force { 204 for my $s (@_) { 205 print ("Service $s: "); 206 if (is_running($s)) { 207 print ("already running\n"); 208 } else { 209 start_service($s); 210 print ("started\n"); 211 } 212 } 213 } 214 215 sub cmd_stopstart { 216 my @pids; 217 for my $s (@_) { 218 my @p = is_running($s); 219 if ($#p == -1) { 220 warn("Cannot stop service $s, not running\n"); 221 } else { 222 push (@pids, @p); 223 } 224 } 225 print ("Service(s) @_: "); 226 kill (15, @pids) if ($#pids > -1); 227 print ("stoppped\n"); 228 for my $s (@_) { 229 print ("Service $s: "); 230 start_service($s); 231 print ("started\n"); 232 } 233 } 234 235 sub cmd_killstart { 236 my @pids; 237 for my $s (@_) { 238 my @p = is_running($s); 239 if ($#p == -1) { 240 warn("Cannot killstart service $s, not running\n"); 241 } else { 242 push (@pids, @p); 243 } 244 } 245 print ("Service(s) @_: "); 246 kill (9, @pids) if ($#pids > -1); 247 print ("killed\n"); 248 for my $s (@_) { 249 print ("Service $s: "); 250 start_service($s); 251 print ("started\n"); 252 } 253 } 254 255 sub cmd_status { 256 for my $s (@_) { 257 print ("Service $s: "); 258 print (BOLD, RED, "not ", RESET) unless (is_running($s)); 259 print ("running\n"); 260 } 261 } 262 263 sub cmd_rotate { 264 if (istrue($sysconf{uselogger}) and find_bin($default_logger)) { 265 print ("Rotating not necessary, logging goes via logger\n"); 266 return; 267 } 268 for my $s (@_) { 269 print ("Service $s: "); 270 my $f = log_file($s); 271 print ("log file $f, "); 272 if (substr($f, 0, 1) ne '>') { 273 print ("not a file\n"); 274 next; 275 } 276 $f = substr($f, 1); 277 if (! -f $f) { 278 print ("not present\n"); 279 next; 280 } 281 if ((stat($f))[7] < $sysconf{maxlogsize}) { 282 print ("no rotation necessary\n"); 283 next; 284 } 285 unlink("$f.$sysconf{loghistory}", 286 "$f.$sysconf{loghistory}.bz2", 287 "$f.$sysconf{loghistory}.gz"); 288 for (my $i = $sysconf{loghistory} - 1; $i >= 0; $i--) { 289 my $src = "$f.$i"; 290 my $dst = sprintf("$f.%d", $i + 1); 291 rename($src, $dst); 292 rename("$src.bz2", "$dst.bz2"); 293 rename("$src.gz", "$dst.gz"); 294 } 295 rename($f, "$f.0"); 296 print("rotated, "); 297 my $zipper; 298 if ($zipper = find_bin('bzip2') or $zipper = find_bin('gzip')) { 299 system ("$zipper $f.0"); 300 print ("zipped, "); 301 } 302 if (my @p = is_running($s)) { 303 kill (15, @p) if ($#p > -1); 304 print ("stopped, "); 305 start_service($s); 306 print ("started, "); 307 } 308 print ("done\n"); 309 } 310 } 311 312 sub cmd_configtest { 313 for my $s (@_) { 314 print ("Service $s: "); 315 my $cmd = xr_command($s) . ' --tryout'; 316 if (system ($cmd)) { 317 print ("FAILED, command: $cmd\n"); 318 } else { 319 print ("configuration ok\n"); 320 } 321 } 322 } 323 324 sub cmd_generateconfig { 325 print ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n", 326 "<configuration>\n", 327 "\n", 328 " <!-- System description -->\n", 329 " <system>\n"); 330 for my $k (sort (keys (%sysconf))) { 331 print (" <$k>$sysconf{$k}</$k>\n") if ($sysconf{$k} ne ''); 332 } 333 print (" </system>\n"); 334 335 for my $s (@_) { 336 generateconfig($s); 337 } 338 339 print ("</configuration>\n"); 340 } 341 342 343 # -------------------------------------------------------------------------- 344 # Small utility functions 345 346 # Show usage and die. 347 sub usage() { 348 die <<"ENDUSAGE"; 349 350 This is xrctl V$VER, the control script for XR, the Crossroads Load Balancer. 351 Usage: xrctl [-FLAGS] action [SERVICE ...] 352 Flags are: 353 -v increases verbosity 354 -c CONFIG specifies the configuration, default $default_conf 355 Actions are: 356 configtest validates the configuration 357 list shows the xr command line 358 start starts the service(s) if they are not yet running 359 stop gracefully stops the service(s) if they are running 360 kill brutally kills the service(s), interrupting all connections 361 force forces the service(s) up: starts if not running 362 stopstart gracefully restarts the service(s) if they are running 363 killstart brutally restarts 364 status shows which services are running 365 rotate rotates logs of the service(s) 366 generateconfig queries running XR's for the current configuration and 367 shows it in the format of $default_conf 368 The SERVICES following an action are the services stated in the configuration. 369 When absent, all configured services are handled. 370 371 ENDUSAGE 372 } 373 374 # Is a service running? 375 sub is_running { 376 my $s = shift; 377 open (my $if, "$sysconf{pscmd} |") 378 or die ("Cannot start '$sysconf{pscmd}': $!\n"); 379 my @ret; 380 while (my $line = <$if>) { 381 chomp ($line); 382 $line =~ s/^\s*//; 383 my ($pid, $cmd) = split(/\s+/, $line); 384 # msg("Command '$cmd' at pid '$pid' (line $line)\n"); 385 if ($cmd =~ /^xr-$s/) { 386 push (@ret, $pid); 387 msg ("Candidate PID: $pid\n"); 388 } 389 } 390 return (@ret); 391 } 392 393 # Unconditionally start a given service 394 sub start_service { 395 my $s = shift; 396 my $xr = xfind_bin('xr'); 397 my @args = xr_cmdarr($s); 398 my $logstr = log_file($s); 399 my $logtype = substr($logstr, 0, 1); 400 my $logout = substr($logstr, 1); 401 402 # Try out the command line 403 my $cmdline = xr_command($s) . ' --tryout'; 404 system ($cmdline) 405 and die ("Command line '$cmdline' fails to parse\n"); 406 407 my $pid = fork(); 408 die ("Cannot fork: $!\n") unless (defined ($pid)); 409 return if ($pid > 0); 410 411 # Child branch 412 open (STDIN, '/dev/null') or die ("Cannot read /dev/null: $!\n"); 413 414 if ($logtype eq '|') { 415 open (STDOUT, "|$logout") 416 or die ("Cannot pipe stdout to $logout: $!\n"); 417 open (STDERR, "|$logout") 418 or die ("Cannot pipe stderr to $logout: $!\n"); 419 } else { 420 open (STDOUT, ">>$logout") 421 or die ("Cannot append stdout to $logout: $!\n"); 422 open (STDERR, ">>$logout") 423 or die ("Cannot append stderr to $logout: $!\n"); 424 } 425 exec ({$xr} @args); 426 exit (1); 427 } 428 429 # Verbose message. 430 sub msg { 431 return unless ($opts{v}); 432 print (@_); 433 } 434 435 # Find a binary along the path 436 sub find_bin { 437 my $bin = shift; 438 my @parts = split (/\s/, $bin); 439 440 if (substr($parts[0], 0, 1) eq '/' and -x $parts[0]) { 441 msg("Binary '$bin' is executable as-is\n"); 442 return $bin; 443 } 444 for my $d (split (/:/, $sysconf{path})) { 445 if (-x "$d/$parts[0]" and -f "$d/$parts[0]") { 446 msg ("Binary '$parts[0]' found as '$d/$parts[0]'\n"); 447 $parts[0] = "$d/$parts[0]"; 448 return (join (' ', @parts)); 449 } 450 } 451 msg ("Binary '$bin' not found along $sysconf{path}\n"); 452 return (undef); 453 } 454 sub xfind_bin { 455 my $bin = shift; 456 my $ret = find_bin ($bin) 457 or die ("Binary '$bin' cannot be found along path '$sysconf{path}'\n"); 458 return ($ret); 459 } 460 461 # Process name according to a service name 462 sub process_name { 463 my $service = shift; 464 return ("xr-$service"); 465 } 466 467 # Log file according to a service name 468 sub log_file { 469 my $service = shift; 470 my $logger = find_bin($default_logger); 471 if (istrue($sysconf{uselogger}) and defined($logger)) { 472 if ($default_logger eq 'logger') { 473 return ("|$logger -t 'xr-$service'"); 474 } else { 475 $logger =~ s/\{service\}/$service/g; 476 return ("|$logger"); 477 } 478 } else { 479 return ('>' . $sysconf{logdir} . '/' . 480 process_name($service) . '.log'); 481 } 482 } 483 484 # XR command according to a service name as one string 485 sub xr_command { 486 my $service = shift; 487 my @parts = xr_cmdarr($service); 488 msg ("Exec command: @parts\n"); 489 my $ret = xfind_bin('xr'); 490 for (my $i = 1; $i <= $#parts; $i++) { 491 my $sub = $parts[$i]; 492 $sub =~ s/^\s+//; 493 $sub =~ s/\s+$//; 494 $ret .= ' ' . shquote($sub); 495 } 496 msg ("Shell command: $ret\n"); 497 return ($ret); 498 } 499 500 # XR command according to a service name as an array, including ARGV[0] 501 # pseudo-name 502 sub xr_cmdarr { 503 my $service = shift; 504 505 my @cmd; 506 push (@cmd, "xr-$service"); 507 push (@cmd, '--prefix-timestamp') 508 if ($default_prefixtimestamp); 509 510 # Fetch the <service> block for this service 511 my $sp = xml_serviceparser($service) 512 or die ("Failed to locate <service> block for service '$service'\n"); 513 514 # Service descriptions inside the <server> block 515 my $ss = xml_serverparser($sp); 516 my $type = 'tcp'; 517 $type = $ss->data('type') if ($ss->data('type')); 518 my $addr = '0:10000'; 519 $addr = $ss->data('address') if ($ss->data('address')); 520 my $full = "$type:$addr"; 521 push (@cmd, '--server', $full) if ($full ne 'tcp:0:10000'); 522 523 # Flags that should go on the command line if the bool-tag is true 524 my %boolflags = (closesocketsfast => '--close-sockets-fast', 525 verbose => '--verbose', 526 debug => '--debug', 527 removereservations => '--remove-reservations'); 528 529 # Web interface def comes from two tags 530 my $w = $ss->data('webinterface'); 531 if ($w) { 532 if (my $name = $ss->data('webinterfacename')) { 533 $w .= ":$name"; 534 } 535 push(@cmd, '--web-interface', $w); 536 } 537 538 # Handle general flags and boolflags 539 push (@cmd, 540 flag($ss, '--web-interface-auth', 'webinterfaceauth', ''), 541 flag($ss, '--dispatch-mode', 'dispatchmode', 542 $default_dispatchmode), 543 flag($ss, '--max-connections', 'maxconnections', 544 $default_maxconnections), 545 flag($ss, '--client-timeout', 'clienttimeout', 546 $default_client_timeout), 547 flag($ss, '--backend-timeout', 'backendtimeout', 548 $default_backend_timeout), 549 flag($ss, '--buffer-size', 'buffersize', 550 $default_buffersize), 551 flag($ss, '--wakeup-interval', 'wakeupinterval', 552 $default_wakeupinterval), 553 flag($ss, '--checkup-interval', 'checkupinterval', 554 $default_checkupinterval), 555 flag($ss, '--time-interval', 'timeinterval', 556 $default_timeinterval), 557 flag($ss, '--hard-maxconnrate', 'hardmaxconnrate', 558 $default_hardmaxconnrate), 559 flag($ss, '--soft-maxconnrate', 'softmaxconnrate', 560 $default_softmaxconnrate), 561 flag($ss, '--defer-time', 'defertime', 562 $default_defertime), 563 flag($ss, '--hard-maxconn-excess', 'hardmaxconnexcess', 564 $default_hardmaxconnexcess), 565 flag($ss, '--soft-maxconn-excess', 'softmaxconnexcess', 566 $default_softmaxconnexcess), 567 flag($ss, '--dns-cache-timeout', 'dnscachetimeout', 568 $default_dnscachetimeout), 569 flag($ss, '--onstart', 'onstart'), 570 flag($ss, '--onend', 'onend'), 571 flag($ss, '--onfail', 'onfail'), 572 flag($ss, '--log-traffic-dir', 'logtrafficdir', '')); 573 for my $k (sort (keys (%boolflags))) { 574 push (@cmd, $boolflags{$k}) if (istrue($ss->data($k))); 575 } 576 577 # Timeouts when specified using separate tags 578 my $t = $ss->data('clientreadtimeout'); 579 if (defined($t)) { 580 my $val = $t; 581 $t = $ss->data('clientwritetimeout'); 582 $val .= ":$t" if (defined($t)); 583 push (@cmd, '--client-timeout', $val); 584 } 585 $t = $ss->data('backendreadtimeout'); 586 if (defined($t)) { 587 my $val = $t; 588 $t = $ss->data('backendwritetimeout'); 589 $val .= ":$t" if (defined($t)); 590 push (@cmd, '--backend-timeout', $val); 591 } 592 593 # ACL's 594 for (my $i = 0; ; $i++) { 595 my $mask = $ss->data('allowfrom', $i) or last; 596 push (@cmd, '--allow-from', $mask); 597 } 598 for (my $i = 0; ; $i++) { 599 my $mask = $ss->data('denyfrom', $i) or last; 600 push (@cmd, '--deny-from', $mask); 601 } 602 603 # HTTP goodies 604 push (@cmd, '--add-xr-version') 605 if ($ss->data('addxrversion') and 606 istrue($ss->data('addxrversion'))); 607 push (@cmd, '--add-x-forwarded-for') 608 if ($ss->data('addxforwardedfor') and 609 istrue($ss->data('addxforwardedfor'))); 610 push (@cmd, '--sticky-http') 611 if ($ss->data('stickyhttp') and 612 istrue($ss->data('stickyhttp'))); 613 push (@cmd, '--replace-host-header') 614 if ($ss->data('replacehostheader') and 615 istrue($ss->data('replacehostheader'))); 616 for (my $i = 0; ; $i++) { 617 my $h = $ss->data('header', $i) or last; 618 push (@cmd, '--add-server-header', $h); 619 } 620 621 # The <backend> blocks for this service 622 my $last_hostmatch = $default_hostmatch; 623 my $last_urlmatch = $default_urlmatch; 624 my $last_backendcheck = $default_backendcheck; 625 for (my $i = 0; ; $i++) { 626 my $bp = xml_backendparser($sp, $i) or last; 627 628 # Handle host match 629 my $hm = $bp->data('hostmatch'); 630 if ($hm and $hm ne $last_hostmatch) { 631 push (@cmd, '--host-match', $hm); 632 } elsif ($hm eq '' and $last_hostmatch ne '') { 633 push (@cmd, '--host-match', $default_hostmatch); 634 } 635 $last_hostmatch = $hm; 636 637 # Handle url match 638 my $um = $bp->data('urlmatch'); 639 if ($um and $um ne $last_urlmatch) { 640 push (@cmd, '--url-match', $um); 641 } elsif ($um eq '' and $last_urlmatch ne '') { 642 push (@cmd, '--url-match', $default_urlmatch); 643 } 644 $last_urlmatch = $um; 645 646 # Handle back end checks 647 my $bc = $bp->data('backendcheck'); 648 if ($bc and $bc ne $last_backendcheck) { 649 push (@cmd, '--backend-check', $bc); 650 } elsif ($bc eq '' and $last_backendcheck ne '') { 651 push (@cmd, '--backend-check', $default_backendcheck); 652 } 653 $last_backendcheck = $bc; 654 655 # Get address, weight and max connections 656 my $ad = $bp->data('address') 657 or die ("Backend in service '$service' lacks <address>\n"); 658 my $mx = $bp->data('maxconnections'); 659 $mx = $default_maxconnections if (!$mx); 660 $ad .= ":$mx"; 661 my $wt = $bp->data('weight'); 662 $wt = $default_weight if (!$wt); 663 $ad .= ":$wt"; 664 665 push (@cmd, '--backend', $ad); 666 } 667 # TODO: <piddir> stuff, and the pid, resulting in something like: 668 # push(@cmd, '--pidfile', "/var/run/xr-$service.pid"); 669 670 # All done 671 my @ret; 672 # msg("Generated flags/arguments:\n"); 673 for my $c (@cmd) { 674 if ($c ne '') { 675 push (@ret, $c); 676 # msg (" $c"); 677 } 678 } 679 # msg ("\n"); 680 681 return (@ret); 682 } 683 684 # Shell-quote a string 685 sub shquote($) { 686 my $s = shift; 687 688 return $s unless ($s =~ /[\(\)\'\"\| \*\[\]\^\$]/); 689 690 if ($s !~ /'/) { 691 $s = "'$s'"; 692 } elsif ($s !~ /"/) { 693 $s = "\"$s\""; 694 } else { 695 $s =~ s/"/\\"/g; 696 $s = "\"$s\""; 697 } 698 699 return $s; 700 } 701 702 # Prepare a flag for the command line if it is defined and if it is 703 # not equal to the default 704 sub flag { 705 my ($parser, $longopt, $tag, $default) = @_; 706 msg ("Flag tag $tag: ", $parser->data($tag), " (default: '$default')\n"); 707 if ($parser->data($tag) ne '' && 708 $parser->data($tag) ne $default) { 709 msg ("Flag values meaningful: ", 710 $longopt, ' ', $parser->data($tag), "\n"); 711 return ($longopt, $parser->data($tag)); 712 } 713 return (undef); 714 } 715 716 # Is a boolean value true 717 sub istrue { 718 my $val = shift; 719 return (1) if ($val eq 'true' or $val eq 'on' or 720 $val eq 'yes' or $val != 0); 721 return (undef); 722 } 723 724 # Fetch an XMLParser for a <service> block given a service name 725 sub xml_serviceparser { 726 my $service = shift; 727 728 for (my $i = 0; ; $i++) { 729 my $xml = $xp->data('service', $i) or return (undef); 730 msg ("XML service block: $xml\n"); 731 my $sub = new XMLParser($xml); 732 return ($sub) if ($sub->data('name') eq $service); 733 } 734 return (undef); 735 } 736 737 # Fetch an XMLParser for a <server> block given a service parser 738 sub xml_serverparser { 739 my $serviceparser = shift; 740 my $xml = $serviceparser->data('server') or return undef; 741 return new XMLParser($xml); 742 } 743 744 # Fetch an XMLParser for a <backend> block given a service parser and 745 # an order number 746 sub xml_backendparser { 747 my ($serviceparser, $order) = @_; 748 $order = 0 unless ($order); 749 my $xml = $serviceparser->data('backend', $order) or return (undef); 750 return (new XMLParser($xml)); 751 } 752 753 # Generate a service configuration from the running XR, if it has a 754 # web interface 755 sub generateconfig { 756 my $s = shift; 757 msg ("Generating runtime configuration for service '$s'\n"); 758 759 my $sp = xml_serviceparser($s) or die ("No service '$s' known.\n"); 760 my $webint = $sp->data('webinterface'); 761 762 # Web interface at IP "0" means localhost 763 $webint =~ s/^0:/localhost:/; 764 765 if ($webint eq '') { 766 print ("\n", 767 " <!-- Configuration for service $s not generated,\n", 768 " no web interface known -->\n"); 769 return; 770 } 771 772 print ("\n", 773 " <!-- Configuration for service $s,\n", 774 " obtained at web interface $webint -->\n", 775 " <service>\n", 776 " <name>$s</name>\n"); 777 778 # Get the configuration from a running XR. Try LWP::UserAgent or 779 # fall back to wget. 780 my $response_blob; 781 eval ("require LWP::UserAgent;"); 782 if ($@) { 783 msg ("LWP::UserAgent not present, trying wget\n"); 784 my $wget = find_bin('wget') 785 or die ("Neither LWP::UserAgent nor wget found.\n", 786 "Cannot contact service web interface $webint.\n"); 787 open (my $if, "wget --no-proxy -q -O- http://$webint/ |") 788 or die ("Cannot start wget: $!\n"); 789 while (my $line = <$if>) { 790 $response_blob .= $line; 791 } 792 close ($if) or die ("Wget indicates failure\n"); 793 } else { 794 my $ua = LWP::UserAgent->new(); 795 my $res = $ua->get("http://$webint/"); 796 die ("Failed to contact web interface at $webint:\n", 797 $res->status_line(), "\n") unless ($res->is_success()); 798 799 $response_blob = $res->content(); 800 } 801 802 # Print the config. 803 my $active = 0; 804 for my $l (split (/\n/, $response_blob)) { 805 if ($l =~ /<server>/) { 806 print (" $l\n"); 807 $active = 1; 808 } elsif ($l =~ /<\/status>/) { 809 $active = 0; 810 } elsif ($l =~ /<activity>/) { 811 $active = 0; 812 } elsif ($l =~ /<\/activity>/) { 813 $active = 1; 814 } elsif ($active) { 815 print (" $l\n"); 816 } 817 } 818 819 print (" </service>\n"); 820 } 821 822 # -------------------------------------------------------------------------- 823 # Idiotically simple XML parser. Used instead of a "real" parser so that 824 # xrctl isn't dependent on modules and can run anywhere. Safe for using 825 # with xr-style XML configs, but not with any XML in the free. 826 827 package XMLParser; 828 sub new { 829 my ($proto, $doc) = @_; 830 my $self = {}; 831 die ("Missing XML document\n") unless($doc); 832 833 my $docstr = ''; 834 for my $p (split (/\n/, $doc)) { 835 $docstr .= $p; 836 } 837 838 # Whitespace between tags is trash 839 $docstr =~ s{>\s+<}{><}g; 840 841 # Remove comments from the doc 842 FINDCOMM: 843 for (my $i = 0; $i <= length($docstr); $i++) { 844 next unless (substr($docstr, $i, 4) eq '<!--'); 845 for (my $end = $i + 4; $end <= length($docstr); $end++) { 846 if (substr($docstr, $end, 3) eq '-->') { 847 # print ("Comment: ", substr($docstr, $i, $end + 3 - $i), "\n"); 848 $docstr = substr($docstr, 0, $i) . substr($docstr, $end + 3); 849 $i--; 850 next FINDCOMM; 851 } 852 } 853 } 854 855 # Activity logs is trash 856 $docstr =~ s{<activity>.*</activity>}{}g; 857 858 # print $docstr, "\n"; 859 860 $self->{xml} = $docstr; 861 bless ($self, $proto); 862 863 return ($self); 864 } 865 866 sub data { 867 my ($self, $tag, $order) = @_; 868 # print("Searching for <$tag> order $order\n"); 869 die ("XML::data: no tag to search for\n") unless ($tag); 870 $order = 0 unless ($order); 871 my $xml = $self->{xml}; 872 my $ret = undef; 873 for (0..$order) { 874 my $start = _findfirst($xml, "<$tag>"); 875 return (undef) unless (defined ($start)); 876 $xml = substr($xml, $start + length("<$tag>")); 877 # print ("start $start $xml\n"); 878 my $end = _findfirst($xml, "</$tag>"); 879 die ("Failed to match </$tag>, invalid XML\n") 880 unless (defined ($end)); 881 $ret = substr($xml, 0, $end); 882 $xml = substr($xml, $end + length("</tag>")); 883 # print ("end $end $xml\n"); 884 } 885 # print("Result for <$tag> $order: [$ret]\n"); 886 return ($ret); 887 } 888 889 sub _findfirst { 890 my ($stack, $needle) = @_; 891 # print ("needle: $needle, stack: $stack\n"); 892 for my $i (0..length($stack)) { 893 my $sub = substr($stack, $i, length($needle)); 894 # print ("sub: $sub\n"); 895 return ($i) if ($sub eq $needle); 896 } 897 return (undef); 898 } 899 900 sub _findlast { 901 my ($stack, $needle) = @_; 902 for (my $i = length($stack); $i >= 0; $i--) { 903 return ($i) if (substr($stack, $i, length($needle)) eq $needle); 904 } 905 return (undef); 906 } 907 908 1;