crossroads 2.81-2 / usr / bin / xrctl

#!/usr/bin/perl
use strict;
use Getopt::Std;
use Term::ANSIColor qw(:constants);

# Versioning
my $VER = "2.81";

# --------------------------------------------------------------------------
# xrctl: used to start, stop, restart etc. the XR balancer.

# Default configuration file to read and default logging facility
my $default_conf = '/etc/xrctl.xml';
my $default_logger = 'logger';
my $default_prefixtimestamp = undef;

# Default settings, must match xr's defaults
my $default_dispatchmode = 'least-connections';
my $default_maxconnections = 0;
my $default_client_timeout = 30;
my $default_client_read_timeout = 30;
my $default_client_write_timeout = 30;
my $default_backend_timeout = 30;
my $default_backend_read_timeout = 3;
my $default_backend_write_timeout = 3;
my $default_buffersize = 2048;
my $default_wakeupinterval = 5;
my $default_checkupinterval = 0;
my $default_weight = 1;
my $default_hostmatch = '.';
my $default_urlmatch = '.';
my $default_backendcheck = 'connect::';
my $default_timeinterval = 1;
my $default_hardmaxconnrate = 0;
my $default_softmaxconnrate = 0;
my $default_defertime = 500000;
my $default_hardmaxconnexcess = 0;
my $default_softmaxconnexcess = 0;
my $default_dnscachetimeout = 3600;

# Cmd line flags
my %opts = (v => 0,
            c => $default_conf,
           );
