#!/usr/bin/perl

# Do not make changes in this file.
# They will be overwritten in the next installation.
# For changes, see crossroads-mgr.in in the Crossroads source tree.

use strict;
use HTTP::Daemon;
use Getopt::Std;
use POSIX qw(:sys_wait_h setsid);
use MIME::Base64;

# The built in XSLT.
my $builtin_xslt = <<'END_XSLT';
<?xml version="1.0" encoding="UTF-8"?>
<xsl:stylesheet version="1.0"
 xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
<xsl:output method="html"/>

<xsl:template match="/">
 <html>
  <head>
   <title>Crossroads Status Overview</title>
   <script type="text/javascript">
     function setstate (target, index) {
       document.location = '/set/' + target + '/state/' + index;
     }
     function setaddress (target) {
       var hostname = document.getElementById (target + '/hostname').value;
       var port     = document.getElementById (target + '/port').value;
       document.location = '/set/' + target + '/server/' +
	   hostname + '/' + port;
     }
   </script>
   <style type="text/css">
     h1 {
       font-family: Verdana,Helvetica;
       font-size: 12pt;
       color: blue;
     }
     body {
       font-family: Verdana,Helvetica;
       font-size: 8pt;
     }
     td {
       font-family: Verdana,Helvetica;
       font-size: 10pt;
     }
     .service { background-color: #ffff33; }
     .backend { background-color: #ffff99; }
     .info { font-size: 8pt; }
     .footer { color: gray; }
   </style>
  </head>
  <body>
   <h1>Crossroads Status Overview</h1>
   <hr/>
   <form>
    <xsl:apply-templates/>
   </form>
   <hr/>
    <div class="footer">
      <i>
	Generated by Crossroads 1.80/233.
	Visit
	<a href="http://crossroads.e-tunity.com">
	  http://crossroads.e-tunity.com
	</a>
	for documentation and downloads. <br/>
      </i>
    </div>
  </body>
 </html>
</xsl:template>

<xsl:template match="/status">
 <table width="100%">
  <xsl:apply-templates/>
 </table>
</xsl:template>

<xsl:template match="/status/service">
 <tr>
  <td class="service" valign="top">
    <b> Service  <xsl:value-of select="@name"/> </b>
  </td>
  <td class="service" colspan="3">
    <table>
      <tr>
	<td class="service">Total connections:</td>
	<td class="service"><xsl:value-of select="connections"/></td>
      </tr>
      <xsl:if test="backends_available &gt; 0">
	<tr>
	  <td class="service">Available back ends:</td>
	  <td class="service"><xsl:value-of select="backends_available"/></td>
	</tr>
      </xsl:if>
      <xsl:if test="backends_unavailable &gt; 0">
	<tr>
	  <td class="service">Unvailable back ends:</td>
	  <td class="service"><xsl:value-of select="backends_unavailable"/></td>
	</tr>
      </xsl:if>
      <xsl:if test="backends_down &gt; 0">
	<tr>
	  <td class="service">Down back ends:</td>
	  <td class="service"><xsl:value-of select="backends_down"/></td>
	</tr>
      </xsl:if>
      <xsl:if test="backends_waking &gt; 0">
	<tr>
	  <td class="service">Waking back ends:</td>
	  <td class="service"><xsl:value-of select="backends_waking"/></td>
	</tr>
      </xsl:if>
      <tr>
	<td class="service">Listener process PID:</td>
	<td class="service"><xsl:value-of select="pid"/></td>
      </tr>
    </table>
  </td>
 </tr>
 <xsl:apply-templates/>
 <tr> </tr>
</xsl:template>

<xsl:template match="/status/service/backend">
 <tr>
  <td width="15%"> </td>
  <td class="backend" width="15%"> Back end </td>
  <td class="backend" width="15%"> <b> <xsl:value-of select="@name"/> </b> </td>
  <td class="backend">
    <select onchange="setstate('{../@name}/{@name}', this.selectedIndex);">
      <xsl:choose>
	<xsl:when test="availability/@id = 0">
	  <option value="available" selected="1">available</option>
	</xsl:when>
	<xsl:otherwise>
	  <option value="available">available</option>
	</xsl:otherwise>
      </xsl:choose>
      <xsl:choose>
	<xsl:when test="availability/@id = 1">
	  <option value="unavailable" selected="1">unavailable</option>
	</xsl:when>
	<xsl:otherwise>
	  <option value="unavailable">unavailable</option>
	</xsl:otherwise>
      </xsl:choose>
      <xsl:choose>
	<xsl:when test="availability/@id = 2">
	  <option value="down" selected="1">down</option>
	</xsl:when>
	<xsl:otherwise>
	  <option value="down">down</option>
	</xsl:otherwise>
      </xsl:choose>
      <xsl:choose>
	<xsl:when test="availability/@id = 3">
	  <option value="waking" selected="1">waking</option>
	</xsl:when>
	<xsl:otherwise>
	  <option value="waking">waking</option>
	</xsl:otherwise>
      </xsl:choose>
      <xsl:choose>
	<xsl:when test="availability/@id = 4">
	  <option value="intermediate" selected="1">intermediate</option>
	</xsl:when>
	<xsl:otherwise>
	  <option value="intermediate">intermediate</option>
	</xsl:otherwise>
      </xsl:choose>
      <xsl:choose>
	<xsl:when test="availability/@id = 5">
	  <option value="unknown" selected="1">unknown</option>
	</xsl:when>
	<xsl:otherwise>
	  <option value="unknown">unknown</option>
	</xsl:otherwise>
      </xsl:choose>
    </select>
  </td>
 </tr>
 <tr>
   <td class="info"/>
   <td class="info"/>
   <td class="info"> Address: </td>
   <td class="info">
     <input name="{../@name}/{@name}/hostname" type="text" class="info"
	    id="{../@name}/{@name}/hostname" value="{server}" maxlength="255"/>
     :
     <input name="{../@name}/{@name}/port" type="text" value="{port}"
	    id="{../@name}/{@name}/port" size="7" class="info"/>
     <input type="button" class="info" value="Set"
      onclick="setaddress('{../@name}/{@name}');"/>
   </td>
 </tr>
 <tr>
   <td class="info"/>
   <td class="info"/>
   <td class="info"> Connections: </td>
   <td class="info">
     Total <xsl:value-of select="connections"/>
     (<xsl:value-of select="failures"/> failures,
      <xsl:value-of select="clients"/> active)
   </td>
 </tr>
 <tr>
   <td class="info"/>
   <td class="info"/>
   <td class="info"> Usage: </td>
   <td class="info">
     Throughput
     <b><xsl:value-of select="throughput"/></b> in 
     <b><xsl:value-of select="duration"/></b>,
     <b><xsl:value-of select="lastaccess"/></b> ago
   </td>
 </tr>
 <xsl:apply-templates/>
</xsl:template>

<xsl:template match="*"/>

</xsl:stylesheet>
END_XSLT

# The version ID
my $VER = "1.80/233";

# Main starts here
my $prog;
$prog = Program->new();
my $daemon = Daemon->new ();
$daemon->start ($prog->port());			# doesn't return


# All program-related functions
{
    package Program;
    use strict;

    # Instantiate program handler. Parse the commandline.
    sub new {
	my $proto = shift;
	my $self = {};
	my %opts;

	# Get the commandline options.
	::getopts ('vfl:x:X:b:B:a:', \%opts) or usage();

	# Act according to argument; 'start' is handled here.
	if ($ARGV[0] eq 'stop') {
	    stop();
	    exit (0);
	} elsif ($ARGV[0] eq 'status' and $#ARGV == 0) {
	    status();
	    exit  (0);
	} elsif ($ARGV[0] ne 'start' or $#ARGV != 1) {
	    usage();
	    exit (0);
	}
	
	# ARGV[0] was 'start' and there is one more argument $ARGV[1], port
	$self->{port} = sprintf ("%d", $ARGV[1]);
	$self->{verbose} = $opts{v} ? 1 : 0;
	$self->{foreground} = $opts{f} ? 1 : 0;
	$self->{isdaemon} = 0;
	$self->{xsltfile} = $opts{X} if ($opts{X});
	$self->{address} = $opts{a} if ($opts{a});
	if ($opts{b}) {
	    if ($opts{b} eq 'PROMPT') {
	        print ("Enter username:password for status authentication: ")
		  if (-t STDIN);
		$opts{b} = <STDIN>;
		chomp ($opts{b});
	    }
	    $self->{statuscred} = ::encode_base64($opts{b});
	    chomp ($self->{statuscred});
	}
	if ($opts{B}) {
	    if ($opts{B} eq 'PROMPT') {
	        print ("Enter username:password for updating authentication: ")
		  if (-t STDIN);
		$opts{B} = <STDIN>;
		chomp ($opts{B});
	    }
	    $self->{setcred} = ::encode_base64($opts{B});
	    chomp ($self->{setcred});
	}
	if ($opts{x}) {
	    $self->{call} = $opts{x};
	} else {
	    $self->{call} = '';
	    for my $p (split /:/, $ENV{PATH}) {
		if (-x "$p/crossroads") {
		    $self->{call} = "$p/crossroads";
		    last;
		}
	    }
	    die ("Failed to locate crossroads program on PATH\n")
	      if ($self->{call} eq '');
	}
	die ("Argument $ARGV[0] is not a port number\n") unless ($self->{port});
	$self->{logfile} = "/tmp/crossroads-mgr.log";
	$self->{logfile} = $opts{l} if ($opts{l});
	
	bless ($self, $proto);
	return ($self);
    }

    # Return the necessary un/pw for status viewing, in Base64 encoding
    sub authstatus {
	return ($_[0]->{statuscred});
    }

    # Return the necessary un/pw for status setting, in Base64 encoding
    sub authset {
	return ($_[0]->{setcred});
    }

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

This is crossroads-mgr V$VER, a web interface for Crossroads.
Usage:  crossroads-mgr [flags] start PORT     (starts on tcp port)
   or:  crossroads-msg stop		      (stops the manager)
   or:  crossroads-msg status		      (shows if it's running)
   
Controls a mini-webserver to monitor Crossroads.
Supported flags during 'start' are:
  -a ADDR  States the binding address for the monitor. Default is to listen
     	   to all addresses.
  -b UN:PW Viewing the Crossroads status will be protected using basic
           authentication, UN is the username, PW is the password.
	   Use PROMPT to be prompted for the username/password.
  -B UN:PW Modifying back end states will be protected using authentication,
           Use PROMPT to be prompted for the username/password.
  -f       crossroads-mgr stays in the foreground instead of daemonizing
           (for debugging).
  -l FILE  States the log file of the daemon, default is
           /tmp/crossroads-mgr.log.
  -v       Verbosity is increased, either to the log file or to stdout
  	   (in -f mode).
  -x CMD   States how crossroads should be invoked, default is 'crossroads'.
           Set to e.g. '/opt/xr/bin/crossroads -c /opt/xr/conf/xr.conf' if
           your Crossroads is in an atypical location and if we should not use
           configuration /etc/crossroads.conf.
  -X XSLT  Serves XSLT file, instead of built-in xslt.

ENDUSAGE
    }

    # Stop the daemon. NOTE: Class-less, called from the constructor.
    sub stop {
	my @pids = pids()
	  or die ("crossroads-mgr is not running\n");
	kill (2, @pids);
    }

    # Report on the status. NOTE: Class-less, called from the constructor.
    sub status {
	my @pids;
	if (@pids = pids()) {
	    print ("crossroads-mgr is running (pids @pids)\n");
	} else {
	    print ("crossroads-mgr is NOT running\n");
	}
    }

    # Return the PID's where the manager is running. NOTE: Class-less.
    sub pids {
	my %ps = (Darwin => 'ps ax',
		  linux  => 'ps ax',
		  Linux  => 'ps ax',
		  SunOS  => 'ps -eo \'pid args\'');
	my $uname = `uname`;
	chomp ($uname);
	die ("Failed to get uname of this system\n") if ($uname eq '');
	die ("No 'ps' command configured for uname '$uname'\n")
	  unless ($ps{$uname});
	open (my $if, "$ps{$uname} |")
	  or die ("Failed to start '$ps{$uname}'\n");
	my @ret;
	while (my $line = <$if>) {
	    next unless ($line =~ /perl/ and $line =~ /crossroads-mgr/);
	    my $pid = sprintf ("%d", $line);
	    next if ($pid == $$);
	    push (@ret, $pid);
	}
	return (@ret);
    }

    # Get or set the listening port.
    sub port {
	$_[0]->{port} = $_[1] if ($_[1]);
	return ($_[0]->{port});
    }

    # Get or set the listening address.
    sub address {
	$_[0]->{address} = $_[1] if ($_[1]);
	return ($_[0]->{address});
    }

    # Issue an error
    sub error {
	my $self = shift;
	if (! $self->{isdaemon}) {
	    die (@_, "\n");
	} else {
	    $self->sendlog ('ERROR', @_);
	    die (@_);
	}
    }

    # Return a Crossroads command
    sub call {
	my $self = shift;
	my $ret = $self->{call};
	for my $a (@_) {
	    $ret .= " $a";
	}
	$ret .= " 2>&1";
	$self->msg ("External call: [$ret]");
	return ($ret);
    }

    # Log a verbose message.
    sub msg {
	my $self = shift;
	return unless ($self->{verbose});
	if (! $self->{isdaemon}) {
	    print (@_, "\n");
	} else {
	    $self->sendlog ('DEBUG', @_);
	}
    }

    # Log a line
    sub sendlog {
	my $self = shift;
	my $type = shift;
	open (my $of, '>>' . $self->{logfile}) or return;
	print $of (scalar (localtime()), ' ', $type, ' ', @_, "\n");
    }

    # Get/set verbosity
    sub verbose {
	$_[0]->{verbose} = $_[1] if ($_[1]);
	return ($_[0]->{verbose});
    }

    # Get/set foreground mode
    sub foreground {
	$_[0]->{foreground} = $_[1] if ($_[1]);
	return ($_[0]->{foreground});
    }

    # Daemonize
    sub daemonize {
	my $self = shift;
	return if ($self->{foreground});
	if (my $pid = fork()) {
	    $self->msg ("Daemon is running as pid $pid");
	    sleep (2);
	    exit (0);
	} 
	$self->msg ("Daemonizing.");
	$self->{isdaemon} = 1;
	open (STDIN, "/dev/null")
	  or $self->error ("Cannot read /dev/null: $!");
	open (STDOUT, ">/dev/null")
	  or $self->error ("Cannot write /dev/null: $!");
	open (STDERR, ">&STDOUT")
	  or $self->error ("Cannot dup stdout: $!");
    }

    # The XSLT stylesheet
    sub xslt {
	my $self = shift;
	if (! $self->{xsltfile}) {
	    $self->msg ("Returning built-in XSLT");
	    return ($builtin_xslt);
	} else {
	    $self->msg ("Returning contents of ", $self->{xsltfile},
			" as XSLT");
	    open (my $if, $self->{xsltfile})
	      or die ("Cannot read ", $self->{xsltfile}, ": $!");
	    my $ret = '';
	    while (my $line = <$if>) {
		$ret .= $line;
	    }
	    return ($ret);
	}
    }
}

# Daemon-related stuff
{
    package Daemon;
    use strict;

    # Instantiate a daemon and start serving.
    sub new {
	my $proto = shift;
	my $self = {};
	$self->{request} = '';
	$self->{conn} = '';
	bless ($self, $proto);
	$prog->msg ("HTTP daemon instantiated.");
	return ($self);
    }

    sub start {
	my ($self, $port) = @_;
	$prog->msg ("Starting HTTP daemon on port $port");
	my $daemon = HTTP::Daemon->new (LocalPort => $port,
					LocalAddr => $prog->address(),
					ReuseAddr => 1)
	  or $prog->error ("Failed to start HTTP daemon. ",
			   "Maybe the address is in use?");
	$SIG{CHLD} = \&reaper;
	$prog->daemonize();
	$prog->msg ("Open for business");
	while (1) {
	    my ($conn, $peer) = $daemon->accept() or next;
	    $prog->msg ("Accepted new connection, spawning handler");
	    next if (my $pid = fork());
	    $prog->msg ("Handler spawned as pid $$");
	    my $req = Request->new();
	    eval { $req->serve ($conn); };
	    $conn->send_error (500, $@) if ($@);
	    exit (0);
	}
    }

    # Reaper of stopped child processes. NOTE: Class-less!
    sub reaper {
	my $child;
	while (($child = waitpid (-1, 'WNOHANG')) > 0){
	    $prog->msg ("Child process $child stopped with status $?");
	}
	$SIG{CHLD} = \&reaper;
    }
}

# Request related stuff
{
    package Request;
    use strict;

    sub new {
	my $proto = shift;
	my $self = {};
	bless ($self, $proto);
	return ($self);
    }

    # Serve a request.
    sub serve {
	my ($self, $conn) = @_;

	# Receive the request.
	$self->receive ($conn);
    }

    # Check authentication.
    sub checkauth {
	my ($self, $required, $desc) = @_;
	return (1) if ($required eq '');
	my $h = $self->{request}->header ('Authorization')
	  or return ($self->prompt_auth($desc));
	$h =~ s/^\s*Basic\s*//i;
	if ($h eq $required) {
	    $prog->msg ("Required authentication '$required' matched");
	    return (1);
	}
	$prog->msg ("Required authentication '$required' does not ",
		    "match passed '$h'");
	return ($self->prompt_auth($desc));
    }

    # Prompt for authentication
    sub prompt_auth {
	my ($self, $desc) = @_;
	$prog->msg ("Prompting for authentication ($desc)");
	my $r = HTTP::Response->new (401, 'Authentication Required');
	$r->header ('WWW-Authenticate' =>
		    "Basic realm=\"Crossroads Load Balancer: $desc\"");
	$self->{conn}->send_response ($r);
	return (undef);
    }

    # Receive client's request.
    sub receive {
	my ($self, $conn) = @_;
	$self->{conn} = $conn;
	$self->{request} = $conn->get_request()
	  or die ("Failed to receive request");
	die ("Bad request, only GET supported")
	  if ($self->{request}->method() ne 'GET');
	my $uri = $self->{request}->uri();
	$prog->msg ("Requested URI: ", $uri);

	# Take action depending on the URI.
	if ($uri eq '/') {
	    $self->act_status ();
	} elsif ($uri eq '/xslt') {
	    $self->act_xslt ();
	} elsif ($uri =~ m{^/set/}) {
	    $self->act_set($uri);
	} else {
	    die ("No action on URI ", $uri, "\n");
	}
    }

    # Status setter
    sub act_set {
	my ($self, $uri) = @_;

	# The uri is /set/{service}/{backend}/state/{numericalstate} or
	# /set/{service}/{backend}/server/{hostname}/{port}
	# Get the variables, and run crossroads tell.
	$self->checkauth ($prog->authset(), "Status Modification")
	  or return;
	my (undef, undef, $service, $backend, $action) = split (/\//, $uri);
	my ($nr, $hostname, $port, $if);
	if ($action eq 'state') {
	    (undef, undef, undef, undef, undef, $nr) = split (/\//, $uri);
	    $prog->msg ("Setting service $service, backend $backend ",
			"to state $nr");
	    open ($if, $prog->call ("tell $service $backend state $nr") . '|')
	      or die ("Cannot start crossroads\n");
	} elsif ($action eq 'server') {
	    (undef, undef, undef, undef, undef, $hostname, $port) =
	      split (/\//, $uri);
	    $prog->msg ("Setting service $service, backend $backend ",
			"to address $hostname:$port");
	    open ($if, $prog->call ("tell $service $backend " .
				    "server $hostname:$port") . '|')
	      or die ("Cannot start crossroads\n");
	} else {
	    die ("Action '$action' not supported in 'set'\n");
	}
	
	my $resp = '';
	while (<$if>) {
	    $resp .= $_;
	}
	close ($if);
	die ("Failed to modify runtime environment: $resp\n")
	  if ($resp ne '');

	# Runtime environment is updated. Redirect to the overview page.
	$prog->msg ("Redirecting to status overview page");
	my $r = HTTP::Response->new (302, 'Moved Temporarily');
	$r->header ('Location' => '/');
	$r->header ('Cache-Control' => 'no-cache');
	$self->{conn}->send_response ($r);
    }

    # Status overview actor
    sub act_status {
	my $self = shift;

	$prog->msg ("Serving status overview page");
	$self->checkauth ($prog->authstatus(), "Status Retrieval")
	  or return;
	open (my $if, $prog->call ('-x -Xxslt status') . '|')
	  or die ("Failed to run status retrieval");
	my $buf = '';
	while (my $line = <$if>) {
	    $buf .= $line;
	}

	my $r = HTTP::Response->new (200, 'OK');
	$r->header ('Content-Type' => 'text/xml');
	$r->header ('Cache-Control' => 'no-cache');
	$r->content ($buf);
	$self->{conn}->send_response ($r);
    }

    # XSLT server
    sub act_xslt {
	my $self = shift;

	$prog->msg ("Serving XSLT");
	my $r = HTTP::Response->new (200, 'OK');
	$r->header ('Content-Type' => 'text/xml');
	$r->header ('Cache-Control' => 'no-cache');
	$r->content ($prog->xslt());
	$self->{conn}->send_response ($r);
    }
}
