#!/usr/bin/perl
use strict;

# Configuration section. Enter your favorite values here.
# -------------------------------------------------------

# Directory where PID stamp files are stored, named xr-{service}.pid
my $piddir = '/var/run';

# 'ps' command that prints a process ID and the invoking command. The
# following is right for Linux, MacOSX (Darwin) and Solaris.
my $pscmd = '/bin/ps ax -o pid,command';
$pscmd = '/usr/bin/ps -ef "pid comm"' if (`uname` =~ /SunOS/);

# Use 'logger' to send output to syslog? 0 means no.
my $use_logger = 1;

# Directory where log files are stored, named xr-{service}.log. Used
# when logger isn't available or wanted.
my $logdir = '/var/log';

# Max log file size in bytes (used by xrctl rotate). Used when logger isn't
# available or wanted.
my $maxlogsize = 100000;

# Nr. of historical log files to keep (used by xrctl rotate). Used when logger
# isn't available or wanted.
my $loghistory = 10;

# Paths where executables are searched.
my @bindirs = qw(/bin /sbin /usr/bin /usr/sbin /usr/local/bin /usr/local/sbin
		 /opt/local/bin /opt/local/sbin);

# Services to balance. All non-default flags for XR must be specified. The
# primary key into hash %services is a self-chosen name. xrctl will supply
# --prefix-timestamp when logging to a bare file (when logger isn't used).
# Also xrctl will supply --pidfile for run control purposes.
# The strings like --server are passed plaintext to the XR invocation. The
# only exception is --host-match - in that case, there's a more complex
# configuration that also states all back ends.
# See the examples below to help you model your favorite dispatcher.
my %services =
  (

   # Web servers balancing to 3 back ends at 10.0.0.1 thru 3. The
   # balancer will use HTTP mode and add X-Forwarded-For headers.
   'webone' =>
   { '--server' 		=> [ qw(http:0:80) ],
     '--backend' 		=> [ qw(10.0.0.1:80 10.0.0.2:80 10.0.0.3:80) ],
     '--verbose'		=> undef,
     '--add-x-forwarded-for'	=> undef,
   },
   
   # Web servers balancing to 3 back ends at 10.1.1.1 thru 3. The
   # balancer will use HTTP mode, add X-Forwarded-For headers, and make the
   # HTTP sessions sticky to their back ends. NOTE - this server starts on
   # port 81 for demo purposes (or it would interfere with webone above).
   'webtwo' =>
   { '--server' 		=> [ qw(http:0:81) ],
     '--backend' 		=> [ qw(10.1.1.1:80 10.1.1.2:80 10.1.1.3:80) ],
     '--verbose'		=> undef,
     '--add-x-forwarded-for'	=> undef,
     '--sticky-http'		=> undef,
   },

   # An Access Control List (ACL) example, again using web balancing.
   # Allowed clients are 127.0.0.1 (localhost) and 192.168.*.*, except
   # for 192.168.1.250. Also, flag -C / --close-sockets-fast is added to
   # avoid TIME_WAIT states under heavy load.
   'webthree' =>
   { '--server' 		=> [ qw(http:0:82) ],
     '--backend' 		=> [ qw(10.1.1.1:80 10.1.1.2:80 10.1.1.3:80) ],
     '--verbose'		=> undef,
     '--add-x-forwarded-for'	=> undef,
     '--allow-from'		=> [ qw(127.0.0.1 192.168.255.255) ],
     '--deny-from'		=> [ qw(192.168.1.250) ],
     '--close-sockets-fast'	=> undef,
   },

   # Multi-hosting two websites. Site "www.onesite.org" has two back ends
   # in the 10.1.1 series, "www.othersite.org" has two back ends in the
   # 10.1.9 series. Note that the server mode must be http to use this.
   'webfour' =>
   { '--server' 		=> [ qw(http:0:82) ],
     '--host-match'		=> { 'onesite'   => [ qw(10.1.1.1:80
							 10.1.1.2:80) ],
				     'othersite' => [ qw(10.1.9.1:80
							 10.1.9.2:80) ],
				   },
     '--verbose'		=> undef,
     # Other options as --allow-from etc. can also be added here
   },

   # An SSH session balancer on port 2222. We set the client time out
   # to 2 hours. Requests are balanced to server1, server2 and server3,
   # all to port 22.
   'ssh' =>
   { '--server'			=> [ qw(tcp:0:2222) ],
     '--backend'		=> [ qw(server1:22 server2:22 server3:22) ],
     '--verbose'		=> undef,
     '--client-timeout'		=> [ qw(7200) ],
   },

   # Windows Remote Desktop Protocol (RDP) balancing. Windows supports
   # only one concurrent client, and we don't want new connections to 'steal'
   # existing sessions - so we set the max connections of each back end to 1.
   'rdp' => 
   { '--server'			=> [ qw(tcp:0:3389) ],
     '--backend'		=> [ qw(win1:3389:1 win2:3389:1 win33:3389:1) ],
     '--verbose'		=> undef,
     '--client-timeout'		=> [ qw(7200) ],
   },

   # A HTTP forwarder for travelling. Depending on the site where I plug
   # in, this reaches some proxy - or localhost:3128, which is a local squid.
   # I configure my browser to use localhost:8080 as proxy, and don't have
   # to reconfigure browsers anymore. Note the dispatch method which is
   # first-available, the first downstream proxy that works is OK for me.
   # Note also that the server type is TCP, I don't need HTTP goodies.
   # Also the server listens to 127.0.0.1 - only for localhost usage.
   'proxy' => 
   { '--server'			=> [ qw(tcp:127.0.0.1:8080) ],
     '--backend'		=> [ qw(10.120.114.2:8080 192.168.1.250:80
					localhost:3128) ],
     '--dispatch-mode'		=> [ qw(first-available) ],
     '--verbose'		=> undef,
   },

   # Simple tunnel to easily access an external proxy at 10.1.1.250. The
   # proxy requires authentication, user 'user', password 'secret', which
   # is base64-encoded: dXNlcjpzZWNyZXQ=
   # Next I can "export http_proxy localhost:8090" and use wget etc. without
   # typing the proxy credentials.
   'authproxy' =>
   { '--server'			=> [ qw(http:127.0.0.1:8090) ],
     '--backend' 		=> [ qw(10.1.1.250:80) ],
     '--add-server-header'	=> [ 'Proxy-Authorization: '.
				     'Basic dXNlcjpzZWNyZXQ=' ],
     '--verbose'		=> undef,
     '--debug'			=> undef,
   },
  );

