eval '(exit $?0)' && eval 'PERLDB_OPTS="N f=26";export PERLDB_OPTS;PERL=`which perl5`; exec $PERL -wS $0 ${1+"$@"}'
    & eval 'setenv PERLDB_OPTS "N f=26"; setenv PERL `which perl5`; exec $PERL -wS $0 $argv:q'
    if 0;

### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
# 
# -------------------------------------------------------------------
#                                   X-BONE
#
#                          http://www.isi.edu/xbone
#                USC Information Sciences Institute (USC/ISI)
#                   Marina del Rey, California 90292, USA
#                          Copyright (c) 1998-2005
# 
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute.  The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
# 
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
#  $RCSfile: xb-gui-control.pl,v $
#
# $Revision: 1.10 $
#   $Author: pingali $
#     $Date: 2005/04/21 00:30:39 $
#    $State: Exp $
# ----------------------------------------------------------------------------
#
############################################################
#
# The first lines start PERL on any system where perl is in the path.
# This is a modified version of the "start perl" script
# provided in the PERL man pages, which starts perl
# on the remainder of the file regardless of whether it
# is run under sh, csh, or perl.
#
# This version is modified to dynamically locate the
# perl path, rather than requiring it be hard-coded.
#
# setenv PERLDB_OPTS "N f=26"
#
# Must be set before perl starts!
#
# N 	: Nonstop (noninteractive)
# f=26	: frame=26 = 16 + 8 + 2,
#		2 = entry and exit,
#		!4 = don't print args to functions
#		8= enabled overloaded stringify and tied FETCH
#		16= print return values from subroutines
#
# note - '-T' (TAINT) switch is not included, because 'which' often
# returns a version of perl that isn't secure. don't worry about it.
#
############################################################
# PERL CODE STARTS HERE
############################################################

# XBONE code to set libraries
BEGIN {
  use strict;
  use sigtrap;
  use FindBin;
  use Config; 
  delete $ENV{PATH};

  #my $version = $Config{'version'};
  #my $arch = $Config{'archname'};  
  my $ldir = $FindBin::RealBin;

  foreach my $p 
    ( 
     "/usr/local/www/xbone",
     "/usr/local/www/xbone/lib",
     "/usr/local/www/xbone/cpan",
    ){
      if(-d $p) { unshift   @INC, $p; }
  }

  # untaint the resulting include path so "use" works
  foreach my $i (@INC) { if($i =~ /(.*)/) { $i = $1;} }

};

##############################################################################
# END OF XBONE PREFIX CODE - PUT YOUR PERL CODE BELOW                        #
##############################################################################

use Tk; 
use Tk::Getopt;
use Tk::BrowseEntry;
use Tk::TableMatrix;
use Tk::Font; 
use Tk::LabFrame; 
use Tk::Labelframe; 
use IPC::Open3;

use Getopt::Long;
use Data::Dumper; 
use Cwd; 
use File::Basename;

# For xbgetaddrinfo 
use Socket;
use Socket6; 

use AppConfig;
use XB_Params; 

########################################################################
# Global Variables 
########################################################################

my $debug = 0; 
my $os = `uname -s`; 
chomp($os); 
my $hostname = `hostname`; 
chomp($hostname); 
my $font; 

my %options = (); 
my %defaults = (); 

my @conftypes = (["Config Files", '.conf', 'TEXT'],
	     ["All Files", "*"] );

########################################################################
# Misc Functions 
########################################################################

# Description: 
#       Show error message
# Arguments:
#	$top: parent window to popup a message
#	$msg: text message
# Returns:
#	
# Exceptions:
#       

sub showmsg ($$){

    my ($top, $msg) = @_; 
    
    $top->messageBox(-icon => 'error', 
		     -message => $msg,
		     -title => 'Error!', 
		     -type => 'Ok', 
		     );	
}; 

# Description: 
#       Write a printf style message to the xblogs, if $level matches the mask
# Arguments:
#	$level	level of the message, must be a string consisting of one out 
#		of err, debug 
#	@args   a printf-style array containing the message to be xblogged
# Returns:
#	1 on success
# Exceptions:
#       "xblog" on failure