usage() unless (getopts('vc:', \%opts));
usage() if ($#ARGV == -1);

# Load configuration
my $xml;
open (my $if, $opts{c}) or die ("Cannot read configuration $opts{c}: $!\n");
while (my $line = <$if>) {
    $xml .= $line;
}
close ($if);
my $xp = new XMLParser($xml);

# Load up the system config.
my %sysconf;
my $sysblock = $xp->data('system');
if ($sysblock ne '') {
    my $sysxp = new XMLParser($xp->data('system'));
    for my $tag (qw[pscmd logger uselogger logdir
                   maxlogsize loghistory path prefixtimestamp]) {
        $sysconf{$tag} = $sysxp->data($tag);
        msg("System config $tag: $sysconf{$tag}\n") if ($sysconf{$tag} ne '');
    }
    if ($sysconf{path} eq '') {
        msg ("No path in configuration, using environment\n");
        $sysconf{path} = $ENV{PATH};
    }
    if ($sysconf{logger} ne 'logger') {
        msg ("Using non-default logger\n");
        $default_logger = $sysconf{logger};
    }
    if ($sysconf{pscmd} eq '') {
        $sysconf{pscmd} = xfind_bin('ps');
        if (`uname` =~ /SunOS/) {
            $sysconf{pscmd} .= ' -ef pid,comm';
        } else {
            $sysconf{pscmd} .= ' ax -o pid,command';
        }
    }
    msg ("PS command: $sysconf{pscmd}\n");
    
    if ($sysconf{prefixtimestamp}) {
        $default_prefixtimestamp = 1 if istrue($sysconf{prefixtimestamp});
    } else {
        $default_prefixtimestamp = 1 
          if (!istrue($sysconf{uselogger}) or !find_bin('logger'));
    }
    msg ("Log lines will be prefixed with a timestamp\n")
      if ($default_prefixtimestamp);
}

# Load up the service names.
my @service_name;
for (my $i = 0; ; $i++) {
    my $serviceblock = $xp->data('service', $i) or last;
    my $servicexp = new XMLParser($serviceblock)
      or die ("No <service> blocks in configuration\n");
    my $name = $servicexp->data('name')
      or die ("<service> block lacks <name>\n");
    push (@service_name, $name);
    msg ("Service '$name' seen\n");
}
die ("No service blocks seen\n") if ($#service_name == -1);

# Take action
$|++;
my $cmd = shift(@ARGV);
@ARGV = @service_name if ($#ARGV == -1);
msg ("Acting on command: $cmd\n");
if ($cmd eq 'list') {
    cmd_list(@ARGV);
} elsif ($cmd eq 'start') {
    cmd_start(@ARGV);
} elsif ($cmd eq 'stop') {
    cmd_stop(@ARGV);
} elsif ($cmd eq 'kill') {
    cmd_kill(@ARGV);
} elsif ($cmd eq 'force') {
    cmd_force(@ARGV);
} elsif ($cmd eq 'stopstart') {
    cmd_stopstart(@ARGV);
} elsif ($cmd eq 'killstart') {
    cmd_killstart(@ARGV);
} elsif ($cmd eq 'status') {
    cmd_status(@ARGV);
} elsif ($cmd eq 'rotate') {
    cmd_rotate(@ARGV);
} elsif ($cmd eq 'configtest') {
    cmd_configtest(@ARGV);
} elsif ($cmd eq 'generateconfig') {
    cmd_generateconfig(@ARGV);
} else {
    die ("Missing or unknown action $cmd\n");
}

# --------------------------------------------------------------------------
# Top level commands

sub cmd_list {
    for my $s (@_) {
        print ("Service: $s\n");
        print ("  Process name : ", process_name($s), "\n");
        print ("  Logging      : ", log_file($s), "\n");
        print ("  XR command   : ", xr_command($s), "\n");
    }
}

sub cmd_start {
    my @to_start;
    for my $s (@_) {
	if (is_running($s)) {
	    warn("Cannot start service $s, already running\n");
	} else {
	    push(@to_start, $s);
	}
    }
    for my $s (@to_start) {
        print ("Service $s: ");
        start_service($s);
        print ("started\n");
    }
}

sub cmd_stop {
    my @pids;
    for my $s (@_) {
        my @p = is_running($s);
	if ($#p == -1) {
	    warn("Cannot stop service $s, not running\n");
	} else {
	    print ("Service $s: running at @p\n");
	    push (@pids, @p);
	}
    }
    for my $p (@pids) {
        msg ("About to stop PID: '$p'\n");
    }
    kill (15, @pids) if ($#pids > -1);
    print ("Services @_: stopped\n");
}

sub cmd_kill {
    my @pids;
    for my $s (@_) {
        my @p = is_running($s);
	if ($#p == -1) {
	    warn("Cannot kill service $s, not running\n");
	} else {
	    print ("Service $s: running at @p\n");
	    push (@pids, @p);
	}
    }
    for my $p (@pids) {
        msg ("About to kill PID: '$p'\n");
    }
    kill (9, @pids) if ($#pids > -1);
    print ("Services @_: killed\n");
}

sub cmd_force {
    for my $s (@_) {
        print ("Service $s: ");
        if (is_running($s)) {
            print ("already running\n");
        } else {
            start_service($s);
            print ("started\n");
        }
    }
}

sub cmd_stopstart {
    my @pids;
    for my $s (@_) {
        my @p = is_running($s);
	if ($#p == -1) {
	    warn("Cannot stop service $s, not running\n");
	} else {
	    push (@pids, @p);
	}
    }
    print ("Service(s) @_: ");
    kill (15, @pids) if ($#pids > -1);
    print ("stoppped\n");
    for my $s (@_) {
        print ("Service $s: ");
        start_service($s);
        print ("started\n");
    }
}

sub cmd_killstart {
    my @pids;
    for my $s (@_) {
        my @p = is_running($s);
	if ($#p == -1) {
	    warn("Cannot killstart service $s, not running\n");
	} else {
	    push (@pids, @p);
	}
    }
    print ("Service(s) @_: ");
    kill (9, @pids) if ($#pids > -1);
    print ("killed\n");
    for my $s (@_) {
        print ("Service $s: ");
        start_service($s);
        print ("started\n");
    }
}

sub cmd_status {
    for my $s (@_) {
        print ("Service $s: ");
        print (BOLD, RED, "not ", RESET) unless (is_running($s));
        print ("running\n");
    }
}

sub cmd_rotate {
    if (istrue($sysconf{uselogger}) and find_bin($default_logger)) {
        print ("Rotating not necessary, logging goes via logger\n");
        return;
    }
    for my $s (@_) {
        print ("Service $s: ");
        my $f = log_file($s);
        print ("log file $f, ");
        if (substr($f, 0, 1) ne '>') {
            print ("not a file\n");
            next;
        }
        $f = substr($f, 1);
        if (! -f $f) {
            print ("not present\n");
            next;
        }
        if ((stat($f))[7] < $sysconf{maxlogsize}) {
            print ("no rotation necessary\n");
            next;
        }
        unlink("$f.$sysconf{loghistory}",
               "$f.$sysconf{loghistory}.bz2",
               "$f.$sysconf{loghistory}.gz");
        for (my $i = $sysconf{loghistory} - 1; $i >= 0; $i--) {
            my $src = "$f.$i";
            my $dst = sprintf("$f.%d", $i + 1);
            rename($src, $dst);
            rename("$src.bz2", "$dst.bz2");
            rename("$src.gz", "$dst.gz");
        }
        rename($f, "$f.0");
        print("rotated, ");
        my $zipper;
        if ($zipper = find_bin('bzip2') or $zipper = find_bin('gzip')) {
            system ("$zipper $f.0");
            print ("zipped, ");
        }
        if (my @p = is_running($s)) {
            kill (15, @p) if ($#p > -1);
            print ("stopped, ");
            start_service($s);
            print ("started, ");
        }
        print ("done\n");
    }
}

sub cmd_configtest {
    for my $s (@_) {
        print ("Service $s: ");
        my $cmd = xr_command($s) . ' --tryout';
        if (system ($cmd)) {
            print ("FAILED, command: $cmd\n");
        } else {
            print ("configuration ok\n");
        }
    }
}

sub cmd_generateconfig {
    print ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n",
           "<configuration>\n",
           "\n",
           "  <!-- System description -->\n",
           "  <system>\n");
    for my $k (sort (keys (%sysconf))) {
        print ("    <$k>$sysconf{$k}</$k>\n") if ($sysconf{$k} ne '');
    }
    print ("  </system>\n");

    for my $s (@_) {
        generateconfig($s);
    }

    print ("</configuration>\n");
}


# --------------------------------------------------------------------------
# Small utility functions

# Show usage and die.
sub usage() {
    die <<"ENDUSAGE";

This is xrctl V$VER, the control script for XR, the Crossroads Load Balancer.
Usage: xrctl [-FLAGS] action [SERVICE ...]
Flags are:
  -v        increases verbosity
  -c CONFIG specifies the configuration, default $default_conf
Actions are:
  configtest     validates the configuration
  list           shows the xr command line
  start          starts the service(s) if they are not yet running
  stop           gracefully stops the service(s) if they are running
  kill           brutally kills the service(s), interrupting all connections
  force          forces the service(s) up: starts if not running
  stopstart      gracefully restarts the service(s) if they are running
  killstart      brutally restarts
  status         shows which services are running
  rotate         rotates logs of the service(s)
  generateconfig queries running XR's for the current configuration and
                 shows it in the format of $default_conf
The SERVICES following an action are the services stated in the configuration.
When absent, all configured services are handled.

ENDUSAGE
}

# Is a service running?
sub is_running {
    my $s = shift;
    open (my $if, "$sysconf{pscmd} |")
      or die ("Cannot start '$sysconf{pscmd}': $!\n");
    my @ret;
    while (my $line = <$if>) {
        chomp ($line);
        $line =~ s/^\s*//;
        my ($pid, $cmd) = split(/\s+/, $line);
        # msg("Command '$cmd' at pid '$pid' (line $line)\n");
        if ($cmd =~ /^xr-$s/) {
            push (@ret, $pid);
            msg ("Candidate PID: $pid\n");
        }
    }
    return (@ret);
}

# Unconditionally start a given service
sub start_service {
    my $s = shift;
    my $xr      = xfind_bin('xr');
    my @args    = xr_cmdarr($s);
    my $logstr  = log_file($s);
    my $logtype = substr($logstr, 0, 1);
    my $logout  = substr($logstr, 1);

    # Try out the command line
    my $cmdline = xr_command($s) . ' --tryout';
    system ($cmdline)
      and die ("Command line '$cmdline' fails to parse\n");

    my $pid = fork();
    die ("Cannot fork: $!\n") unless (defined ($pid));
    return if ($pid > 0);

    # Child branch
    open (STDIN, '/dev/null') or die ("Cannot read /dev/null: $!\n");

    if ($logtype eq '|') {
        open (STDOUT, "|$logout")
          or die ("Cannot pipe stdout to $logout: $!\n");
        open (STDERR, "|$logout")
          or die ("Cannot pipe stderr to $logout: $!\n");
    } else {
        open (STDOUT, ">>$logout")
          or die ("Cannot append stdout to $logout: $!\n");
        open (STDERR, ">>$logout")
          or die ("Cannot append stderr to $logout: $!\n");
    }
    exec ({$xr} @args);
    exit (1);
}

# Verbose message.
sub msg {
    return unless ($opts{v});
    print (@_);
}

# Find a binary along the path
sub find_bin {
    my $bin = shift;
    my @parts = split (/\s/, $bin);

    if (substr($parts[0], 0, 1) eq '/' and -x $parts[0]) {
        msg("Binary '$bin' is executable as-is\n");
        return $bin;
    }
    for my $d (split (/:/, $sysconf{path})) {
        if (-x "$d/$parts[0]" and -f "$d/$parts[0]") {
            msg ("Binary '$parts[0]' found as '$d/$parts[0]'\n");
            $parts[0] = "$d/$parts[0]";
            return (join (' ', @parts));
        }
    }
    msg ("Binary '$bin' not found along $sysconf{path}\n");
    return (undef);
}
sub xfind_bin {
    my $bin = shift;
    my $ret = find_bin ($bin)
      or die ("Binary '$bin' cannot be found along path '$sysconf{path}'\n");
    return ($ret);
}

# Process name according to a service name
sub process_name {
    my $service = shift;
    return ("xr-$service");
}

# Log file according to a service name
sub log_file {
    my $service = shift;
    my $logger = find_bin($default_logger);
    if (istrue($sysconf{uselogger}) and defined($logger)) {
        if ($default_logger eq 'logger') {
            return ("|$logger -t 'xr-$service'");
        } else {
            $logger =~ s/\{service\}/$service/g; 
            return ("|$logger");
        }
    } else {
        return ('>' . $sysconf{logdir} . '/' .
                process_name($service) . '.log');
    }
}

# XR command according to a service name as one string
sub xr_command {
    my $service = shift;
    my @parts = xr_cmdarr($service);
    msg ("Exec command: @parts\n");
    my $ret = xfind_bin('xr');
    for (my $i = 1; $i <= $#parts; $i++) {
        my $sub = $parts[$i];
        $sub =~ s/^\s+//;
        $sub =~ s/\s+$//;
        $ret .= ' ' . shquote($sub);
    }
    msg ("Shell command: $ret\n");
    return ($ret);
}

# XR command according to a service name as an array, including ARGV[0]
# pseudo-name
sub xr_cmdarr {
    my $service = shift;

    my @cmd;
    push (@cmd, "xr-$service");
    push (@cmd, '--prefix-timestamp')
      if ($default_prefixtimestamp);

    # Fetch the <service> block for this service
    my $sp = xml_serviceparser($service)
      or die ("Failed to locate <service> block for service '$service'\n");

    # Service descriptions inside the <server> block
    my $ss = xml_serverparser($sp);
    my $type = 'tcp';
    $type = $ss->data('type') if ($ss->data('type'));
    my $addr = '0:10000';
    $addr = $ss->data('address') if ($ss->data('address'));
    my $full = "$type:$addr";
    push (@cmd, '--server', $full) if ($full ne 'tcp:0:10000');

    # Flags that should go on the command line if the bool-tag is true
    my %boolflags = (closesocketsfast => '--close-sockets-fast',
                     verbose => '--verbose',
                     debug => '--debug',
                     removereservations => '--remove-reservations');

    # Web interface def comes from two tags
    my $w = $ss->data('webinterface');
    if ($w) {
        if (my $name = $ss->data('webinterfacename')) {
            $w .= ":$name";
        }
        push(@cmd, '--web-interface', $w);
    }   

    # Handle general flags and boolflags
    push (@cmd,
          flag($ss, '--web-interface-auth', 'webinterfaceauth', ''),
          flag($ss, '--dispatch-mode', 'dispatchmode',
               $default_dispatchmode),
          flag($ss, '--max-connections', 'maxconnections',
               $default_maxconnections),
          flag($ss, '--client-timeout', 'clienttimeout',
               $default_client_timeout),
          flag($ss, '--backend-timeout', 'backendtimeout',
               $default_backend_timeout),
          flag($ss, '--buffer-size', 'buffersize',
               $default_buffersize),
          flag($ss, '--wakeup-interval', 'wakeupinterval',
               $default_wakeupinterval),
          flag($ss, '--checkup-interval', 'checkupinterval',
               $default_checkupinterval),
          flag($ss, '--time-interval', 'timeinterval',
               $default_timeinterval),
          flag($ss, '--hard-maxconnrate', 'hardmaxconnrate',
               $default_hardmaxconnrate),
          flag($ss, '--soft-maxconnrate', 'softmaxconnrate',
               $default_softmaxconnrate),
          flag($ss, '--defer-time', 'defertime',
               $default_defertime),
          flag($ss, '--hard-maxconn-excess', 'hardmaxconnexcess',
               $default_hardmaxconnexcess),
          flag($ss, '--soft-maxconn-excess', 'softmaxconnexcess',
               $default_softmaxconnexcess),
          flag($ss, '--dns-cache-timeout', 'dnscachetimeout',
               $default_dnscachetimeout),
          flag($ss, '--onstart', 'onstart'),
          flag($ss, '--onend', 'onend'),
          flag($ss, '--onfail', 'onfail'),
          flag($ss, '--log-traffic-dir', 'logtrafficdir', ''));
    for my $k (sort (keys (%boolflags))) {
        push (@cmd, $boolflags{$k}) if (istrue($ss->data($k)));
    }

    # Timeouts when specified using separate tags
    my $t = $ss->data('clientreadtimeout');
    if (defined($t)) {
        my $val = $t;
        $t = $ss->data('clientwritetimeout');
        $val .= ":$t" if (defined($t));
        push (@cmd, '--client-timeout', $val);
    }
    $t = $ss->data('backendreadtimeout');
    if (defined($t)) {
        my $val = $t;
        $t = $ss->data('backendwritetimeout');
        $val .= ":$t" if (defined($t));
        push (@cmd, '--backend-timeout', $val);
    }

    # ACL's
    for (my $i = 0; ; $i++) {
        my $mask = $ss->data('allowfrom', $i) or last;
        push (@cmd, '--allow-from', $mask);
    }
    for (my $i = 0; ; $i++) {
        my $mask = $ss->data('denyfrom', $i) or last;
        push (@cmd, '--deny-from', $mask);
    }

    # HTTP goodies
    push (@cmd, '--add-xr-version')
      if ($ss->data('addxrversion') and
          istrue($ss->data('addxrversion')));
    push (@cmd, '--add-x-forwarded-for')
      if ($ss->data('addxforwardedfor') and
          istrue($ss->data('addxforwardedfor')));
    push (@cmd, '--sticky-http')
      if ($ss->data('stickyhttp') and
          istrue($ss->data('stickyhttp')));
    push (@cmd, '--replace-host-header')
      if ($ss->data('replacehostheader') and
          istrue($ss->data('replacehostheader')));
    for (my $i = 0; ; $i++) {
        my $h = $ss->data('header', $i) or last;
        push (@cmd, '--add-server-header', $h);
    }

    # The <backend> blocks for this service
    my $last_hostmatch    = $default_hostmatch;
    my $last_urlmatch     = $default_urlmatch;
    my $last_backendcheck = $default_backendcheck;
    for (my $i = 0; ; $i++) {
        my $bp = xml_backendparser($sp, $i) or last;

        # Handle host match
        my $hm = $bp->data('hostmatch');
        if ($hm and $hm ne $last_hostmatch) {
            push (@cmd, '--host-match', $hm);
        } elsif ($hm eq '' and $last_hostmatch ne '') {
            push (@cmd, '--host-match', $default_hostmatch);
        }
        $last_hostmatch = $hm;

        # Handle url match
        my $um = $bp->data('urlmatch');
        if ($um and $um ne $last_urlmatch) {
            push (@cmd, '--url-match', $um);
        } elsif ($um eq '' and $last_urlmatch ne '') {
            push (@cmd, '--url-match', $default_urlmatch);
        }
        $last_urlmatch = $um;

        # Handle back end checks
        my $bc = $bp->data('backendcheck');
        if ($bc and $bc ne $last_backendcheck) {
            push (@cmd, '--backend-check', $bc);
        } elsif ($bc eq '' and $last_backendcheck ne '') {
            push (@cmd, '--backend-check', $default_backendcheck);
        }
        $last_backendcheck = $bc;

        # Get address, weight and max connections
        my $ad = $bp->data('address')
          or die ("Backend in service '$service' lacks <address>\n");
        my $mx = $bp->data('maxconnections');
        $mx = $default_maxconnections if (!$mx);
        $ad .= ":$mx";
        my $wt = $bp->data('weight');
        $wt = $default_weight if (!$wt);
        $ad .= ":$wt";

        push (@cmd, '--backend', $ad);
    }
    # TODO: <piddir> stuff, and the pid, resulting in something like:
    # push(@cmd, '--pidfile', "/var/run/xr-$service.pid");

    # All done
    my @ret;
    # msg("Generated flags/arguments:\n");
    for my $c (@cmd) {
        if ($c ne '') {
            push (@ret, $c);
            # msg (" $c");
        }
    }
    # msg ("\n");
    
    return (@ret);
}

# Shell-quote a string
sub shquote($) {
    my $s = shift;
    
    return $s unless ($s =~ /[\(\)\'\"\| \*\[\]\^\$]/);

    if ($s !~ /'/) {
        $s = "'$s'";
    } elsif ($s !~ /"/) {
        $s = "\"$s\"";
    } else {
        $s =~ s/"/\\"/g;
        $s = "\"$s\"";
    }

    return $s;
}

# Prepare a flag for the command line if it is defined and if it is
# not equal to the default
sub flag {
    my ($parser, $longopt, $tag, $default) = @_;
    msg ("Flag tag $tag: ", $parser->data($tag), " (default: '$default')\n");
    if ($parser->data($tag) ne '' &&
        $parser->data($tag) ne $default) {
        msg ("Flag values meaningful: ",
             $longopt, ' ', $parser->data($tag), "\n");
        return ($longopt, $parser->data($tag));
    }
    return (undef);
}

# Is a boolean value true
sub istrue {
    my $val = shift;
    return (1) if ($val eq 'true' or $val eq 'on' or
                   $val eq 'yes' or $val != 0);
    return (undef);
}

# Fetch an XMLParser for a <service> block given a service name
sub xml_serviceparser {
    my $service = shift;

    for (my $i = 0; ; $i++) {
        my $xml = $xp->data('service', $i) or return (undef);
        msg ("XML service block: $xml\n");
        my $sub = new XMLParser($xml);
        return ($sub) if ($sub->data('name') eq $service);
    }
    return (undef);
}

# Fetch an XMLParser for a <server> block given a service parser
sub xml_serverparser {
    my $serviceparser = shift;
    my $xml = $serviceparser->data('server') or return undef;
    return new XMLParser($xml);
}

# Fetch an XMLParser for a <backend> block given a service parser and
# an order number
sub xml_backendparser {
    my ($serviceparser, $order) = @_;
    $order = 0 unless ($order);
    my $xml = $serviceparser->data('backend', $order) or return (undef);
    return (new XMLParser($xml));
}

# Generate a service configuration from the running XR, if it has a
# web interface
sub generateconfig {
    my $s = shift;
    msg ("Generating runtime configuration for service '$s'\n");

    my $sp = xml_serviceparser($s) or die ("No service '$s' known.\n");
    my $webint = $sp->data('webinterface');

    # Web interface at IP "0" means localhost    
    $webint =~ s/^0:/localhost:/;

    if ($webint eq '') {
        print ("\n",
               "  <!-- Configuration for service $s not generated,\n",
               "       no web interface known -->\n");
        return;
    }

    print ("\n",
           "  <!-- Configuration for service $s,\n",
           "       obtained at web interface $webint -->\n",
           "  <service>\n",
           "    <name>$s</name>\n");

    # Get the configuration from a running XR. Try LWP::UserAgent or
    # fall back to wget.
    my $response_blob;
    eval ("require LWP::UserAgent;");
    if ($@) {
        msg ("LWP::UserAgent not present, trying wget\n");
        my $wget = find_bin('wget')
          or die ("Neither LWP::UserAgent nor wget found.\n",
                  "Cannot contact service web interface $webint.\n");
        open (my $if, "wget --no-proxy -q -O- http://$webint/ |")
          or die ("Cannot start wget: $!\n");
        while (my $line = <$if>) {
            $response_blob .= $line;
        }
        close ($if) or die ("Wget indicates failure\n");
    } else {
        my $ua = LWP::UserAgent->new();
        my $res = $ua->get("http://$webint/");
        die ("Failed to contact web interface at $webint:\n",
             $res->status_line(), "\n") unless ($res->is_success());

        $response_blob = $res->content();
    }

    # Print the config.
    my $active = 0;
    for my $l (split (/\n/, $response_blob)) {
        if ($l =~ /<server>/) {
            print ("  $l\n");
            $active = 1;
        } elsif ($l =~ /<\/status>/) {
            $active = 0;
        } elsif ($l =~ /<activity>/) {
            $active = 0;
        } elsif ($l =~ /<\/activity>/) {
            $active = 1;
        } elsif ($active) {
            print ("  $l\n");
        }
    }

    print ("  </service>\n");
}

# --------------------------------------------------------------------------
# Idiotically simple XML parser. Used instead of a "real" parser so that
# xrctl isn't dependent on modules and can run anywhere. Safe for using
# with xr-style XML configs, but not with any XML in the free.

package XMLParser;
sub new {
    my ($proto, $doc) = @_;
    my $self = {};
    die ("Missing XML document\n") unless($doc);

    my $docstr = '';
    for my $p (split (/\n/, $doc)) {
        $docstr .= $p;
    }

    # Whitespace between tags is trash
    $docstr =~ s{>\s+<}{><}g;

    # Remove comments from the doc
    FINDCOMM:
    for (my $i = 0; $i <= length($docstr); $i++) {
        next unless (substr($docstr, $i, 4) eq '<!--');
        for (my $end = $i + 4; $end <= length($docstr); $end++) {
            if (substr($docstr, $end, 3) eq '-->') {
                # print ("Comment: ", substr($docstr, $i, $end + 3 - $i), "\n");
                $docstr = substr($docstr, 0, $i) . substr($docstr, $end + 3);
                $i--;
                next FINDCOMM;
            }
        }
    }

    # Activity logs is trash
    $docstr =~ s{<activity>.*</activity>}{}g;

    # print $docstr, "\n";

    $self->{xml} = $docstr;
    bless ($self, $proto);

    return ($self);
}

sub data {
    my ($self, $tag, $order) = @_;
    # print("Searching for <$tag> order $order\n");
    die ("XML::data: no tag to search for\n") unless ($tag);
    $order = 0 unless ($order);
    my $xml = $self->{xml};
    my $ret = undef;
    for (0..$order) {
        my $start = _findfirst($xml, "<$tag>");
        return (undef) unless (defined ($start));
        $xml = substr($xml, $start + length("<$tag>"));
        # print ("start $start $xml\n");
        my $end = _findfirst($xml, "</$tag>");
        die ("Failed to match </$tag>, invalid XML\n")
          unless (defined ($end));
        $ret = substr($xml, 0, $end);
        $xml = substr($xml, $end + length("</tag>"));
        # print ("end $end $xml\n");
    }
    # print("Result for <$tag> $order: [$ret]\n");
    return ($ret);
}

sub _findfirst {
    my ($stack, $needle) = @_;
    # print ("needle: $needle, stack: $stack\n");
    for my $i (0..length($stack)) {
        my $sub = substr($stack, $i, length($needle));
        # print ("sub: $sub\n");
        return ($i) if ($sub eq $needle);
    }
    return (undef);
}

sub _findlast {
    my ($stack, $needle) = @_;
    for (my $i = length($stack); $i >= 0; $i--) {
        return ($i) if (substr($stack, $i, length($needle)) eq $needle);
    }
    return (undef);
}

1;