#!/usr/bin/perl -w
#
#
# -------------------------------------------------------------------
# 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-xml-create.pl,v $
#
# $Revision: 1.34 $
# $Author: pingali $
# $Date: 2005/04/21 00:12:07 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Lars Eggert
use strict;
use sigtrap;
use LWP::Simple qw(!head);
use CGI qw(:standard :html3);
use CGI::Carp qw(fatalsToBrowser);
# set library search path
BEGIN {
use strict;
use sigtrap;
use FindBin;
use Config;
delete $ENV{PATH};
my $version = $Config{'version'};
my $arch = $Config{'archname'};
#my $ldir = $FindBin::RealBin;
my $ldir = "/usr/local/www/xbone/s-cgi-bin";
foreach my $p ($ldir,
"$ldir/../lib",
"$ldir/../cpan",
"$ldir/../cpan/lib/perl5/$version",
"$ldir/../cpan/lib/perl5/$version/$arch",
"$ldir/../cpan/lib/perl5/site_perl/mach",
"$ldir/../cpan/lib/perl5/site_perl/mach/$arch",
"$ldir/../cpan/lib/perl5/site_perl/$version",
"$ldir/../cpan/lib/perl5/site_perl/$version/$arch",
"$ldir/../cpan/lib/perl5/site_perl/$version/mach",
"$ldir/../cpan/lib/perl5/site_perl/$version/mach/$arch",
) {
if(-d $p) { unshift @INC, $p; }
}
# untaint the resulting include path so "use" works
foreach my $i (@INC) { if($i =~ /(.*)/) { $i = $1;} }
};
sub dump_params {
my $msg = "content-type: text/plain\n\n";
my @keys = param();
foreach my $key (@keys) {
$msg .= " $key => " . param($key) . "\n";
}
print $msg;
exit;
};
sub dump_arg ($) {
my ($arg) = @_;
my $msg = "content-type: text/plain\n\n";
$msg .= Dumper($arg);
print $msg;
exit;
};
#####################################
# Bring in the associated API files.
# Bring in the precompiled RecDescent
# parser for the API grammar, create
# an instance of the parser.
#####################################
use XB_Params;
use XB_XML_Interface;
use XB_XML_GUI;
use XB_XML_scan;
use XML::Simple;
use Data::Dumper; # Needed only for debugging
#use LWP::Simple;
my $host = `uname -n`;
chomp($host);
XB_XML_Interface::init();
my $canned_success_message =
'<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE xbone SYSTEM "http://www.isi.edu/xbone/software/xbone/api-1.0.dtd">
<xbone version="2.4" release="2.9">
<credential>
<property prop="user_name" value="Test User"/>
<property prop="user_email" value="dummy@dummy.com"/>
<property prop="auth_type" value="x509"/>
</credential>
<command>
<create_overlay_reply>
<property prop="overlay_name" value="aaaa.xbone.overlay"/>
<property prop="dns" value="yes"/>
<property prop="routing" value="static"/>
<property prop="IPsec_encryption" value="none"/>
<property prop="IPsec_authentication" value="none"/>
<node>
<property prop="status" value="up"/>
<property prop="ip" value="128.9.112.69"/>
<property prop="class" value="simple"/>
<property prop="type" value="router"/>
<property prop="hostname" value="e.postel.org"/>
<property prop="vname" value="router_0"/>
<property prop="os" value="freebsd"/>
<tunnel>
<property prop="remote_ip_address" value="172.26.0.14"/>
<property prop="status" value="up"/>
<property prop="local_ip_address" value="172.26.0.13"/>
</tunnel>
<tunnel>
<property prop="remote_ip_address" value="172.26.0.10"/>
<property prop="status" value="up"/>
<property prop="local_ip_address" value="172.26.0.9"/>
</tunnel>
</node>
<node>
<property prop="status" value="up"/>
<property prop="ip" value="128.9.160.31"/>
<property prop="class" value="simple"/>
<property prop="type" value="host"/>
<property prop="hostname" value="tlc.isi.edu"/>
<property prop="vname" value="host_0"/>
<property prop="os" value="freebsd"/>
<tunnel>
<property prop="remote_ip_address" value="172.26.0.13"/>
<property prop="status" value="up"/>
<property prop="local_ip_address" value="172.26.0.14"/>
</tunnel>
</node>
<node>
<property prop="status" value="up"/>
<property prop="ip" value="128.9.112.68"/>
<property prop="class" value="simple"/>
<property prop="type" value="host"/>
<property prop="hostname" value="d.postel.org"/>
<property prop="vname" value="host_1"/>
<property prop="os" value="freebsd"/>
<tunnel>
<property prop="remote_ip_address" value="172.26.0.9"/>
<property prop="status" value="up"/>
<property prop="local_ip_address" value="172.26.0.10"/>
</tunnel>
</node>
</create_overlay_reply>
</command>
</xbone>
XBoneEOC';
my $myurl = "/cgi-bin/xb-xml-create.pl";
my $indexurl = "/cgi-bin/xb-xml-create.pl";
# get xbone dns suffix from defs, make sure it starts with a dot
my $suffix = $XB_Params::node_opts{xbone_net};
if($suffix !~ /^\./) { $suffix = ".$suffix"; }
# we are retaining this just in case it will be necessary in future.
my %explanation = ( name => "Name of the Overlay",
mcast_radius => "Search radius for multicast",
topology => "Overlay topology",
dns => "Enable DNS",
dyn_routing => "Enable dynamic Routing",
app => "Enable application deployment",
app_script => "Script for application deployment",
hosts => "Number of Hosts",
routers => "Number of Routers",
host_os => "Host operating systems",
router_os => "Router operating systems",
ah => "Authentication",
esp => "Ecryption",
dn_delay => "Dummynet setting for per-link transmission delay",
dn_bw => "Dummynet setting for per-link bandwidth",
dn_bw_u => "Unit of bandwidth specification",
dn_q => "Dummynet setting for per-hop queue length ",
dn_q_u => "Unit of queue length specification",
dn_plr => "Dummynet setting for per-hop loss probability");
my %default = ( name => "",
mcast_radius => 5,
topology => "star",
dns => 1,
dyn_routing => 0,
app => 0,
app_script => "",
hosts => 1,
routers => 1,
host_os => "freebsd",
router_os => "freebsd",
ah => "undef",
esp => "undef",
dn_delay => 100,
dn_bw => 10,
dn_bw_u => "Mbit",
dn_q => 100,
dn_q_u => "byte",
dn_plr => 0);
# there is a check for host_os and the backend requires host_os. So
# generate temporary variable.
my @newos = (param("host_os_freebsd"), param("host_os_linux"),
param("host_os_cisco"));
param(-name => "host_os", -value => \@newos);
@newos = (param("router_os_freebsd"), param("router_os_linux"),
param("router_os_cisco"));
param(-name => "router_os", -value => \@newos);
my @test_param = param();
my %user = XB_XML_Interface::user_info();
# make sure that the manager is selected
if (not defined param("manager")){
XB_XML_Interface::show_error
"Please specify an overlay manager",
"", $indexurl;
}
# check if any parameters have been passed.
if($#test_param == 0){ # only manager is defined
# Show the default page
# create-xsl.xml will take care of the formating information.
my $msg = "content-type: text/xml\n\n";
$msg .= "<?xml version=\"1.0\"?>\n";
$msg .= "<?xml-stylesheet type=\"text/xsl\" href=\"/xml/create-xsl.xml\"?>\n";
$msg .= "<overlay>\n";
$msg .= "<user>\n";
$msg .= "<name> $user{User} </name>\n";
$msg .= "<location>$user{Location}</location>\n";
$msg .= "<org>$user{Organization}</org>\n";
$msg .= "</user>\n";
$msg .= "<manager>";
$msg .= param("manager");
$msg .= "</manager>\n";
$msg .= "<overlay-properties>\n";
$msg .= " <name/>\n";
$msg .= " <addresstype/>\n";
$msg .= " <ldap/>\n";
$msg .= " <hostlist/>\n";
$msg .= " <search-radius/>\n";
$msg .= " <netlist/>\n";
$msg .= " <dns/>\n";
$msg .= " <timeout/>\n";
$msg .= " <topology/>\n";
$msg .= " <dynamic-routing/>\n";
$msg .= " <appscript>\n";
$msg .= " <user>nobody</user>\n";
$msg .= " <user>vhost</user>\n";
$msg .= " <user>root</user>\n";
$msg .= " </appscript>\n";
$msg .= "</overlay-properties>\n";
$msg .= "<nodes>\n";
$msg .= " <host-properties/>\n";
$msg .= " <router-properties/>\n";
$msg .= "</nodes>\n";
$msg .= "<link-properties>\n";
$msg .= " <authentication/>\n";
$msg .= " <encryption/>\n";
$msg .= " <dummynet/>\n";
$msg .= "</link-properties>\n";
$msg .= "<host>$host</host>\n";
$msg .= "</overlay>\n";
print $msg;
exit;
}
# XXX hack
# if the topology is set to star, then the routers entry is
# disabled and this variable value may not be uploaded.
# XXX figure out how to make the variable readonly instead
# of disabled
if (param("topology") eq "star" and not defined param("routers")) {
param("routers", 1);
@test_param = (@test_param, "routers");
}
#############################################################
# Arguments have been passed. See check if they are fine.
#############################################################
my ($h, $r) = (param("hosts"), param("routers"));
my ($t) = (param("topology"));
my $dyn_rtn;
###################################################################
# Check for manager name
###################################################################
if (not defined param("manager"))
{
# This is an server name
XB_XML_Interface::show_error "Invalid manager specified.", "", $indexurl;
}
###################################################################
# Check for proper name
###################################################################
if (param("name") !~ /^[a-z]([a-z0-9\-]*[a-z0-9])?$/i)
{
# This is an invalid DNS name.
XB_XML_Interface::show_error "Invalid Overlay Name",
"The overlay name \"".param("name") .
"\" is not a well-formed DNS name.", $myurl;
}
###################################################################
# Check for address type.
###################################################################
if (param("address_type") ne "ipv4" and param("address_type" ne "ipv6"))
{
XB_XML_Interface::show_error "Invalid address type:",
param("address_type"), $myurl;
}
###################################################################
# Check the discovery method
###################################################################
if (param("discovery_method") eq "multicast") {
if (defined param("mcast_radius") and
(param("mcast_radius") !~ /\d+/)){
XB_XML_Interface::show_error "Incorrect search radius specification.", "", $myurl;
};
};
if (param("discovery_method") eq "hostlist") {
if( defined param("custom_hostlist") and
param("custom_hostlist") =~ /^\S+$/) {
# do a simple check on the given URL
my $url = param("custom_hostlist");
if(! LWP::Simple::head($url)){
XB_XML_Interface::show_error "Custom hostlist access error. ",
"Cannot access the given URL: $url.", $myurl;
}
} else {
XB_XML_Interface::show_error "Custom hostlist missing. ",
"Did not specify a URL for Custom Hostlist.", $myurl;
}
}
if (param("discovery_method") eq "ldap") {
if (defined param("attrvals")){
my $cleaned = "";
my $line = param("attrvals");
$line =~ s/^\s+//;
$line =~ s/\s+$//;
my @av_array = split(/[\s,]+/, $line);
foreach my $av (@av_array){
my @arr = split(/=/, $av);
if (not defined $arr[0] or
not defined $arr[1] or
$arr[0] !~ /^\S+$/ or
$arr[1] !~ /^\S+$/){
XB_XML_Interface::show_error "Incorrect attribute value specification. Found error at \"$line\". ".
"Format is <attribute>=<value>. Value could be a regular expression. ", "", $myurl;
};
$cleaned .= $arr[0] . "=" . $arr[1] . " ";
};
# store the cleaned
param("attrvals", $cleaned);
};
};
###################################################################
# Check the topology and for minimum number of routers.
# check if user selected correct host/router numbers for topology type
###################################################################
if ($h !~ /\d+/){
XB_XML_Interface::show_error "Invalid host or router number ".
"specification.", "Must be a number, you specified \"$h\".", $myurl;;
};
if ($r !~ /\d+/){
XB_XML_Interface::show_error "Invalid host or router number ".
"specification.", "Must be a number, you specified \"$r\".", $myurl;;
};
if($t eq "star")
{
# star must have one router
if($r != 1)
{
my $msg = ($r eq "") ? "none" : $r;
XB_XML_Interface::show_error "Invalid Star Topology",
"Must have exactly one router in a star, you specified $msg.", $myurl;;
}
}
elsif ($t eq "ring")
{
# ring must have >= 3 routers
if($r < 3)
{
XB_XML_Interface::show_error "Invalid Ring Topology",
"Must have at least three routers in a ring, you specified " .
$r . ".", $myurl;;
}
}
elsif ($t eq "linear")
{
# line must have two end hosts
if($h < 2)
{
XB_XML_Interface::show_error "Invalid Line Topology",
"Must have atleast two end hosts in a line, you specified " .
$h . ".", $myurl;;
}
# Not more than two end hosts if zero routers.
if($r == 0 && $h > 2)
{
XB_XML_Interface::show_error "Invalid Line Topology",
"Can't have more than two hosts in a line without routers, " .
"you specified $h.", $myurl;;
}
}
elsif ($t eq "custom")
{
# make sure that url is specified.
if (not defined param("custom_netlist") or
param("custom_netlist") !~ /^\S+$/){
XB_XML_Interface::show_error "Unspecified or incorrectly ".
"specified netlist", "", $myurl;
}
###################################################################
# Check if the netlist is readable
###################################################################
my $url = param("custom_netlist");
if(!head($url)){
XB_XML_Interface::show_error "Netlist Access Error",
"Can not access the given URL: $url.", $myurl;;
}
}
else
{
# unsupported topology
XB_XML_Interface::show_error "Unsupported Topology $t", "", $myurl;
}
###################################################################
# If the application deployment script has been selected, check
# for the readability of the URL.
###################################################################
if(defined param("app") && param("app") == 1){
if(param("app_script") =~ /^\S+$/) {
# do a simple check on the given URL
my $url = param("app_script");
if(! head($url)){
XB_XML_Interface::show_error
"Application Deployment Script Access Error",
"Can not access the given URL: <B>$url</B>.", $myurl;;
}
if (not defined param("suid")){
XB_XML_Interface::show_error
"Application Deployment Script Error",
"User not selected. Internal error. " .
"Please contact X-Bone Support.", $myurl;
}
#else{ # for debugging only, will not proceed if uncommented
# my $doc = get($url);
# XB_XML_Interface::show_error "Application Deployment Testing",
# p("Script:<BR>$doc");
#}
}else{
XB_XML_Interface::show_error "Application deployment script missing",
"Did not specify a URL for Application Deployment Script.", $myurl;;
}
}
#else{ # don't need to fail if script given but didn't check the box
# if(param("app_script") =~ /^\S+$/){
# XB_XML_Interface::show_error "Application Deployment", "Need to check the box.";
# }
#}
###################################################################
# Check for dynamic routing.
###################################################################
if (defined param("dyn_routing") && param("dyn_routing") == 1)
{ $dyn_rtn = "1"; }
else
{ $dyn_rtn = "0"; }
###################################################################
# Check for the search radius being reasonable.
###################################################################
if (defined param("mcast_radius") && param("mcast_radius") =~ /\d+/){
if (param("mcast_radius") <= 0){
XB_XML_Interface::show_error "Search radius is invalid", param("mcast_radius"), $myurl;;
}
}
###################################################################
# Check for the host and router types.
###################################################################
my @ostypes = param("host_os");
if ($#ostypes == -1){
XB_XML_Interface::show_error "No host operating system selected",
"Please select one or more host operating systems", $myurl;;
}
foreach my $os (@ostypes){
if ($os !~ /(linux|freebsd|cisco)/){
XB_XML_Interface::show_error "Invalid host operating system $os ", "", $myurl;;
}
}
@ostypes = param("router_os");
if ($#ostypes == -1){
XB_XML_Interface::show_error "No router operating system selected",
"Please select one or more router operating systems", $myurl;
}
foreach my $os (@ostypes){
if ($os !~ /(linux|freebsd|cisco)/){
XB_XML_Interface::show_error "Invalid router host operating system $os ", "", $myurl;
}
}
###################################################################
# Authentication?
###################################################################
if (param("ah") eq ""){ param("ah", "undef"); }
if (param("esp") eq ""){ param("esp", "undef"); }
if(param("ah") ne "undef" or param("esp") ne "undef") {
# if IPsec is enabled, diddle the OS field to use IPsec-capable OS flavors
foreach my $p (qw(host_os router_os)) {
my @newos;
foreach my $os (param($p)) {
if($os eq "linux") { push @newos, "linux"; }
elsif($os eq "freebsd") { push @newos, qw(freebsd); }
elsif($os eq "cisco") { push @newos, "cisco"; }
else {
XB_XML_Interface::show_error "Invalid $1 Operating Systems For IPsec",
"You have chosen IPsec protection of the overlay links, but the ".
$XB_Params::NODEOS_LABEL{$os} . " operating system picked does ".
"not support this.", $myurl;
}
}
# overwrite os flags
param(-name => $p, -value => \@newos);
}
} else {
# if IPsec is not enabled, send a pattern that matches both IPsec
# and non-IPsec flavors of an OS
foreach my $p (qw(host_os router_os)) {
my @newos;
foreach my $os (param($p)) {
if($os eq "linux") { push @newos, qw(linux); }
elsif($os eq "freebsd") { push @newos, qw(freebsd); }
elsif($os eq "solaris") { push @newos, qw(solaris); }
elsif($os eq "cisco") { push @newos, qw(cisco); }
else {
XB_XML_Interface::show_error "Invalid $1 Operating System",
"You have chosen the $XB_Params::NODEOS_LABEL{$os} operating " .
"system, which I know nothing about.", $myurl;
}
}
# overwrite os flags
param(-name => $p, -value => \@newos);
}
}
###################################################################
# Probability loss ratio
# form has probability in %, but need to pass it as a fraction
###################################################################
if (defined param("dn_plr") and param("dn_plr") ne ""){
my $plr = param("dn_plr")/100;
# test for plausability
if ($plr < 0 or $plr > 1)
{
XB_XML_Interface::show_error "Loss Rate Error", "Loss rate probability must be [0..1].", $myurl;
}
}
###################################################################
# Check for the various dummynet variables.
###################################################################
my $t_dn = (param("dn_en_delay") or param("dn_en_bw") or
param("dn_en_q") or param("dn_en_plr") ? "y" : "n");
# dummynet only works on freebsd
if ($t_dn eq "y")
{
foreach my $p (qw(host_os router_os))
{
foreach my $os (param($p))
{
if ($os !~ /(kame|freebsd|cairn|linux)/)
{
XB_XML_Interface::show_error "Invalid OS Choice for Dummynet",
"You have chosen the $XB_Params::NODEOS_LABEL{$os} operating " .
"system and enabled Dummynet.".
"Dummynet doesn't support $XB_Params::NODEOS_LABEL{$os}.", $myurl;
}
}
}
}
if (defined param("dn_en_delay") and param("dn_en_delay") eq "y" ){
if (param("dn_delay") !~ /\d+/){
XB_XML_Interface::show_error "Incorrect link delay specification.", "", $myurl;
};
};
if (defined param("dn_en_bw") and param("dn_en_bw") eq "y" ){
if (param("dn_bw") !~ /\d+/){
XB_XML_Interface::show_error "Incorrect link bandwidth specification.", "", $myurl;
};
};
if (defined param("dn_en_q") and param("dn_en_q") eq "y" ){
if (param("dn_q") !~ /\d+/){
XB_XML_Interface::show_error "Incorrect link queue size specification.", "", $myurl;
};
};
#############################
# Generate API create message
# Construct an prop list
#############################
my ($authtype, $userid, $dns, $cmdref, %args);
%args = ();
###########################################################
# Credentials
###########################################################
$args{auth_type} = "x509";
$args{creator_name} = $user{Name};
$args{creator_email} = $user{Email};
$args{user_name} = $user{Name};
$args{user_email} = $user{Email};
###########################################################
# Overlay-wide Properties
###########################################################
$args{overlay_name} = param ('name') . $suffix;
$args{address_type} = param ('address_type');
$args{topology} = $t;
#the headers have already been checked for the existence.
if (param("custom_netlist") ne ""){
$args{custom_netlist} = get(param("custom_netlist"));
}
if (param("discovery_method") eq "multicast"){
$args{"search_radius"} = param('mcast_radius');
} elsif (param("discovery_method") eq "hostlist"){
$args{custom_hostlist} = LWP::Simple::get(param("custom_hostlist"));
$args{custom_hostlist} =~ s/\s+/ /g;
} elsif (param('discovery_method') eq "ldap"){
$args{ldap} = "yes";
$args{attrvals} = param("attrvals");
$args{attrvals} =~ s/\s+/ /g;
$args{scope} = param("scope");
}
if (param('dns'))
{ $args{dns} = "yes"; }
else
{ $args{dns} = "no"; }
if ($dyn_rtn)
{ $args{dynamic_routing} = 'yes'; }
else
{ $args{dynamic_routing} = 'no'; }
$args{timeout} = param('timeout');
if (defined param("app_script") and param("app_script") ne ""){
my $program;
my $url = param("app_script");
my $file = "/tmp/app-script." . $$ ;
my $rc = mirror($url, $file);
if(is_error($rc)){
XB_XML_Interface::show_error "Internal resource error! Please try again.", "", $myurl;
}
# extract the filename from the URL
if($url =~ /\S+\/(\S+)$/){
$program = $1;
}else{
XB_XML_Interface::show_error "Unable to find application deployment script name. ",
"Should not come here. Contact xbone\@isi.edu", $myurl;
}
my $cksum = `md5 -q $file`;
chomp ($cksum);
my $suid = param("suid");
my %app = (
"program" => $program,
"script" => $url,
"checksum" => $cksum,
"suid" => $suid,
"nodes" => 'all',
"ifaces" => 'all'
);
my %app_arg = (
$app{"program"} => \%app
);
$args{application} = \%app_arg;
unlink($file);
}
###########################################################
# Host and Router properties
###########################################################
$args{hosts} = $h;
$args{host_os} = (join "|", param ('host_os'));
$args{routers} = $r;
$args{router_os} = (join "|", param ('router_os'));
###########################################################
# Link properties
###########################################################
if (param ('ah') eq 'undef')
{ $args{IPsec_authentication} = 'none'; }
else
{ $args{IPsec_authentication} = param ('ah'); }
if (param ('esp') eq 'undef')
{ $args{IPsec_encryption} = 'none'; }
else
{ $args{IPsec_encryption} = param ('esp'); }
if ($t_dn eq "y"){
$args{dummynet} = "yes";
} else {
$args{dummynet} = "no";
}
####### delay
if (defined param("dn_en_delay")){
$args{dummynet_delay} = param("dn_delay");
}
####### bandwidth
if (defined param("dn_en_bw")){
$args{dummynet_bandwidth} = param("dn_bw");
$args{dummynet_bandwidth_unit} = param("dn_bw_u");
}
####### queue length
if (defined param("dn_en_q")){
$args{dummynet_queue} = param("dn_q");
$args{dummynet_queue_unit} = param("dn_q_u");
}
####### probability loss ratio
if (defined param("dn_en_plr")){
# make it a percentage.
$args{dummynet_loss_rate} = param("dn_plr")/100;
}
##################################################################
#
# Now communicate with the OM. And interpret the results.
#
##################################################################
$cmdref = XB_XML_GUI::XB_build_create_overlay_msg (\%args);
# Call the overlay manager
my $xmlresult = XB_XML_Interface::OverlayManagerInterface
(param("manager"), $$cmdref);
# for testing
#my $xmlresult = $canned_success_message;
$xmlresult =~ s/XBoneEOC//g;
# the result is an XML message. parse it to see if it fine.
my $parseresult = XB_XML_scan::XB_XML_parse (\$xmlresult);
if ( $parseresult ne "")
{
XB_XML_Interface::show_error ("Error while parsing the reply of the OM",
$parseresult, $myurl);
};
# construct a hash to simplify the processing later on.
my $hashresult = XB_XML_scan::XB_XML_hash (\$xmlresult);
# Check to make sure that the the parser was able to parse the
# message.
if (! $hashresult) {
XB_XML_Interface::show_error "Invalid response from the Overlay Manager. Please contact" .
"<a href=\"http://www.isi.edu/xbone\">" .
"X-Bone Support</a>", "", $myurl;;
}
# fix the properties list
XB_XML_scan::XB_XOL_xbone_list_sub ($hashresult);
# test the hash
if (!$hashresult or ! $hashresult->{command}){
XB_XML_Interface::show_error "Reply from OM could not be parsed.",
"", $myurl;
}
# see if this is an error. If so, show an error.
if (defined $hashresult->{command}{error_reply}){
my $errmsg = $hashresult->{command}{error_reply}{property}{error};
XB_XML_Interface::show_error "Overlay creation has failed!",
$errmsg, $myurl;
}
# if not error, make sure the message is a create message.
if (not defined $hashresult->{command}{create_overlay_reply}){
XB_XML_Interface::show_error "Dont know how to parse the OM reply!",
"", $myurl;
}
#####################################################################
# Construct the output message. This is really messy. Basically
# extracting the content of the XML message returned into an internal
# structure and using the internal structure to generate a simple xml
# message that can be dumped on the screen.
#####################################################################
my $msg = "content-type: text/xml\n\n";
$msg .= "<?xml version=\"1.0\"?>\n";
$msg .= "<?xml-stylesheet type=\"text/xsl\" href=\"/xml/create-reply-xsl.xml\"?>\n";
$msg .= "<overlay>\n";
# user properties. Ignore the values returned from the reply.
$msg .= "<user>\n";
$msg .= "<name> $user{User} </name>\n";
$msg .= "<location>$user{Location}</location>\n";
$msg .= "<org>$user{Organization}</org>\n";
$msg .= "</user>\n";
$msg .= "<manager>" . param("manager") . "</manager>\n";
# saves code
my $temp = $hashresult->{command}{create_overlay_reply};
$msg .= "<create_overlay_reply>\n";
#high level properties applicable to the entire overlay.
foreach my $prop (keys %{$temp->{property}}){
$msg .= " <$prop>" .
$temp->{property}{$prop} .
"</$prop>\n";
}
$msg .= " <nodes>\n";
foreach my $node (@{$temp->{node}}){
# process nodes - one at a time. print the high level properties of
# the node followed by tunnel details.
$msg .= " <node>\n";
foreach my $prop (keys %{$node->{property}}){
$msg .= " <$prop>" .
$node->{property}{$prop};
$msg .= "</$prop>\n";
}
foreach my $tun (@{$node->{tunnel}}){
$msg .= " <tunnel>\n";
foreach my $prop (keys %{$tun->{property}}){
$msg .= " <$prop>" .
$tun->{property}{$prop} .
"</$prop>\n";
}
$msg .= " </tunnel>\n";
}
$msg .= " </node>\n";
}
$msg .= " </nodes>\n";
$msg .= "</create_overlay_reply>\n";
$msg .= "<host>$host</host>\n";
$msg .= "</overlay>\n";
print $msg;
1;
syntax highlighted by Code2HTML, v. 0.9.1