sub xblog ($@) {
  my ($level, @args) = @_;

  unless($level =~ /^(err|warning|debug)$/) {
    warn "xblog: unknown xblog level \"$level\"" and die "xblog"; 
  }

  my $msg = ($#args ? sprintf shift @args, @args : $args[0]);
  chomp $msg; 

  if ($level eq "err"){
      print STDERR "$msg\n";
  } elsif ($level eq "warning") {
      print STDOUT "$msg\n";      
  } else {
      print STDOUT "$msg\n" if ($debug); 
  }

  return 1; 
}; 

# Description:
#     Return an array of addresses for a given hostname of specified type.
# Arguments:
#     $hostname hostname to lookup
#     $ipproto  ipv4 or ipv6
# Returns:
#     \@addrs   IP addresses of the given hostnames
# Exception:
#     "xbgetaddrinfo" on failure, nothing to cleanup by caller
sub xbgetaddr($$){
  my ($hostname, $ipproto) = @_;
  my $procname = "xbgetaddr";
  my @addrs = ();
  my %addrhash = (); 

  xblog "debug", "-> $procname $hostname, $ipproto";

  eval{
    unless($hostname =~ /\S+/){
      xblog "err", "   [$procname] empty hostname";
      die "hostname";
    }
    unless($ipproto =~ /(ipv6|ipv4)/){
      xblog "err", "   [$procname] unknown IP protocol: $ipproto";
      die "ipproto";
    }

    my ($family, $socktype, $proto, $saddr, $canonname);
    my @res = (); 

    if($ipproto eq 'ipv4'){
      @res = getaddrinfo($hostname, 
			 'daytime', # dummy service 
			 AF_INET);
      unless(scalar(@res) >=  5){
        xblog "err", "   [$procname] getaddrinfo failed to return ".
          "IPv4 addresses for $hostname";
        die "getaddrinfo";
      };
    } else {
      @res = getaddrinfo($hostname, 
			 'daytime', # dummy service 
			 AF_INET6);
      unless(scalar(@res) >= 5){
	  xblog "err", "   [$procname] getaddrinfo failed to return ".
	      "IPv6 addresses for $hostname";
	  die "getaddrinfo";
	};	
    } # give getaddrinfo call

    while (scalar(@res) >= 5) {
	$family = -1; # for safety 
	($family, $socktype, $proto, $saddr, $canonname, @res) 
	    = @res;
	my ($addr, $dummyport) = 
	    getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV);
	
	# for some reason there are duplicates. This is a way to 
	# avoid the duplicates. 
	$addrhash{$addr} = 1; 
    }

    @addrs = keys %addrhash; 
    unless(@addrs > 0){
      xblog "err", "   [$procname] host $hostname has no IP addresses!";
      die "noaddr";
    }
  }; #eval 
  
  xblog "debug", "<- $procname";
  return \@addrs unless $@;
  unless($@ =~ /(hostname|ipproto|getaddrinfo|noaddr)/){
    xblog "warning", "   ! $procname caught unknown exception: $@";
  }
  die "$procname";
};


# Description: 
#       Execute the system call and return the results 
# Arguments:
#	\@cmd : reference of a list
# Returns:
#	$msg: output of the command
# Exceptions:
#       Cant execute the command

sub execcmd($){

    my ($cmd) = @_; 
    my $cmdline = join (" ", @{$cmd});
    my $msg = ""; 
    my $status = 0; 

    eval { 

	die ("Script/Executable " . $cmd->[0] . " does not exist or" .
	     " does not have the right permissions") 
	if (! -e $cmd->[0] or ! -x $cmd->[0] ) ;

	my @prefix = (\*WTR, \*RDR, \*ERR);
	
	$cpid = open3(@prefix, @{$cmd}) or
	    xblog "err" => "Unable to execute command. $!: Route command failed" and die "cmd";
	
	if (defined $cpid) {
	    waitpid $cpid, 0 == $cpid or
		xblog "err" => "Operating system resource error. ".
		"No child $cpid" and die "wait"; 
	    $status = $? >> 8; 
	}
	
	# Read all the error messages...
	while (<RDR>) { $msg .= $_; } 
	while (<ERR>) { $msg .= $_; } 
	close(WTR); 
	close(RDR); 
	close(ERR); 
    }; 
    if ($@ or $status ) {
	$msg .= $@ if ($@);
	die "Command \"" . $cmdline .  "\" failed. ". 
	    "The following error was reported:\n\n $msg";
    } else { 
	return $msg; 
    }

}; 


###############################################################
# Save
###############################################################

# Description: 
#       Save all parameters specified through the GUI. If LDAP 
#       is enabled, choose accordingly. 
# Arguments:
#       $top: main window 
# Returns:
#
# Exceptions:
# 

