#!/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" .
	       "&lt;a href=\"http://www.isi.edu/xbone\"&gt;" .
	       "X-Bone Support&lt;/a&gt;", "", $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;