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-node-control.pl,v $
#
# $Revision: 1.22 $
# $Author: pingali $
# $Date: 2005/04/21 00:58:26 $
# $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/xbone",
"/usr/local/xbone/programs",
"$ldir/../programs",
"$ldir/../programs/modules",
){
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 $font;
my %options = ();
my %defaults = ();
my @conftypes = (["Config Files", '.conf', 'TEXT'],
["All Files", "*"] );
my @ldaptypes = (["LDIF Files", '.ldif', 'TEXT'],
["All Files", "*"] );
########################################################################
# Read Configuration
########################################################################
# Description:
# The options structure has been copied from the xb-node-daemon.
# That is the place to correct if any.
# Arguments:
#
# Returns:
#
# Exceptions:
#
%options = (
"auto" => $XB_Params::auto,
# basic configuration options
"conf" => $XB_Params::conf,
"workdir" => $XB_Params::workdir,
"state_file" => $XB_Params::state_file,
"pidfile" => $XB_Params::pidfile,
"daemon_type" => $XB_Params::daemon_type,
"background" => 0 ,
# node IP config options
"hostname" => `hostname`,
"ctl_addr" => $XB_Params::ctl_addr,
"ctl_addr6" => $XB_Params::ctl_addr6,
"app_addr" => $XB_Params::app_addr,
"app_addr6" => $XB_Params::app_addr6,
# XBone network parameters
"ipproto" => $XB_Params::ipproto,
"xbone_mcast_addr" => $XB_Params::xbone_mcast_addr,
"xbone_mcast_addrv6" => $XB_Params::xbone_mcast_addrv6,
"xbone_api_port" => $XB_Params::xbone_api_port,
"xbone_ctl_port" => $XB_Params::xbone_ctl_port,
# logging options
"log_dest" => $XB_Params::log_dest,
"log_mask" => $XB_Params::log_mask,
"log_file" => $XB_Params::log_file,
# X.509 certificate & key info
"node_cert" => $XB_Params::node_cert,
"node_key" => $XB_Params::node_key,
"ca_cert" => $XB_Params::ca_cert,
"ca_path" => $XB_Params::ca_path,
# ACLs: for overlay manager & users
"ovl_manager" => \@XB_Params::ovl_manager,
"user_acl" => \%XB_Params::user_acl,
# features & capabilities
# - os [should only set these for buddy host; i.e., Cisco]
#"os" => $XB_Params::os,
"os" => $os,
"os_version" => $XB_Params::os_version,
"kern_version" => $XB_Params::kern_version,
"node_arch" => $XB_Params::node_arch,
# - routing (static vs. dynamic)
"routing" => $XB_Params::routing,
# - ipsec
"IPsec" => $XB_Params::IPsec,
# - qos
"qos" => $XB_Params::qos,
# - [optional] address server options
"addrserv" => $XB_Params::addrserv,
"netv4" => $XB_Params::netv4,
"netv6" => $XB_Params::netv6,
"addr_server" => $XB_Params::addr_server,
# legacy options
"address_type" => $XB_Params::address_type,
"control_protocol" => $XB_Params::control_protocol,
"linkv4" => $XB_Params::linkv4,
"linkv6" => $XB_Params::linkv6,
# - [optional] DDNS (Dynamic DNS update) server/zone/key info
"xbone_net" => $XB_Params::XBONE_NET,
"dns" => $XB_Params::dns,
"name_server" => $XB_Params::name_server,
"forward_zone" => $XB_Params::forward_zone,
"reverse_zone" => $XB_Params::reverse_zone,
"reverse_zone6" => $XB_Params::reverse_zone6,
"dns_key_file" => $XB_Params::dns_key_file,
# - [optional] Dynamic routing options
"zebra_dir" => $XB_Params::zebra_dir,
# - [optional] Force router options
"force-router" => 0,
# - [optional] Cisco platform options
"cisco_buddy_username" => $XB_Params::CISCO_BUDDY_USERNAME,
"cisco_buddy_password" => $XB_Params::CISCO_BUDDY_PASSWORD,
"cisco_buddy_enable_password"=> $XB_Params::CISCO_BUDDY_ENABLE_PASSWORD,
# - [optional] register attributes
"register" => \%XB_Params::register,
# - [optional] Ldap options
"ldap" => \%XB_Params::ldap,
);
my @opts_spec = (
"auto=s", # automatic or not - default on
# basic configuration options
"conf|c=s", # config file
"workdir|w=s", # working dir
"state_file|s=s", # state file
"pidfile|pid=s", # state file
"daemon_type|t=s", # daemon type
"background|bg", # run in the background
# node IP config options
"hostname|h=s", # hostname
"ctl_addr|caddr=s", # addr for control connection IPv4
"ctl_addr6|caddr6=s", # addr for control connection IPv6
"app_addr|aaddr=s", # addr for app/data connection IPv4
"app_addr6|aaddr6=s", # addr for app/data connection IPv6
# XBone network parameters
"ipproto|ip=s",
"xbone_mcast_addr|mcast=s",
"xbone_mcast_addrv6|mcastv6=s",
"xbone_ctl_port|ctl=i",
"xbone_api_port|api=i",
# logging options
"log_dest|d=i",
"log_mask|m=s",
"log_file|l=s",
# X.509 certificate & key info
"node_cert|cert=s",
"node_key|key=s",
"ca_cert|ca=s",
"ca_path|cp=s",
# ACLs: for overlay manager & users
"ovl_manager|om=s@",
"user_acl|acl=s%",
# node features & capabilities
# - os [should only set these for buddy host; i.e., Cisco]
"os=s",
"os_version|over=s",
"kern_version|kver=s",
"node_arch|arch=s",
# - routing/IPsec/QoS
"routing|rt=s",
"IPsec|sec=s",
"qos|q=s",
# address server options [optional]
"addrserv|a", # address server / IP allocator
"netv4|n4=s", # - Overlay net v4 block
"netv6|n6=s", # - Overlay net v6 block
"addr_server|as=s", # remote address server
# legacy options
"address_type|atype=s",
"control_protocol|cc=s",
"linkv4|l4=s", # - Overlay link v4 block
"linkv6|l6=s", # - Overlay link v6 block
# DNS related options
"xbone_net|xb=s",
"dns=s",
"name_server|ns=s",
"forward_zone|fzone=s",
"reverse_zone|rzone=s",
"reverse_zone6|rzone6=s",
"dns_key_file|dnskey=s",
# Dynamic routing related options
"zebra_dir|zd=s",
# Force router option
"force-router|fr",
# Cisco platform option
"cisco_buddy_username|ciscouname=s",
"cisco_buddy_password|ciscopw=s",
"cisco_buddy_enable_password|ciscoenpw=s",
# variables to be registered with the main xbone daemon
"register|reg=s%",
# variables to be registered with the main xbone daemon
"ldap=s%",
);
# Description:
# Parse the commandline, conf file and if necessary
# conf from an LDAP server.
# Arguments:
# (Implicit) %options
# Returns:
# stored in the options structure
# Exceptions:
#
# Notes: This code is a little bit (?) ugly. This has
# copied and used almost unmodified from xb-node-daemon.
#
#
sub get_opts {
my %cmdl_opts; # hash of args from command line
my $file_opts; # obj of args from config file
my $ldap_opts; # obj of args from ldap server
#=> get command line options
if (GetOptions(\%cmdl_opts, @opts_spec)==0) {
print "Usage: xb-node-control [-h hostname] <options>\n";
exit;
}
#=> get conf file options
my $have_conf = 1;
$options{conf} = defined $cmdl_opts{conf} ?
$cmdl_opts{conf} : $options{conf};
unless (-f $options{conf}){
#warn "! Could not find XBone config file: $options{conf}";
$have_conf = 0;
}else{
$file_opts = AppConfig->new(@opts_spec);
$file_opts->file($options{conf}) or
warn "! Error parsing XBone conf file: $options{conf}"
and die "parse";
}
for my $n (keys %options){
# The following are sets and they have to be treated
# slightly differently.
next if ($n =~ /(ldap|user_acl|ovl_manager|register)/);
if (defined $cmdl_opts{$n}){ # command line
$options{$n} = $cmdl_opts{$n};
} elsif ((defined $file_opts) and (defined $file_opts->get($n))){ # conf file
$options{$n} = $file_opts->get($n);
} elsif ((defined $ldap_opts) and (defined $ldap_opts->get($n))){ # ldap
$options{$n} = $ldap_opts->get($n);
};
};
# copy the ldap information from the conf files.
if (defined $file_opts){
my $ldaphash = $file_opts->get('ldap');
if (defined $ldaphash) {
foreach my $attr (keys %{$ldaphash}){
$options{ldap}->{$attr} = $ldaphash->{$attr};
};
}
};
# cleanup the result from `hostname`
chomp($options{hostname});
#=> Handle Overlay Manager List. Let command line override
# conf file, and conf file transitively override ldap.
my (@mgrarr) = ();
@mgrarr = @{$cmdl_opts{'ovl_manager'}}
if (defined $cmdl_opts{'ovl_manager'});
if ($#mgrarr == -1){
@mgrarr = @{$file_opts->get('ovl_manager')}
if ((defined $file_opts) and (defined $file_opts->get('ovl_manager')));
}
if ($#mgrarr == -1){
@mgrarr = @{$ldap_opts->get('ovl_manager')}
if ((defined $ldap_opts) and (defined $ldap_opts->get('ovl_manager')));
}
$options{'ovl_manager'} = \@mgrarr;
#=> Handle ACL Rules compute the acl union. conflicts between acl
#rules of the different sites is handled through offline control.
my (@aclarr) = ();
push @aclarr, $ldap_opts->get('user_acl')
if ((defined $ldap_opts) and (defined $ldap_opts->get('user_acl')));
push @aclarr, $file_opts->get('user_acl')
if ((defined $file_opts) and (defined $file_opts->get('user_acl')));
push @aclarr, $cmdl_opts{'user_acl'}
if (defined $cmdl_opts{'user_acl'});
# process ACLs. the order is important
foreach my $map (@aclarr){
# process each map separately
foreach my $key (keys %{$map}){
$options{user_acl}->{$key} = $map->{$key};
}
};
#=> Handle the register commands
if ((keys %{$cmdl_opts{'register'}}) > 0){
$options{register} = $cmdl_opts{'register'};
} elsif ((defined $file_opts) and ((keys %{$file_opts->get('register')}) > 0)){
$options{register} = $file_opts->get('register');
} elsif ((defined $ldap_opts) and ((keys %{$ldap_opts->get('register')}) > 0)){
$options{register} = $ldap_opts->get('register');
};
# debugging outputs
#print ">>> ", Dumper(\%cmdl_opts), "\n";
#print ">>> ", Dumper(\%options), "\n";
#print ">>> ", Dumper($ldap_opts), "\n";
#print ">>> ", Dumper($file_opts), "\n";
#print ">>> ACL: ", Dumper($options{user_acl});
}
########################################################################
# 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>) {
unless (/DB_KEYEXIST/) {
$msg .= $_;
}
}
while (<ERR>) {
unless (/DB_KEYEXIST/) {
$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;
}
};
###########################################################################
# Base Configuration
###########################################################################
# Description:
# Option setting callback. Called when the user presses
# apply/update for LDAP
# Arguments:
# $top: parent window to popup a message
# $what: what should be checked
# Returns:
#
# Exceptions:
#
sub opt_callback_ldap ($$) {
my ($top, $what) = @_;
#print "Callback : LDAP, $what\n";
# add a series of checks.
my $ldapconf = $options{ldap};
if ($$ldapconf{enable} !~ /(yes|no)/){
$$ldapconf{enable} = "no";
}
return if ( $$ldapconf{enable} !~ /(yes)/ );
# basically if we came here, then enable is yes. the variable
# updated could be enable or any of the other variable on the
# window. So, check all of them if enable has been modified.
my @whatall = ();
if ( $what eq "enable" ){
@whatall = ( "server", "password", "instance", "port" );
} elsif ( $what eq "all" ){
@whatall = ( "server", "password", "instance", "port" );
} else {
@whatall = ( $what );
}
foreach (@whatall) {
SWITCH: {
/(server)/ and do {
if ((not defined $$ldapconf{'server'}) or
( $$ldapconf{'server'} eq "")){
showmsg($top, "LDAP server is undefined.");
return 0;
};
};
/(password)/ and do {
if ((not defined $$ldapconf{'password'}) or
( $$ldapconf{'password'} eq "")){
showmsg($top, "LDAP user password is undefined");
return 0;
};
};
/(instance)/ and do {
if ((not defined $$ldapconf{'instance'}) or
( $$ldapconf{'instance'} eq "")){
showmsg($top, "The instance is undefined");
return 0;
};
};
/(port)/ and do {
if ((not defined $$ldapconf{'port'}) or
( $$ldapconf{'port'} eq "")){
showmsg($top, "Server port number is undefined");
return 0;
};
};
}; # SWITCH
}; # foreach
return 1;
};
# Description:
# Option setting callback. Called when the user presses
# apply/update for DNS
# Arguments:
# $top: parent window to popup a message
# $what: what should be checked
# Returns:
#
# Exceptions:
#
sub opt_callback_dns ($$) {
my ($top, $what) = @_;
#print "Callback : DNS, $what\n";
# add a series of checks.
return if ($options{"dns"} !~ /(yes)/);
my %map = (
"name_server" => "DNS Server",
"dns_key_file" => "TSIG key file",
"reverse_zone" => "Reverse zone",
"forward_zone" => "Forward zone",
"reverse_zone6" => "IPv6 Reverse zone",
);
if ( $what ne "dns" and $what ne "all" ) {
if ((not defined $options{$what}) or
($options{$what} eq "")) {
showmsg($top, $map{$what} . " undefined ");
return 0;
};
} else {
# if DNS is enabled, then look at all the specified
# entries.
foreach $what (keys %map) {
if ((not defined $options{$what}) or
($options{$what} eq "")) {
showmsg($top, $map{$what} . " undefined ");
return 0;
};
};
};
return 1;
};
# 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 $ovl_mgr_list = "";
my $ldapconf = $options{ldap};
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 (! $v6noshow and ! $v4noshow ){ push @ipver, "both"; };
# Initialization of variables
$ovl_mgr_list = join (',', @{$options{ovl_manager}});
if ( not defined $$ldapconf{server} or $$ldapconf{server} eq ""){
$$ldapconf{server} = $options{hostname};
}
if ( not defined $$ldapconf{port} or $$ldapconf{port} eq ""){
$$ldapconf{port} = 636;
}
# Options
my @opttable = (
'Main',
[
'ipproto', '=s', $options{ipproto},
label => 'IP Protocol:',
longhelp => 'IP version(s) that the Node Daemon should enable.',
choices => \@ipver,
var => \$options{ipproto},
strict => 1,
],
[
'daemon_type', '=s', $options{daemon_type},
label => 'Daemon Type',
longehelp => 'Select type of node. Options include: meta = overlay manager, node = router + host, router, host',
choices => [ "meta", "node", "router", "host"],
strict => 1,
var => \$options{daemon_type},
],
[
'os', '=s', $options{os},
label => 'Node OS:',
longhelp => 'Node operating system. This is by default the host operating system but if this node is configured as a buddy for another os (we support only cisco), then the node should be set to the other os (cisco). ',
choices => [ $options{os}, "cisco" ],
var => \$options{os},
strict => 1,
],
[
'ovl_mgr_list', '=s', $ovl_mgr_list,
label => 'Overlay Manager List:',
longhelp => 'List of overlay manager (host names) that this daemon should accept overlay management requests from.',
var => \$ovl_mgr_list,
],
'Addressing',
['', '', "$hostname" ],
['', '',
'
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 on which the Node Daemon will listen.',
choices => $v4addrs,
nogui => $v4noshow,
var => \$options{ctl_addr},
],
[
'app_addr', '=s', $v4addrs->[0],
label => 'IPv4 Address of Buddy Host:',
longhelp => 'Applicable only in case this node is used as a buddy for a Cisco router',
nogui => $v4noshow,
var => \$options{app_addr},
],
[
'ctl_addr6', '=s', $v6addrs->[0],
label => 'IPv6 Address:',
longhelp => 'IPv6 address on which the Node Daemon will listen.',
choices => $v6addrs,
nogui => $v6noshow,
var => \$options{ctl_addr6},
],
[
'app_addr6', '=s', $v6addrs->[0],
label => 'IPv6 Address of Buddy Host:',
longhelp => 'Applicable only in case this node is used as a buddy for a Cisco router',
nogui => $v6noshow,
var => \$options{app_addr6},
],
'LDAP',
['', '', "LDAP Server Configuration"],
[
'LDAP', '=s', $$ldapconf{enable},
label => 'Enable LDAP',
longehelp => 'use LDAP Server',
choices => [ "yes", "no" ],
var => \$$ldapconf{enable},
callback => sub { opt_callback_ldap($top, "enable"); },
strict => 1,
],
[
'ldapserver', '=s', $$ldapconf{server},
label => 'LDAP Server:',
#longhelp => 'LDAP server',
var => \$$ldapconf{server},
callback => sub { opt_callback_ldap($top, "server"); }
],
[
'ldapport', '=i', $$ldapconf{port},
label => 'Port',
longhelp => 'Port on which LDAP server runs',
var => \$$ldapconf{port},
callback => sub { opt_callback_ldap($top, "port"); }
],
[
'ldappasswd', '=s', $$ldapconf{password},
label => 'User Password:',
longhelp => 'Password for OID "cn=XBoneUser,ou=Users,ou=xbone" ',
var => \$$ldapconf{password},
callback => sub { opt_callback_ldap($top, "password"); }
],
[
'ldapinstance', '=s', $os,
label => 'Instance',
longhelp => 'Choose the instance name '.
'"ou=xbone,ou=local,ou=config,cn=<hostname>,cn=<instance>"'
. 'See /usr/local/www/xbone/doc/xbone-ldap.txt',
var => \$$ldapconf{instance},
callback => sub { opt_callback_ldap($top, "instance"); }
],
[
'ldapscope', '=i', $$ldapconf{scope},
label => 'Scope',
choices => [ "local", "global" ],
longhelp => 'Is this deployment of X-Bone part of the Global X-Bone Testbed?',
var => \$$ldapconf{scope},
],
'DNS',
['', '', "DNS Configuration"],
[
'dns', '=s', $options{dns},
label => 'Enable DNS',
choices => [ "yes", "no" ],
var => \$options{dns},
strict => 1,
callback => sub { opt_callback_dns($top, "dns"); }
],
[
'name_server', '=s', "",
label => 'Name of the DNS Server',
longhelp => 'DNS Server',
var => \$options{name_server},
callback => sub { opt_callback_dns($top, "name_server"); }
],
[
'forward_zone', '=s', $options{forward_zone},
label => 'DNS Forward Zone',
longhelp => 'DNS Forward Zone',
var => \$options{forward_zone},
callback => sub { opt_callback_dns($top, "forward_zone"); }
],
[
'reverse_zone', '=s', $options{reverse_zone},
label => 'DNS Reverse Zone',
longhelp => 'DNS Reverse Zone',
var => \$options{reverse_zone},
callback => sub { opt_callback_dns($top, "reverse_zone"); }
],
[
'reverse_zone6', '=s', $options{reverse_zone6},
label => 'DNS IPv6 Reverse Zone',
longhelp => 'DNS IPv6 Reverse Zone',
var => \$options{reverse_zone6},
callback => sub { opt_callback_dns($top, "reverse_zone6"); },
nogui => $v6noshow,
],
['dns_key_file', "=s", $options{dns_key_file},
label => "DNS Key",
subtype => 'file',
var => \$options{dns_key_file},
callback => sub { opt_callback_dns($top, "dns_key_file"); }
],
'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',
['', '', "Miscellaneous Settings"],
[
'IPSec', "=s", $options{IPsec},
label => 'Enable IPSec',
var => \$options{IPsec},
choices => [ "yes", "no" ],
strict => 1,
],
[
'routing', '=s', $options{routing},
label => 'Routing',
choices => [ "static", "dynamic"],
var => \$options{routing},
strict => 1,
],
[
'qos', '=s', $options{qos},
label => 'Enable QoS',
choices => [ "yes", "no" ],
var => \$options{qos},
longhelp => 'QoS support depends on host support. '.
'X-Bone uses DummyNet on FreeBSD and NISTnet on Linux',
strict => 1,
],
);
$opt = new Tk::Getopt(-opttable => \@opttable,
-options => \%options,
);
$opt->set_defaults;
$opt->load_options;
$opt->get_options;
$opt->process_options;
$opt->option_editor($top,
"-wait" => 1,
"-delaypagecreate" => 1,
"-buttons" => [qw/ok/],
);
$opt->get_options;
# fix the overlay manager list
my @ovl_manager = split(/[\s,:;]+/, $ovl_mgr_list);
$options{ovl_manager} = \@ovl_manager;
#print Dumper(\%options);
}; # config
###############################################################
# Table Manipulation for Registry and ACL
###############################################################
# Description:
# Check if the cell entry has been entered correctly
# Arguments:
# $top: parent window to popup a message
# $t: table display window
# $tableopts: hash containing variables (including data array)
# $prev: previous cell
# $curr: current cell
# Returns:
# 1 on successs
# 0 on failure
# Exceptions:
#
sub validatecell ($$$$$) {
my ($t, $top, $tableopts, $prev, $curr) = @_;
my $msg = 'Cells in the row are empty or incorrect.';
eval {
if ((defined $prev) and ($prev ne "")){
my ($row,$col)=split(",",$prev);
# empty cells
if ((not defined $$tableopts{array}->{"$prev"}) or
($$tableopts{array}->{"$prev"} eq "")){
showmsg($top, $msg);
$t->activate($prev);
die ("cell");
}
# Syntax check
if (($$tableopts{name} eq "acl") and
(($col eq "0") or ($col eq "3")) and
(not (($$tableopts{array}->{$prev} =~ /^(\d+)$/) and
($$tableopts{array}->{$prev} ge 0)))
){
my $supmsg = "";
if ($col eq "0") {
$supmsg = "Rule number in row $row has to be an integer.";
} else {
$supmsg = "Tunnel count in row $row has to be an integer.";
}
showmsg($top, $msg . $supmsg);
$t->activate($prev);
die ("cell");
}
if (($$tableopts{name} eq "acl") and ($col == "2")){
my $access = $$tableopts{array}->{$prev};
if (not defined $XB_Params::access_level{$access}){
my $line = join (", ", (keys %XB_Params::access_level));
my $supmsg = " The access level specified in third column " .
" should belong the supported set { $line } ";
showmsg($top, $msg . $supmsg);
$t->activate($prev);
die ("cell");
}
}
# if row changes, then make sure that the row is filled.
my ($crow,$ccol)=split(",",$curr);
# check the entire row.
if ($crow ne $row) {
# go through as many cols as contained in the first row.
my $i = 0;
while (defined $$tableopts{array}->{"0,$i"}){
if ((not defined $$tableopts{array}->{"$row,$i"}) or
($$tableopts{array}->{"$row,$i"} eq "")){
my $supmsg = " Check cell in row $row column $i ";
showmsg($top, $msg . $supmsg);
$t->activate("$row,$i");
die ("row");
}
$i++;
}
}
}
}; # eval
return 0 if ($@);
return 1;
};
# Description:
# This calls validate on each and every row
# when the user clicks on quit.
# Arguments:
# $top: parent window to popup a message
# $t: table display window
# $tableopts: hash containing variables (including data array)
# Returns:
# 1 on successs
# 0 on failure
# Exceptions:
#
sub validateall ($$$) {
my ($t, $top, $tableopts) = @_;
eval {
foreach my $row (1 .. ${$$tableopts{rows}} - 1){
die ("validate")
if (!validatecell($t, $top, $tableopts, "$row,0", "0,0"));
}
};
return 0 if ($@);
return 1;
}
# Description:
# Show the table - whatever it may be. All required data is
# specified in the table opts.
# Arguments:
# $tableopts: hash containing variables (including data array)
# Returns:
# 1 on successs
# 0 on failure
# Exceptions:
#
# Notes: This is a common function for both ACL and Registry
# and any future tables that need to read from the user.
#
sub table ($){
my ($tableopts) = @_;
my ($main, $top, $frame, $t);
# open a new table
$top = $$tableopts{main}->Toplevel;
$top->Label(-text => $options{hostname} . " - " . $$tableopts{title})->pack;
# A menu bar is really a Frame.
$menubar = $top->Frame(-relief=>"raised",
-borderwidth=>2);
# Menubuttons appear on the menu bar.
my $filebutton =
$menubar->Menubutton(-text=>"Options", -underline => 0);
# Menus are children of Menubuttons.
my $filemenu = $filebutton->Menu();
# Associate Menubutton with Menu.
$filebutton->configure(-menu => $filemenu);
$filemenu->command( -label => "Quit",
-command => sub {
if (validateall($t, $top, $tableopts)){
$top->destroy();
}
}
);
my $filebutton2 = $menubar->Menubutton(-text=>"Table",
-underline => 0);
# Menus are children of Menubuttons.
my $filemenu2 = $filebutton2->Menu();
$filebutton2->configure(-menu=>$filemenu2);
$filemenu2->command ( -label =>"Append New Row",
-command=> sub {
my $rows = ${$$tableopts{rows}};
# append blank record at end of table
$t->insertRows($rows,1);
$rows++;
$t->see("$rows,0");
$t->activate("$rows,0");
${$$tableopts{rows}} = $rows;
}
);
$filemenu2->command ( -label => "Delete Row Containing Active Cell",
-command => sub {
my $loc = $t->tagCell("active");
my ($row,$col)=split(",",$loc);
$t->deleteRows($row,1);
${$$tableopts{rows}}--;
}
);
$filemenu2->command ( -label =>"Show Active Cell",
-command =>sub{ $t->see("active"); }
);
# Help menu.
$helpbutton = $menubar->Menubutton(-text => "Help",
-underline => 0);
$helpmenu = $helpbutton->Menu();
$helpmenu->command(-command => $$tableopts{help},
-label => "Table",
-underline => 0);
$helpbutton->configure(-menu=>$helpmenu);
# Pack most Menubuttons from the left.
$filebutton->pack(-side=>"left");
$filebutton2->pack(-side=>"left");
# Help menu should appear on the right.
#$helpbutton->pack(-side=>"right");
$menubar->pack(-side => "top", -fill => "x");
$t = $top->Scrolled('TableMatrix',
-rows => ${$$tableopts{rows}},
-cols => ${$$tableopts{cols}},
-titlerows => 1,
-variable => $tableopts->{array},
-colstretchmode => 'all',
-rowstretchmode => 'all',
-colwidth => 13,
-rowheight => 1,
-height => 0,
-width => 0,
#-selectmode => 'extended',
-browsecmd => sub {
my ($prev, $curr) = @_;
validatecell($t, $top, $tableopts, $prev, $curr);
},
#-maxheight => 1000,
-selecttype => 'row',
#-scrollbars => 'se',
-sparsearray => 0,
#-bd => 1,
);
#-width => 6,
#-height =>16,
#-bg => 'PaleGreen',
#-validatecommand => sub { validatecell ($t, $tableopts); },
#-validate => 1,
# the next two statements force left justification of everything
$t->tagConfigure("just", -anchor=>'w');
foreach my $col ( 0 .. ${$$tableopts{cols}} -1 ) {
$t->tagCol("just",$col);
}
$t->pack(-expand => 1, -fill => 'both');
# bring focus to the table
$t->activate("1,0");
$t->focus;
$top->deiconify;
$top->raise();
# block access to other windows
my $wait_var = 1;
$top->OnDestroy(sub { undef $wait_var });
$top->waitVisibility unless $top->ismapped;
$top->grab;
$top->waitVariable(\$wait_var);
};
###############################################################
# ACL
###############################################################
# Description:
# Obtain the ACL entries. Specify the requirements to
# table function.
# Arguments:
# $main: main window
# Returns:
#
# Exceptions:
#
sub acl ($){
my ($main) = @_;
my $rule;
my $array = {};
my ($numrows, $numcols) = (1,5);
$array->{"0,0"} = "Rule No";
$array->{"0,1"} = "Pattern";
$array->{"0,2"} = "Capability";
$array->{"0,3"} = "Tunnels";
$array->{"0,4"} = "UID";
foreach $rule (keys %{$options{user_acl}}){
my $line = $options{user_acl}{$rule};
my @opts = split (/\s+/, $line);
my $pat = $opts[0];
my $cap = $opts[1];
my $tun = $opts[2];
my $uid = $opts[3];
$array->{"$numrows,0"} = $rule;
$array->{"$numrows,1"} = $pat;
$array->{"$numrows,2"} = $cap;
$array->{"$numrows,3"} = $tun;
$array->{"$numrows,4"} = $uid;
$numrows++;
}
my %tableopts = (
"main" => $main,
"name" => "acl",
"title" => "ACL Configuration",
"array" => $array,
"rows" => \$numrows,
"cols" => \$numcols,
);
table(\%tableopts);
my %newacl = ();
foreach my $row (1..$numrows-1){
# take care of undefined entries
foreach my $i (0..$numcols){
$array->{"$row,1"} = ""
if (not defined $array->{"$row,1"});
}
$rule = $array->{"$row,0"};
my $line =
$array->{"$row,1"} . " " .
$array->{"$row,2"} . " " .
$array->{"$row,3"} . " " .
$array->{"$row,4"} ;
$newacl{$rule} = $line;
}
$options{user_acl} = \%newacl;
};
###############################################################
# Registry
###############################################################
# Description:
# Obtain the Registry entries. Specify the requirements to
# table function.
# Arguments:
# $main: main window
# Returns:
#
# Exceptions:
#
sub registry ($){
my ($main) = @_;
my $rule;
my $array = {};
my ($numrows, $numcols) = (1,2);
$array->{"0,0"} = "Attribute";
$array->{"0,1"} = "Value";
foreach $var (keys %{$options{register}}){
my $val = $options{register}{$var};
$array->{"$numrows,0"} = $var;
$array->{"$numrows,1"} = $val;
$numrows++;
};
my %tableopts = (
"main" => $main,
"name" => "registry",
"title" => "Registry Configuration",
"array" => $array,
"rows" => \$numrows,
"cols" => \$numcols,
);
table(\%tableopts);
my %register = ();
foreach my $row (1..$numrows-1){
# take care of undefined entries
foreach my $i (0..$numcols){
$array->{"$row,1"} = ""
if (not defined $array->{"$row,1"});
}
$var = $array->{"$row,0"};
$val = $array->{"$row,1"};
$register{$var} = $val;
}
$options{register} = \%register;
#print Dumper($options{register});
};
###############################################################
# 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.conf",
-title => "Save X-Bone Configuration File");
if ((not defined $file) or ($file eq "")) {
last; # dont show the message
$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',
);
next;
};
last;
};
return if ((not defined $file) or ($file eq ""));
open(CONF,">$file");
print CONF "#************ X-Bone 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";
$options{address_type} = $options{ipproto};
$options{control_protocol} = $options{control_protocol};
my @variables = (
"hostname",
"daemon_type","addrserv", "address_type",
"control_protocol","ipproto",
"dns","name_server", "dns_key_file",
"xbone_net",
"os", "os_version", "kern_version",
"cisco_buddy_username", "cisco_buddy_password",
"cisco_buddy_enable_password",
"routing", "IPsec", "qos",
);
my @v6variables = ( "ctl_addr6", "app_addr6", "xbone_mcast_addrv6" );
my @v4variables = ( "ctl_addr", "app_addr", "xbone_mcast_addr" );
my @certvariables = ( "ca_cert", "ca_path", "node_cert", "node_key" );
my @ldapvariables = (
"enable", "server", "port",
"password", "instance", "scope"
);
my @addressarray = ();
if ( $options{ipproto} eq "ipv4" ){
@addressarray = @v4variables;
} elsif ( $options{ipproto} eq "ipv6" ){
@addressarray = @v6variables;
} else {
@addressarray = (@v4variables, @v6variables);
}
#print Dumper(\%options);
# Should I write both an LDIF file and a .CONF file or
# only a .CONF file.
if ($options{ldap}->{enable} =~ /(yes)/i){
# First generate the .conf file with enough
# information to contact the server.
foreach my $key (@ldapvariables){
print CONF "ldap $key = " . $options{ldap}->{$key} . "\n";
}
foreach my $key (@certvariables){
print CONF "$key = " . $options{$key} . "\n";
}
# Store everything else in the LDIF File.
my $file = $top->getSaveFile(-filetypes => \@ldaptypes,
-initialdir => "/usr/local/etc/xbone",
-initialfile => "xbone.ldif",
-title => "Save LDAP Configuration");
if (defined $file) {
open(LDIF,">$file");
my $h = $options{'hostname'};
my $ldapconf = $options{'ldap'};
my $instance = $$ldapconf{'instance'};
#=> host configuration
print LDIF "dn: cn=$h,ou=config,ou=local,ou=xbone\n";
print LDIF "objectClass: XBoneGroup\n";
print LDIF "cn: $h\n\n";
#=> host configuration
print LDIF "dn: cn=$instance,cn=$h,ou=config,ou=local,ou=xbone\n";
print LDIF "objectClass: XBoneInstance\n";
print LDIF "cn: $instance\n";
foreach $key (@variables, @addressarray){
if ((defined $options{$key}) and
($options{$key} ne "") and
($options{$key} ne $defaults{$key})){
print LDIF "xbattr: \'$key = $options{$key}\'\n";
}
}
foreach my $mgr ( @{$options{'ovl_manager'}}) {
print LDIF "xbattr: \'ovl_manager = $mgr\'\n";
};
foreach my $key ( keys %{$options{user_acl}} ){
print LDIF "xbacl: \'$key = " . $options{user_acl}{$key} .
"\'\n";
}
foreach my $key ( keys %{$options{register}} ){
print LDIF "xbregister: \'$key = " .
$options{register}{$key} . "\'\n";
}
close(LDIF);
my $m = "Load the contents of $file into the LDAP server ".
"using xb-ldap-config or any other ldap tool ".
"(e.g., phpldapadmin)";
$top->messageBox(-icon => 'info',
-message => $m,
-title => 'Help',
-type => 'Ok',
);
}; # defined LDIF file
} else {
# Write out the node config in a non-ldap fashion
foreach $key (@variables, @addressarray){
if ((defined $options{$key}) and
($options{$key} ne "") and
($options{$key} ne $defaults{$key})){
print CONF "$key = $options{$key}\n";
}
}
foreach my $key (@certvariables){
print CONF "$key = " . $options{$key} . "\n";
}
print CONF "\n\n";
foreach my $mgr (@{$options{'ovl_manager'}}) {
print CONF "ovl_manager = $mgr\n";
}
print CONF "\n\n";
foreach my $key ( keys %{$options{register}} ){
print CONF "register $key = " . $options{register}{$key} . "\n";
}
print CONF "\n\n";
foreach my $key ( keys %{$options{user_acl}} ){
print CONF "acl $key = " . $options{user_acl}{$key} . "\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 !~ /(dns|zebra|openldap)/);
my $ldapmsg =
"X-Bone requires OpenLDAP version 2.2.18 and above.\n\n" .
"To configure LDAP, add the following lines to /etc/rc.conf.local" .
"\nslapd_enable=\"YES\"\n".
"slapd_flags=\"-h ldaps://<server-name>\"\n\n".
"X-Bone specific LDAP configuration is stored in ".
"etc/xbone/openldap/slapd-xbone.conf and one include rule ".
"is added the the default LDAP configuration file.\n\n".
"bin/xb-ldap-config is a useful script that install/uninstall, ".
" X-Bone-specific LDAP configuration, show the content of the " .
"LDAP server and ".
"upload contents of LDIF files generated the control panel.\n\n".
"More information can be found in xbone/doc/xbone-ldap.txt\n";
my $dnsmsg =
"X-Bone requires Bind 9 or above.\n\n" .
"X-Bone Overlay Manager uses Dynamic DNS with DNSSEC to " .
"add records to the DNS server. The DNS server must be " .
"appropriately configured along with the Overlay Manager\n\n".
"Sample X-Bone specific DNS configuration is stored in ".
"etc/xbone/named and detailed step by step instructions can ".
"be found in xbone/doc/dynamic_dns.txt\n\n";
my $zebramsg =
"X-Bone requires Quagga 0.96 or above.\n\n" .
"X-Bone Node Daemons manipulate the Quagga routing daemon".
" configuration during the overlay creation process.\n\n".
"There is little in terms of X-Bone specific Quagga ".
"configuration. Example quagga configuration files are stored ".
" in etc/xbone/routing and step by step instructions can be " .
"found in xbone/doc/xbone-dynamic_routing.txt\n\n";
if ($what =~ /(dns)/i){
$m = $dnsmsg;
} elsif ($what =~ /(zebra)/i){
$m = $zebramsg;
} elsif ($what =~ /(openldap)/i){
$m = $ldapmsg;
}
$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 !~ /^(openldap)$/);
return if ($op !~ /^(install|uninstall)$/);
if ($type =~ /^(openldap)$/) {
$script = "xb-ldap-config";
} else {
$script = "xb-config.pl";
}
my @cmd = ("/usr/local/bin/$script", $op);
if ($type =~ /^(openldap)$/) {
# add other options for OpenLDAP
my $scope = "local";
if (defined $options{ldap} and
defined $options{ldap}->{scope} and
$options{ldap}->{scope} =~ /(global)/){
$scope = "global";
}
@cmd = (@cmd, $scope);
}
eval {
$msg = execcmd(\@cmd);
};
if ($@) {
showmsg($top, "Error! $@.");
} else {
my $m = "Operation successful!";
if ($msg) {
$m .= "\n\nAdditional information: " . $msg;
}
$top->messageBox(-icon => 'info',
-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 375));
$top -> geometry('+0+0');
$l = $top->Label (-text=>'(Un)Install X-Bone Specific Components.');
#$l->place(-x=>10, -y => 10);
$l->pack(-pady => 5);
my $f = $top->LabFrame(-label => "OpenLDAP");
$f->place(-x => 0, -y => 30, -width => 300, -height => 100);
$l = $f->Label(-text=>'(Only if the LDAP is installed on this host)');
$l->pack(-pady => 5, -padx => 5, -side => "top");
$b = $f->Button(
-text => 'Install',
-command => sub{
&related_btn_cb($top, "openldap", "install");
}
);
$b->place(-x=>20, -y => 25);
$b = $f->Button(
-text => 'Uninstall',
-command => sub{
&related_btn_cb($top, "openldap", "uninstall");
}
);
$b->place(-x=>100, -y => 25);
$b = $f->Button(
-text => 'Help',
-command => sub{&help_btn_cb($top, "openldap");}
);
$b->place(-x=>210, -y => 25);
$f = $top->LabFrame(-label => "BIND/DNS");
$f->place(-x => 0, -y => 130, -width => 300, -height => 100);
$l = $f->Label(-text=>'(To be supported in future. See help.)');
$l->pack(-pady => 5, -padx => 5, -side => "top");
$b = $f->Button(
-text => 'Install',
-command => sub{
&related_btn_cb($top, "dns", "install");
},
-state => 'disabled',
);
$b->place(-x=>20, -y => 25);
$b = $f->Button(
-text => 'Uninstall',
-command => sub{
&related_btn_cb($top, "dns", "uninstall");
},
-state => 'disabled',
);
$b->place(-x=>100, -y => 25);
$b = $f->Button(
-text => 'Help',
-command => sub{&help_btn_cb($top, "dns");}
);
$b->place(-x=>210, -y => 25);
$f = $top->LabFrame(-label => "Zebra/Quagga");
$f->place(-x => 0, -y => 230, -width => 300, -height => 100);
$l = $f->Label(-text=>'(To be supported in future. See help.)');
$l->pack(-pady => 5, -padx => 5, -side => "top");
$b = $f->Button(
-text => 'Install',
-command => sub{
&related_btn_cb($top, "zebra", "install");
},
-state => 'disabled',
);
$b->place(-x=>20, -y => 25);
$b = $f->Button(
-text => 'Uninstall',
-command => sub{
&related_btn_cb($top, "zebra", "uninstall");
},
-state => 'disabled',
);
$b->place(-x=>100, -y => 25);
$b = $f->Button(
-text => 'Help',
-command => sub{&help_btn_cb($top, "zebra");}
);
$b->place(-x=>210, -y => 25);
$b = $top->Button(
-text => 'Quit',
-command => [$top => 'destroy']
);
$b->place(-x=>115, -y => 335);
my $wait_var = 1;
$top->OnDestroy(sub { undef $wait_var });
$top->waitVisibility unless $top->ismapped;
$top->grab;
$top->waitVariable(\$wait_var);
};
###############################################################
# Start/Stop X-Bone
###############################################################
sub xbonectl ($$) {
my ($top, $op) = @_;
my $msg = "";
#=> Check to make sure that the user has uploaded the
# the LDIF
my $ldapconf = $options{'ldap'};
if ( defined $ldapconf and $$ldapconf{'enable'} =~ /(yes)/i) {
my $msg .= "If LDAP database is used to store host configuration " .
"then the content of the LDIF file generated by the ".
"control panel must be uploaded to server. Click Yes ".
"if already done. Else run xb-ldap-config with " .
"appropriate options.";
my $response = $top->messageBox(-icon => 'question',
-message => $msg,
-title => 'Warning!',
-type => 'YesNo',
);
return if ($response =~ /(no)/i);
};
my @cmd = ("/usr/local/bin/xbonectl", "$op");
eval {
# execcmd blocks until all children and their children
# finish.
#$msg = execcmd(\@cmd);
system(@cmd) == 0 || die ("could not $op the node daemon");
};
if ($@) {
showmsg($top, "Error! $@.");
} else {
my $m = "Operation successful! ";
# "(See terminal output for additional information.)";
# NOT to put $msg into messageBox because it tends to clog
if ($msg) {
$m .= "\n\nAdditional information: " . $msg;
}
$top->messageBox(-icon => 'question',
-message => $m,
-title => 'Status',
-type => 'Ok',
);
};
}
###############################################################
# Main
###############################################################
sub main_btn_cb ($$){
my ($top, $type) = @_;
my %funcmap = (
"save" => \&save,
"config" => \&config,
"registry" => \®istry,
"acl" => \&acl,
"related" => \&related,
);
$funcmap{$type}($top);
};
sub main {
# create a window
my $top = MainWindow->new;
$top->title("X-Bone Control Panel");
# make a copy of the defaults
foreach my $key (keys %options) {
next if ($key =~ /(register|user_acl|ldap)/ );
$defaults{$key} = $options{$key};
}
# load existing configuration file
my $file = $top->getOpenFile(-filetypes => \@conftypes,
-initialdir => "/usr/local/etc/xbone",
-initialfile => "xbone.conf",
-title => "Load An Existing Configuration File (If Any)");
if (defined $file and -f $file){
$options{conf} = $file;
} else {
$options{conf} = "";
}
# load the options
get_opts;
$font = $top->Font(family => 'courier',
point => 140,
weight => 'bold',
slant => 'r');
$top -> minsize(qw(300 330));
$top -> geometry('+0+0');
my $f = $top->LabFrame(-label => "Configure X-Bone");
$f->place(-x => 0, -y => 0, -width => 300, -height => 120);
$b = $f->Button(
-text => 'Base',
-command => sub{&main_btn_cb($top,"config");}
);
$b->place(-x=>20, -y => 10);
$b = $f->Button(
-text => 'Registry',
-command => sub{&main_btn_cb($top,"registry");}
);
$b->place(-x=>100, -y => 10);
$b = $f->Button(
-text => 'ACL',
-command => sub{&main_btn_cb($top,"acl");}
);
$b->place(-x=>200, -y => 10);
$b = $f->Button(
-text => 'Save',
-command => sub{&main_btn_cb($top,"save");}
);
$b->place(-x=>110, -y => 50);
$f = $top->LabFrame(-label => "Configure Related Software");
$f->place(-x => 0, -y => 120, -width => 300, -height => 80);
my $msg .= "Automatic configuration of dependent services such as " .
"OpenLDAP requires saved X-Bone configuration in the standard " .
"location\n/usr/local/etc/xbone/xbone.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=>80, -y => 10);
$f = $top->LabFrame(-label => "X-Bone Runtime");
$f->place(-x => 0, -y => 200, -width => 300, -height => 80);
$b = $f->Button(
-text => 'Start',
-command => sub{&xbonectl($top,"start");}
);
$b->place(-x=>50, -y => 10);
$b = $f->Button(
-text => 'Stop',
-command => sub{&xbonectl($top,"stop");}
);
$b->place(-x=>150, -y => 10);
$b = $top->Button(
-text => 'Quit',
-command => [$top => 'destroy']
);
$b->place(-x=>105, -y => 280);
}
###############################################################
# Main Loop
###############################################################
main;
MainLoop;
syntax highlighted by Code2HTML, v. 0.9.1