sub save ($) {

    my ($top) = @_; 
    my (@keys, $key);
    my $file = ""; 
    my $dir = "."; 

    while (1) { 
	$file = 
	    $top->getSaveFile(-filetypes => \@conftypes,
			      -initialdir => "/usr/local/etc/xbone", 
			      -initialfile => "xbone-gui.conf", 
			      -title => "Save X-Bone GUI Configuration File");

	if ((not defined $file) or ($file eq "")) {	    	    
	    last; # dont show the message below
	    $top->messageBox(-icon => 'error', 
			     -message => "Configuration file undefined",
			     -title => 'Error!', 
			     -type => 'Ok', 
			     );	
	}

	$dir = dirname($file);
	if ((-e $file and ! -w $file) or 
	    (! -e $file and ! -w $dir)) {
	    $top->messageBox(-icon => 'error', 
			     -message => "Directory not writable",
			     -title => 'Error!', 
			     -type => 'Ok', 
			     );	
	    last;
	}; 
	
	last; 
    };
    
    return if (not defined $file or $file eq ""); 

    open(CONF,">$file"); 
	

    print CONF "#************ X-Bone GUI Configuration ***********\n";
    print CONF "#  * This file has been automatically generated  *\n";
    print CONF "#  * Consult the documentation for more          *\n";
    print CONF "#  * information on how to set the variable in   *\n";
    print CONF "#  * file configuration file.                    *\n";
    print CONF "#*************************************************\n";
    print CONF "\n";


    my @variables = ("hostname", "ipproto", "timeout");    
    my @v6variables = (	"ctl_addr6" );
    my @v4variables = (	"ctl_addr" );    
    my @certvariables = ( "ca_cert", "ca_path",
			  "node_cert", "node_key" );
    
    my @addressarray = (); 
    if ( $options{ipproto} eq "ipv4" ){
	@addressarray = @v4variables; 
    } elsif ( $options{ipproto} eq "ipv6" ){
	@addressarray = @v6variables; 
    } else {
	@addressarray = (@v4variables, @v6variables);	
    }

    #print Dumper(\%options); 
	
    # Write out the node config in a non-ldap fashion 
    foreach $key (@variables, @addressarray, @certvariables){
	if ((defined $options{$key}) and 
	    ($options{$key} ne "")) {
	    print CONF "$key = $options{$key}\n";
	}
    }
    
    print CONF "\n\n";

    close(CONF);

}

###############################################################
# Related
###############################################################


# Description: 
#       Show help for the different related softwares
# Arguments:
#       $top = window 
#       $what = help for what?
# Returns:
#
# Exceptions:
# 

sub help_btn_cb ($$$){
    my ($top,$what) = @_;       
    my $m = ""; 
    
    return if ($what !~ /(apache)/); 
    
    my $apachemsg = 
    "X-Bone requires Apache version 2.0.42 and above.\n\n" .

    "To configure Apache, add the following lines to " . 
    "/etc/rc.conf.local:\n" .
    "apache2_enable=\"YES\"\n".
    "apache2ssl_enable=\"YES\"\n\n".     

    "X-Bone specific Apache configuration is stored in ".
    "etc/xbone/apache/xbone-apache.conf and symbolically linked ".
    "from etc/apache2/Includes. \n\n".

    "bin/xb-apache-config is used to install/uninstall X-Bone, " . 
    "in the background. The installed X-Bone is available at ".
    "http://<hostname>/xbone. To run X-Bone GUI on non-standard ".
    "ports, edit the above mentioned the configuration file. By ".
    "default the X-Bone GUI will be available on port 443 (https).".
    "\n\n";
    
    $m = $apachemsg;
    
    $m .= "Unless specified all paths are relative to /usr/local";

    $top->messageBox(-icon => 'info', 
		     -message => $m, 
		     -title => 'Help', 
		     -type => 'Ok', 
		     );	 
}


# Description: 
#       Process the clicks on related software button. 
#       This is place where we go ahead and install/uninstall/
#       check related software. 
# Arguments:
#       $type: process what? (openldap/apache?) 
#       $op: how? (install/uninstall)
# Returns:
#
# Exceptions:
# 