# Main starts here, configuration ends.
# -------------------------------------

# Get the action
my $action = shift (@ARGV);

# Prepare service list unless given on the command line
if ($#ARGV == -1) {
    push (@ARGV, sort (keys (%services)));
} else {
    for my $s (@ARGV) {
	die ("xrctl: No such service $s\n") unless ($services{$s});
    }
}

# Verify the configuration
verifyconf (@ARGV);

# Take appropriate action
if ($action eq 'list') {
    list(@ARGV);
} elsif ($action eq 'status') {
    status(@ARGV);
} elsif ($action eq 'start') {
    start(@ARGV);
} elsif ($action eq 'stop') {
    stop(@ARGV);
} elsif ($action eq 'force') {
    force(@ARGV);
} elsif ($action eq 'rotate') {
    rotate(@ARGV);
} elsif ($action eq 'restart') {
    restart(@ARGV);    
} else {
    usage();
}

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

Usage: xrctl list [SERVICE]    - show configuration of a service, or of all
       xrctl start [SERVICE]   - start a service, or all configured services
       xrctl stop [SERVICE]    - stop a service, or all configured services
       xrctl force [SERVICE]   - start a service (or all) if not running
       xrctl restart [SERVICE] - stop and start a service, or all
       xrctl status [SERVICE]  - show running status of a service, or of all
       xrctl rotate [SERVICE]  - rotate logs of a service or of all

ENDUSAGE
}

