#!/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-discover.pl,v $
#
# $Revision: 1.24 $
# $Author: pingali $
# $Date: 2005/04/10 01:26:55 $
# $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;} }
};
#use XB_Common;
use XB_XML_Interface;
use XB_XML_GUI;
use XB_XML_scan;
use Data::Dumper;
my $host = `uname -n`;
chomp($host);
XB_XML_Interface::init();
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;
};
############################################################
# fix some variables before you proceed.
############################################################
my $canned_success_message =
'<!DOCTYPE xbone SYSTEM "http://www.isi.edu/xbone/software/xbone/api-1.0.dtd">
<xbone version="1.5" release="2.0">
<credential>
<property prop="user_name" value="Test User"/>
<property prop="user_email" value="dummy@dummy.com"/>
<property prop="auth_type" value="x509"/>
</credential>
<command>
<discover_daemons_reply>
<property prop="creator_name" value=""/>
<property prop="creator_email" value=""/>
<node>
<property prop="dns" value="no"/>
<property prop="IPsec" value="yes"/>
<property prop="hostname" value="d.postel.org"/>
<property prop="qos" value="no"/>
<property prop="NODEOS" value="freebsd"/>
<property prop="os_version" value="4.7-release"/>
<property prop="kernel" value="470000"/>
<property prop="ipproto" value="ipv4"/>
<property prop="xol_vers" value="1.4"/>
<property prop="routing" value="static"/>
<property prop="node_type" value="host"/>
<property prop="ctl_addr" value="128.9.112.68"/>
<property prop="tunnel" value="0"/>
<property prop="app_addr" value="128.9.112.68"/>
<property prop="overlay" value="0"/>
</node>
<node>
<property prop="dns" value="no"/>
<property prop="IPsec" value="yes"/>
<property prop="hostname" value="e.postel.org"/>
<property prop="qos" value="no"/>
<property prop="NODEOS" value="freebsd"/>
<property prop="os_version" value="4.8-release"/>
<property prop="kernel" value="480000"/>
<property prop="ipproto" value="ipv4"/>
<property prop="xol_vers" value="1.4"/>
<property prop="routing" value="static"/>
<property prop="node_type" value="router"/>
<property prop="ctl_addr" value="128.9.112.69"/>
<property prop="tunnel" value="0"/>
<property prop="app_addr" value="128.9.112.69"/>
<property prop="overlay" value="0"/>
</node>
</discover_daemons_reply>
</command>
</xbone>
XBoneEOC';
my %user = XB_XML_Interface::user_info();
my $myurl = "/cgi-bin/xb-xml-discover.pl";
my $indexurl = "/cgi-bin/xb-xml-index.pl";
############################################################
# Show error messages
############################################################
# make sure that the manager is selected
if (not defined param("manager")){
XB_XML_Interface::show_error "Please specify the overlay manager.", "", $indexurl;
}
# show the window in case this is the first time or one of the two
# entries is not defined.
#if(not defined param("timeout") or not defined param("mcast_radius"))
if(not defined param("timeout") or
(param("discovery_method") !~ /(multicast|hostlist|ldap)/))
{
# set them to some initial value if there is no history
if (not defined param("timeout")){ param("timeout", 5); }
if (not defined param("mcast_radius")){ param("mcast_radius", 3); }
my $msg = "content-type: text/xml\n\n";
$msg .= "<?xml version=\"1.0\"?>\n";
$msg .= "<?xml-stylesheet type=\"text/xsl\" href=\"/xml/discover-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>" . param("manager"). "</manager>\n";
$msg .= "<discover>\n";
$msg .= " <timeout>" . param("timeout") . "</timeout>\n";
$msg .= " <search-radius>" . param("mcast_radius") . "</search-radius>\n";
$msg .= " <hostlist/>\n";
$msg .= " <ldap></ldap>\n";
$msg .= "</discover>\n";
$msg .= "<host>$host</host>\n";
$msg .= "</overlay>\n";
print $msg;
exit;
}
# ok. we have the inputs. Check them to make sure that they are ok.
###################################################################
# Check the timeout
###################################################################
if (param("timeout") !~ /\d+/)
{
XB_XML_Interface::show_error "Incorrect timeout specification.", "", $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);
};
};
#######################################
# Generate API discover daemons message
#######################################
my ($cmdref, $result, $userid, $authtype);
# gather the basic information for construction of a search request.
if(CGI::https())
{ $userid = $user{Email}; $authtype='x509'; }
else
{ $userid = $ENV{REMOTE_ADDR}; $authtype = 'ipaddr'; };
my %args = ("auth_type" => $authtype,
"creator_name" => $user{Name},
"creator_email" => $user{Email},
"timeout" => param('timeout'),
"user_id" => $userid,
"user_name" => $user{Name},
"user_email" => $user{Email},
);
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");
}
# construct a discover request
$cmdref = XB_XML_GUI::XB_build_discover_daemons_msg (\%args);
# send it to the OM
$result = XB_XML_Interface::OverlayManagerInterface
(param("manager"),$$cmdref);
# use the canned message for testing only.
#$result = $canned_success_message;
$result =~ s/XBoneEOC//g;
#########################################
# ok we have the result.
# parse the result of communication with the OM.
#########################################
# the result is an XML message. parse it to see if it fine.
my $parseresult = XB_XML_scan::XB_XML_parse (\$result);
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 (\$result);
# 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;
}
#########################################
# Check if the result is error and print it out.
# Otherwise show the results.
#########################################
#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 "Discover daemons - Error while executing command!", $errmsg, $myurl;
}
# the discovery has happened and now we have to parse the results and
# display them.
# 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/discover-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}{discover_daemons_reply};
$msg .= "<discover_daemons_reply>\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} .
"</$prop>\n";
}
$msg .= " </node>\n";
}
$msg .= " </nodes>\n";
$msg .= "</discover_daemons_reply>\n";
$msg .= "<host>$host</host>\n";
$msg .= "</overlay>\n";
print $msg;
1;
syntax highlighted by Code2HTML, v. 0.9.1