sub related_btn_cb ($$$){
    my ($top,$type, $op) = @_;    
    my ($script) = (); 

    #print "related_btn_cb : $type $op \n"; 
    
    return if ($type !~ /^(apache)$/); 
    return if ($op !~ /^(install|uninstall)$/); 

    if ($type =~ /^(apache)$/) { 
       $script = "xb-apache-config"; 
    } else {
       $script = "xb-config"; 
    }

    my @cmd = ("/usr/local/bin/$script", $op); 

    eval {
	$msg = execcmd(\@cmd); 
    }; 
    if ($@) {
	showmsg($top, "Error! $@.");
    } else { 
	
	my $m = "Operation successful!";
	if ($msg) {
	    $m .= "\n\nAdditional information: " . $msg; 
	}

	$top->messageBox(-icon => 'question', 
			 -message => $m, 
			 -title => 'Status', 
			 -type => 'Ok', 
			 );	
	
    };  
    
}; 

# Description: 
#       Show the related software window 
# Arguments:
#       $main: Main window 
# Returns:
#
# Exceptions:
# 
sub related ($){
    
    my ($main) = @_; 
    my ($b, $l); 

    $top = $main->Toplevel; 
    $top->title("Related Software Management");

    $top -> minsize(qw(300 150));
    $top -> geometry('+0+0');    
    
    $l = $top->Label (-text=>'(Un)Install X-Bone Specific Components.');
    #$l->place(-x=>10, -y => 10);
    $l->pack(-pady => 5); 

    $f = $top->LabFrame(-label => "Apache");
    $f->place(-x => 0, -y => 20, -width => 300, -height => 80);
    
    $b = $f->Button(
    		      -text => 'Install', 
    		      -command => sub{&related_btn_cb($top, "apache", "install");}
    		      );
    $b->place(-x=>20, -y => 10);
    
    $b = $f->Button(
    		      -text => 'Uninstall', 
    		      -command => sub{&related_btn_cb($top, "apache", "uninstall");}
    		      );
    $b->place(-x=>100, -y => 10);

    $b = $f->Button(
		    -text => 'Help', 
		    -command => sub{&help_btn_cb($top, "apache");}
		    );
    $b->place(-x=>210, -y => 10);

    $b = $top->Button(
		      -text => 'Quit', 
		      -command => [$top => 'destroy']
		      );
    $b->place(-x=>110, -y => 110);
    

    my $wait_var = 1;
    $top->OnDestroy(sub { undef $wait_var });
    $top->waitVisibility unless $top->ismapped;
    $top->grab;
    $top->waitVariable(\$wait_var);
    
    
};


# Description: 
#       Show the base configuration window
# Arguments:
#	$top: parent window to popup a message
# Returns:
#	Updates the %options hash 
#       Blocks until ok is pressed on the popup window
# Exceptions:
#       
sub config ($) { 

    my ($top) = @_;
    my ($opt); 
    my ($v4addrs, $v6addrs) = (); 
    my @nonexist = (); 
    my ($v4noshow, $v6noshow) = (0, 0); 
    my @ipver = (); 

    my $hostname = $options{hostname}; 
    eval { 
	$v4addrs = xbgetaddr($hostname, 'ipv4'); 
	push @ipver, "ipv4"; 
    }; 
    if ($@) { 
	$v4addrs = \@nonexist; 
	$v4noshow = 1;
    }
    
    eval { 
	$v6addrs = xbgetaddr($hostname, 'ipv6'); 
	push @ipver, "ipv6"; 
    };
    if ($@) { 
	$v6addrs = \@nonexist;
	$v6noshow = 1; 
    }
    
    if ( $os =~ /(linux)/i) { $v6noshow = 1; } 
    if (! $v6noshow and ! $v4noshow ){ push @ipver, "both"; };
    
    my @opttable = (
		    'Addressing', 
		    
		    [
		     'ipproto', '=s', $options{ipproto}, 
		     label => 'IP Protocol:', 
		     longhelp => 'IPv4 address on which the Node Daemon will listen.', 
		     choices => \@ipver, 
                     var => \$options{ipproto}, 
		     strict => 1,
		     ],	

		    ['', '', 
		     '
Select the appropriate IP version(s) and address(es). The 
final addresses used will depend on chosen IP protocol.'
		     ], 

		    [
		     'ctl_addr', '=s', $v4addrs->[0],  
		     label => 'IPv4 Address:', 
		     longhelp => 'IPv4 address to be used as a source address',
		     choices => $v4addrs, 
		     nogui => $v4noshow, 
                     var => \$options{ctl_addr}, 
		    ], 
			 
                    [
		     'ctl_addr6', '=s',  $v6addrs->[0],  
                     label => 'IPv6 Address:', 
		     longhelp => 'IPv6 address to be used as a source address',
	     	     choices => $v6addrs, 
       		     nogui => $v6noshow, 
                     var => \$options{ctl_addr6}, 
                    ], 
		    
		    'Certificates', 

                    ['', '', "X-Bone Host/CA Certificates/Path"], 

                    ['ca_cert', "=s", $options{ca_cert}, 
		     label => "CA Certificate", 
		     subtype => 'file',
                     var => \$options{ca_cert}, 
		     ], 

                    ['ca_path', "=s", $options{ca_path}, 
		     label => "Certificate Path", 
		     subtype => 'dir', 
		     var => \$options{ca_path}, 
		     ],

                    ['node_cert', "=s", $options{node_cert}, 
		     label => "Host Certificate", 
		     subtype => 'file',
		     var => \$options{node_cert}, 
		     ],

                    ['node_key', "=s", $options{node_key}, 
		     label => "Host Key",
		     subtype => 'file',
		     var => \$options{node_key}, 
		     ],

		    'Miscellaneous', 

                    ['', '', "Connection Properties"], 
		    
                    ['timeout', "=i", $options{timeout}, 
		     label => "Timeout",
		     longhelp => 'Timeout for the connection to the backend',
		     var => \$options{timeout}, 
		     ],
		    

		    );

    $opt = new Tk::Getopt(-opttable => \@opttable,
			  -options => \%options,
			  );

    $opt->set_defaults;
    $opt->load_options;
    $opt->get_options;
    $opt->process_options;
    
    my @packopts = ( -fill => "both", 
		     -expand => 1
		     );

    $opt->option_editor($top, 
			#-toplevel => "Frame",
			"-wait" => 1, 
			"-delaypagecreate" => 1,
			"-buttons" => [qw/ok/], 
			#-pack => \@packopts, 
			);
    $opt->get_options;    

}; # config