# List services and command lines
# -------------------------------
sub list {
    print ("Configured services: ",
	   join (', ', sort (keys (%services))),
	   "\n");
    for my $s (@_) {
	print ("Service $s:\n",
	       "  Process   : ", "xr-$s\n",
	       "  PID file  : ", pidfile($s), "\n",
	       "  Log file  : ", logfile($s), "\n",
	       "  XR command:");
	my @parts = xrcommand($s);
	for (my $i = 0; $i <= $#parts; $i++) {
	    next if ($i == 1);
	    my $p = $parts[$i];
	    $p = "'$p'" if ($p =~ /\s/);
	    print (" $p");
	}
	print ("\n");
    }
}

# Show the status of the commands
# -------------------------------
sub status {
    for my $s (@_) {
	die ("xrctl: No such service '$s'\n") unless ($services{$s});
	print ("Service $s: ", getstatus($s), "\n");
    }
}

# Start service(s)
# ----------------
sub start {
    for my $s (@_) {
	print ("Service $s: ");
	my $status = getstatus($s);
	if ($status !~ /^not/) {
	    print ("already $status\n");
	} else {
	    rundaemon ($s, xrcommand($s));
	    print ("started\n");
	}
    }
}

# Stop service(s)
# ---------------
sub stop {
    for my $s (@_) {
	print ("Service $s: ");
	my $status = getstatus($s);
	if ($status =~ /^not/) {
	    print ($status, "\n");
	} else {
	    my $pid = servicebypidfile($s);
	    $pid = servicebypslist($s) unless ($pid);
	    die ("Failed to get PID\n") unless ($pid);
	    kill (15, $pid);
	    print ("stopping\n");
	}
    }
}

# Restart service(s)
# ------------------
sub restart {
    for my $s (@_) {
	print ("Service $s: ");
	my $status = getstatus($s);
	if ($status =~ /^not/) {
	    print ($status, "\n");
	} else {
	    my $pid = servicebypidfile($s);
	    $pid = servicebypslist($s) unless ($pid);
	    die ("Failed to get PID\n") unless ($pid);
	    kill (15, $pid);
	    rundaemon ($s, xrcommand($s));
	    print ("restarted\n");
	}
    }
}

# Force service(s) up
# -------------------
sub force {
    for my $s (@_) {
	print ("Service $s: ");
	my $status = getstatus($s);
	if ($status =~ /^not/) { 
	    rundaemon ($s, xrcommand($s));
	    print ("started\n");
	} else {
	    print ($status, "\n");
	}
    }
}

# Rotate logs
# -----------
sub rotate {
    if ($use_logger and findbin('logger')) {
	print ("Rotating disabled, logging via logger/syslog\n");
	return;
    }
    for my $s (@_) {
	print ("Service $s: ");
	my $f = logfile($s);
	if (! -f $f) {
	    print ("no logfile $f\n");
	} elsif ((stat($f))[7] < $maxlogsize) {
	    print ("no rotation necessary\n");
	} else {
	    unlink ("$f.$loghistory", "$f.$loghistory.bz2",
		    "$f.$loghistory.gz");
	    for (my $i = $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 = findbin("bzip2") or
		$zipper = findbin("gzip")) {
		system ("$zipper $f.0");
		print (", zipped");
	    }
	    print ("\n");
	    restart($s);
	}
    }
}

# Verify a configuration
# ----------------------
sub verifyconf {
    for my $s (@_) {
	my @p = xrcommand($s);
	my $cmd = "$p[0] -n";
	for my $i (2..$#p) {
	    $cmd .= " '$p[$i]'";
	}
	if (system ($cmd)) {
	    die ("xrctl: Configuration of service '$s' probably bad\n",
		 "Testing command was:\n",
		 "  $cmd\n");
	}
    }
}

# Get the status of one balancer service
# --------------------------------------
sub getstatus($) {
    my $s = shift;
    die ("xrctl: No such service '$s'\n") unless ($services{$s});
    my $fpid = servicebypidfile($s);
    my $ppid = servicebypslist($s);

    # print ("getstatus: fpid=$fpid, ppid=$ppid\n");
    
    if (! $fpid and ! $ppid) {
	return ("not running");
    } elsif ($fpid == $ppid) {
	return ("running");
    } elsif ($fpid and ! $ppid) {
	return ("not running (stale pidfile found)");
    } elsif (! $fpid and $ppid) {
	return ("running (but no pidfile found)");
    } else {
	return ("running (stale pidfile found)");
    }
}

