# -*- perl -*-
#
# DO NOT MOVE THE FIRST LINE
# It identifies the rest of the file as PERL for EMACS autoformatting
# put perl options at the end of that line, e.g., -p
#
#
# -------------------------------------------------------------------
# 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_Interface.pm,v $
#
# $Revision: 1.27 $
# $Author: pingali $
# $Date: 2005/04/06 21:53:21 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Lars Eggert
package XB_XML_Interface;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(OverlayManagerInterface);
use strict;
use sigtrap;
use lib qw(../lib);
use Text::ParseWords;
use Getopt::Long;
use AppConfig;
use CGI qw(:standard :html3);
use CGI::Carp qw(fatalsToBrowser);
#use XB_Common;
use Net::IP;
use Net::Netmask;
use Net::hostent;
use IO::Socket;
use IO::Socket::SSL;
use Socket6;
use IO::Socket::SSLv6;
use FileHandle;
use POSIX qw(:errno_h);
use XB_Params;
use Data::Dumper; # Needed only for debugging
use XB_XML_GUI;
############################################################
#
# read the configuration file
#
############################################################
sub init () {
%XB_Params::node_opts =
(
# basic configuration options
"gui_conf" => $XB_Params::gui_conf,
"hostname" => `hostname`,
"ctl_addr" => $XB_Params::ctl_addr,
"ctl_addr6" => $XB_Params::ctl_addr6,
"ipproto" => $XB_Params::ipproto,
"node_cert" => $XB_Params::node_cert,
"node_key" => $XB_Params::node_key,
"ca_cert" => $XB_Params::ca_cert,
"ca_path" => $XB_Params::ca_path,
"xbone_net" => $XB_Params::XBONE_NET,
"timeout" => $XB_Params::NET_TIMEOUT,
"xbone_api_port" => $XB_Params::xbone_api_port
);
my @opts_spec =
(
"gui_conf|gc=s", # this is there more for completeness
"hostname|h=s", # hostname
"ctl_addr|caddr=s", # addr for control connection IPv4
"ctl_addr6|caddr6=s", # addr for control connection IPv6
"ipproto|ip=s",
# X.509 certificate & key info
"node_cert|cert=s",
"node_key|key=s",
"ca_cert|ca=s",
"ca_path|cp=s",
"xbone_net|xn=s",
"timeout|t=s",
"xbone_api_port|api=i",
);
my $file_opts = AppConfig->new(@opts_spec);
$file_opts->file($XB_Params::node_opts{gui_conf});
# this might die #
#=> merge command line options & conf file options
for my $n (keys %XB_Params::node_opts){
$XB_Params::node_opts{$n} =
(defined $file_opts->get($n)) ?
$file_opts->get($n) : $XB_Params::node_opts{$n};
}
if ((not defined ($XB_Params::node_opts{ctl_addr}) ||
$XB_Params::node_opts{ctl_addr} eq "") &&
$XB_Params::node_opts{ipproto} =~ /(ipv4|both)/){
$XB_Params::node_opts{ctl_addr} =
getaddr($XB_Params::node_opts{hostname}, 'ipv4');
}
if ((not defined ($XB_Params::node_opts{ctl_addr6}) ||
$XB_Params::node_opts{ctl_addr6} eq "") &&
$XB_Params::node_opts{ipproto} =~ /(ipv6|both)/){
$XB_Params::node_opts{ctl_addr6} =
getaddr($XB_Params::node_opts{hostname}, 'ipv6');
}
}
############################################################
#
# retrieve the information stored in the environment variables
# in a convenient form.
#
############################################################
sub user_info() {
my ($email, $name, $org, $loc) = ("")x4;
if (defined $ENV{SSL_CLIENT_EMAIL} and $ENV{SSL_CLIENT_EMAIL} ne ""){
$email = $ENV{SSL_CLIENT_EMAIL};
} elsif (defined $ENV{SSL_CLIENT_S_DN_Email} and
$ENV{SSL_CLIENT_S_DN_Email} ne ""){
$email = $ENV{SSL_CLIENT_S_DN_Email};
} elsif (defined $ENV{SSL_CLIENT_S_DN_EMAILADDRESS} and
$ENV{SSL_CLIENT_S_DN_EMAILADDRESS} ne ""){
$email = $ENV{SSL_CLIENT_S_DN_EMAILADDRESS};
} else {
$email = "";
}
if (defined $ENV{SSL_CLIENT_CN} and $ENV{SSL_CLIENT_CN} ne ""){
$name = $ENV{SSL_CLIENT_CN};
} elsif (defined $ENV{SSL_CLIENT_S_DN_CN} and
$ENV{SSL_CLIENT_S_DN_CN} ne ""){
$name = $ENV{SSL_CLIENT_S_DN_CN};
} else {
$name = "";
}
if (defined $ENV{SSL_CLIENT_O} and $ENV{SSL_CLIENT_O} ne ""){
$org = $ENV{SSL_CLIENT_O} .
($ENV{SSL_CLIENT_OU} ? ", $ENV{SSL_CLIENT_OU}" : "");
} elsif (defined $ENV{SSL_CLIENT_S_DN_O} and
$ENV{SSL_CLIENT_S_DN_O} ne ""){
$org = $ENV{SSL_CLIENT_S_DN_O} .
($ENV{SSL_CLIENT_S_DN_OU} ? ", $ENV{SSL_CLIENT_S_DN_OU}" : "");
} else {
$org = "";
}
if (defined $ENV{SSL_CLIENT_L} and $ENV{SSL_CLIENT_L} ne ""){
$loc = $ENV{SSL_CLIENT_L};
} elsif (defined $ENV{SSL_CLIENT_S_DN_L} and
$ENV{SSL_CLIENT_S_DN_L} ne ""){
$loc = $ENV{SSL_CLIENT_S_DN_L};
} else {
$loc = "";
}
my %user = ( User => "$name <" .
a({-href => "mailto:$email"},
$email) . ">",
Organization => $org,
Location => $loc,
Email => $email,
Name => $name
);
return %user;
}
#############################################################
# Copied from programs/modules/XB_Common.pm
#
# 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:
# "getaddrinfo" on failure, nothing to cleanup by caller
#############################################################
sub getaddr($$){
my ($hostname, $ipproto) = @_;
my $procname = "getaddr";
my @addrs;
eval{
unless($hostname =~ /\S+/){ die "hostname"; }
unless($ipproto =~ /(ipv6|ipv4)/){ 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){ die "getaddrinfo"; };
} else {
@res = getaddrinfo($hostname,
'daytime', # dummy service
AF_INET6);
unless(scalar(@res) >= 5){ 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);
push @addrs, $addr;
}
unless(@addrs > 0){ die "noaddr"; }
}; #eval
return \@addrs unless $@;
die "$procname";
}
################################################################
#
# Contact the OM with the message passed as argument to the
# funtion.
#
################################################################
sub OverlayManagerInterface($$) {
my $peer = shift;
my $str = shift;
my $buf = "";
my $return_string = "";
my $routeraddr;
my %user = user_info();
my %cred = (
'user_name' => $user{Name},
'user_email' => $user{Email},
'auth_type' => 'x509'
);
# Open a connection to the overlay manager, send it the prepared
# string, and get the response string back
my $tcph;
my $msg = "";
foreach my $location (
"$XB_Params::node_opts{node_cert}",
"$XB_Params::node_opts{node_key}",
"$XB_Params::node_opts{ca_cert}",
"$XB_Params::node_opts{ca_path}"){
unless (-e "$location" and -r "$location")
{
$msg .= "\n $location,";
};
}
if ($msg ne "") {
my $hostname = `hostname`;
chomp($hostname);
$_ = XB_XML_GUI::XB_build_api_errmsg
( \%cred, "The GUI backend on host $hostname is either missing or unable to read the ".
"the following files necessary for ".
"communicating with the Overlay Manager: " . $msg .
" Please update /usr/local/etc/xbone/xbone-gui.conf with the correct locations.");
return ($$_);
};
my $n = Net::IP->new($peer);
if (defined $n){
$_ = XB_XML_GUI::XB_build_api_errmsg
(\%cred,
"Please use hostname instead of IP address");
return ($$_);
}
# allow the user to specify a name and a port
my ($peerhost, $peerport);
if ($peer =~ /:/){
($peerhost, $peerport) = split(':', $peer);
} else {
($peerhost, $peerport) = ($peer, $XB_Params::node_opts{xbone_api_port});
}
my $errmsg = "";
eval {
$tcph = IO::Socket::SSL->new(
PeerAddr => $peerhost,
PeerPort => $peerport,
LocalAddr => $XB_Params::node_opts{ctl_addr},
Proto => 'tcp',
Reuse => 1,
SSL_use_cert => 1,
SSL_verify_mode => 0x03,
SSL_cert_file => $XB_Params::node_opts{node_cert},
SSL_key_file => $XB_Params::node_opts{node_key},
SSL_ca_file => $XB_Params::node_opts{ca_cert},
SSL_ca_path => $XB_Params::node_opts{ca_path},
);
};
if ($@) {
$errmsg = $@;
}
if (not defined $tcph){
eval {
my $addrs = getaddr($peerhost, 'ipv6');
foreach my $dest (@{$addrs}){
$tcph = IO::Socket::SSLv6->new(
PeerAddr => $dest,
PeerPort => $peerport,
LocalAddr => $XB_Params::node_opts{ctl_addr6},
Proto => 'tcp',
Reuse => 1,
SSL_use_cert => 1,
SSL_verify_mode => 0x03,
SSL_cert_file => $XB_Params::node_opts{node_cert},
SSL_key_file => $XB_Params::node_opts{node_key},
SSL_ca_file => $XB_Params::node_opts{ca_cert},
SSL_ca_path => $XB_Params::node_opts{ca_path}
);
last if $tcph;
} # foreach destination ip address
}; # eval
$errmsg .= $@;
};
unless ($tcph)
{
$_ = XB_XML_GUI::XB_build_api_errmsg ( \%cred,
"Cannot open socket to $peerhost:$peerport. $!. " .
"Suspect Overlay Manager is down or does not " .
"support the IP version specified in GUI configuration file. ".
"Do check whether both the webserver host and the manager's".
" host support the ip version specified in the configuration file");
return ($$_);
};
print $tcph "$str\n XBoneEOC \n";
# Select to wait until the socket becomes ready to read
my $start_time = time;
my $total_time = $XB_Params::node_opts{timeout};
my ($inputflags, $errorflags, $iflg, $eflg) = ("") x 4;
vec ($inputflags, $tcph->fileno, 1) = 1;
$errorflags = $inputflags;
while (1)
{
my $events =
select($iflg = $inputflags, undef, $eflg = $errorflags, $total_time);
# When something (either the socket or the timer goes off
if (vec ($iflg, $tcph->fileno, 1))
{
# Make the read call non-blocking so we can avoid getting blocked
# if the other end crashes
fcntl($tcph, F_SETFL, O_NDELAY);
my ($buf, $byte_read);
# do sysread until it returns either 0 (EOF) or undef (error)
if(defined($byte_read = sysread($tcph, $buf, 1000)))
{
unless($byte_read == 0){ $return_string .= $buf; }
}
if (defined $return_string and $return_string =~ /\bXboneEOC\b/)
{ last; }
# check for error condition of sysread
if (not defined $byte_read)
{
if (defined $!)
{
if ($! == EWOULDBLOCK)
{
undef $!; # clean up error flag for the next round
next; # since we loop back to select, no need to sleep
}
elsif ($! != 0)
{
# some other error
my $errno = $! + 0; # Force numeric context
$_ = XB_XML_GUI::XB_build_api_errmsg (\%cred,
"$errno: $!. " .
"This is wierd. Don't expect anything except " .
"EWOULDBLOCK here.");
$return_string = $$_;
last;
}
else
{ # $!=0 => EOF
last;
}
} else
{ # undefined $! => EOF
last;
}
}
elsif ($byte_read == 0)
{ # byte_read = 0 => EOF
last;
}
if(time > $start_time + $total_time)
{
$_ = XB_XML_GUI::XB_build_api_errmsg (\%cred,
"Non-blocking read from Overlay " .
"Manager timed out.".
"Consider increasing the timeout setting".
"in the X-Bone GUI configuration file (typically ".
"xbone-gui.conf)");
return ($$_);
}
}
elsif (vec ($eflg, $tcph->fileno, 1))
{
$_ = XB_XML_GUI::XB_build_api_errmsg (\%cred,
"IO error on TCP socket. $!.");
return ($$_);
}
else
{
# Must be due to time limit.
$_ = XB_XML_GUI::XB_build_api_errmsg (\%cred,
"Select to overlay manager timed out. ".
"Consider increasing the timeout setting".
"in the X-Bone GUI configuration file (typically ".
"xbone-gui.conf)");
return ($$_);
}
}
$tcph->close();
if ($return_string eq "")
{
$_ = XB_XML_GUI::XB_build_api_errmsg (\%cred,
"Null message from Overlay Manager. There are a couple" .
" of possibilities. (1) The operation (create/discover)".
" timed out. (2) The overlay manager might have crashed\n");
return ($$_);
}
return ($return_string);
}
sub show_success ($$$) {
my ($success, $extra, $url) = @_;
my $host = `uname -n`;
chomp($host);
if (defined $extra) { $success .= " " . $extra; }
my $msg = "content-type: text/xml\n\n";
#my $msg = "content-type: text/plain\n\n";
$msg .= "<?xml version=\"1.0\"?>\n";
$msg .= "<?xml-stylesheet type=\"text/xsl\" href=\"/xml/error-xsl.xml\"?>\n";
$msg .= "<success>\n";
$msg .= " <source>$url</source>\n";
$msg .= " <message>$success</message>\n";
$msg .= " <manager>" . param("manager") . "</manager>\n";
$msg .= " <host>$host</host>\n";
$msg .= "</success>\n";
print $msg;
exit;
}
sub show_error ($$$){
my ($error, $extra, $url) = @_;
my $host = `uname -n`;
chomp($host);
if (defined $extra) { $error .= " " . $extra; }
$error =~ s/\</\<\;/sg;
$error =~ s/\>/\>\;/sg;
my $msg = "content-type: text/xml\n\n";
$msg .= "<?xml version=\"1.0\"?>\n";
$msg .= "<?xml-stylesheet type=\"text/xsl\" href=\"/xml/error-xsl.xml\"?>\n";
$msg .= "<error>\n";
$msg .= " <source>$url</source>\n";
$msg .= " <message>$error</message>\n";
$msg .= " <manager>" . param("manager") . "</manager>\n";
$msg .= " <host>$host</host>\n";
$msg .= "</error>\n";
print $msg;
exit;
}
1;
syntax highlighted by Code2HTML, v. 0.9.1