###############################################################
# Main 
###############################################################


%options = ( 
	     ipproto => "both", 
	     hostname => $hostname, 
	     ca_cert => "/usr/local/etc/xbone/cert/CAcert.pem", 
	     ca_path => "/usr/local/etc/xbone/cert", 
	     node_cert => "/usr/local/etc/xbone/cert/node_cert.pem", 
	     node_key => "/usr/local/etc/xbone/cert/node_key.pem", 
	     timeout => "25", 
	     "ctl_addr" => "", 
	     "ctl_addr6" => "", 	     
	     );

sub main_btn_cb ($$){
    my ($top, $type) = @_;    
    my %funcmap = ( 
		    "save" => \&save,
		    "config" => \&config,
		    "related" => \&related, 
		    );

    $funcmap{$type}($top);
}; 


sub main {

    # create a window
    my $top = MainWindow->new;
    $top->title("X-Bone GUI Control Panel");

    
    $top -> minsize(qw(300 200));
    $top -> geometry('+0+0');    

    my $f = $top->LabFrame(-label => "Configure X-Bone GUI");
    $f->place(-x => 0, -y => 0, -width => 300, -height => 80);

    $b = $f->Button(
		      -text => 'Configure', 
  		      -command => sub{&main_btn_cb($top,"config");}
		      );
    $b->place(-x=>50, -y => 10);
    $b = $f->Button(
		      -text => 'Save', 
  		      -command => sub{&main_btn_cb($top,"save");}
		      );
    $b->place(-x=>160, -y => 10);


    $f = $top->LabFrame(-label => "Configure Related Software");
    $f->place(-x => 0, -y => 80, -width => 300, -height => 80);
    
    my $msg = "Automatic configuration of dependent services such as " .
	      "Apache requires saved X-Bone configuration in the standard " .
              "location\n/usr/local/etc/xbone/xbone-gui.conf.\nProceed?"; 


    $b = $f->Button(
    		      -text => 'Related Software', 
    		      -command => sub{
			  my $response = 
			      $top->messageBox(-icon => 'question', 
					       -message => $msg, 
					       -title => 'Warning!', 
					       -type => 'YesNo', 
					       );	
			  if ($response =~ /(yes)/i){ 
			      &main_btn_cb($top,"related");
			  }
		        }
    		      );
    $b->place(-x=>70, -y => 10);

    $b = $top->Button(
    		      -text => 'Quit', 
    		      -command => [$top => 'destroy']
    		      );
    $b->place(-x=>105, -y => 160);

}


###############################################################
# Main Loop
###############################################################

main; 
MainLoop;