# Return a command to start XR
# ----------------------------
sub xrcommand ($) {
    my $s = shift;
    my $xr = findbin('xr') or die ("xrctl: Failed to find xr along @bindirs\n");
    my %opts = %{ $services{$s} };
    my @ret = ($xr, "xr-$s", "--pidfile", pidfile($s));
    push (@ret, "--prefix-timestamp") if (! $use_logger or
					  ! findbin('logger'));
    for my $o (sort (keys (%opts))) {
	if ($o eq '--host-match') {
	    my %def = %{ $opts{$o} };
	    for my $host (sort (keys (%def))) {
		push (@ret, '--host-match', $host);
		for my $b(@{ $def{$host} }) {
		    push (@ret, '--backend', $b);
		}
	    }
	} elsif (! $opts{$o}) {
	    push (@ret, $o);
	} else {
	    my @args = @{ $opts{$o} };
	    if ($#args == -1) {
		push (@ret, $o);
	    } else {
		for my $arg (@args) {
		    push (@ret, $o);
		    push (@ret, $arg);
		}
	    }
	}
    }
    return (@ret);
}

# Return the PID file of a given service
# --------------------------------------
sub pidfile ($) {
    my $s = shift;
    return ("$piddir/xr-$s.pid");
}

# Examine the contents of a PID file
# ----------------------------------
sub servicebypidfile($) {
    my $s = shift;
    my $p = pidfile($s);
    if (open (my $f, $p)) {
	my $pid = <$f>;
	chomp ($pid);
	return ($pid);
    } else {
	return (undef);
    }
}

# Get the PID of a service using the PS list
# -------------------------------------------
sub servicebypslist($) {
    my $s = shift;
    open (my $if, "$pscmd |") or die ("xrctl: Cannot start '$pscmd': $!\n");
    while (my $line = <$if>) {
	chomp ($line);
	my $p = sprintf ("%d", $line);
	next unless ($p);
	my $c = $line;
	$c =~ s/^[\d\s]*//;
	# print ("LF [$s], p=[$p], c=[$c]\n");
	return ($p) if ($c =~ /^[^\s]*xr-$s/);
    }
    return (undef);
}

# Return the log file of a given service
# --------------------------------------
sub logfile($) {
    my $s = shift;
    return ('logger') if ($use_logger and findbin('logger'));
    return ("$logdir/xr-$s.log");
}

# Find a binary along the path
# -----------------------------
sub findbin ($) {
    my $b = shift;
    for my $d (@bindirs) {
	return ("$d/$b") if (-x "$d/$b");
    }
    return (undef);
}

# Run a command as a daemon
# -------------------------
sub rundaemon {
    my $s = shift;
    my @args = @_;

    my $logger = findbin('logger');
    my $outfile = logfile($s);
    
    my $pid = fork();
    return if ($pid > 0);

    # Child branch
    close (STDIN);
    open (STDIN, "/dev/null")
      or die ("xrctl (daemon): Can not reopen stdin to /dev/null: $!\n");
    if ($use_logger and $logger) {
	open (STDOUT, "|$logger -t xr-$s")
	  or die ("xrctl (daemon): Cannot reopen stdout to logger: $!\n");
	open (STDERR, "|$logger -t xr-$s")
	  or die ("xrctl (daemon): Cannot reopen stdout to logger: $!\n");
    } else {
	open (STDOUT, ">>$outfile")
	  or die ("xrctl (deamon): Cannot reopen stdout to $outfile: $!\n");
	open (STDERR, ">>$outfile")
	  or die ("xrctl (deamon): Cannot reopen stderr to $outfile: $!\n");
    }
    my $truecmd = shift (@args);
    exec ({ $truecmd } @args);
    exit (1);
}
