#! /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-mcast-conf.pl,v $
#
# $Revision: 1.16 $
# $Author: pingali $
# $Date: 2005/03/31 07:04:03 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Venkata Pingali
use strict;
use sigtrap;
use lib qw(../lib);
use CGI qw(:standard :html3);
use CGI::Carp qw(fatalsToBrowser);
use Apache2();
use Apache::SubProcess qw(system);
use Mail::Sendmail;
use Net::Netmask;
use XB_Common;
use Net::IP;
##################################################################
# This script will update the /etc/mrouted.conf file -- add or
# delete entries.
##################################################################
#constants
my $our_router = qw(128.9.168.66);
my @our_networks = qw(128.9.160.0/20 128.9.112.0/20);
$ENV{"PATH"} = "/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin:/usr/local/sbin";
# which form fields correspond to which user cert fields
my %field = ( emailAddress => $ENV{SSL_CLIENT_S_DN_Email},
commonName => $ENV{SSL_CLIENT_S_DN_CN},
IpAddr => "",
Network => "",
Operation => "Show"
);
# init params from cert if they're undefined
foreach my $v ( keys(%field) ) {
unless(defined param($v)) { param($v, $field{$v}); }
#print "$v -> \"", param($v), "\" <br>";
}
# redirect to secure port if user came in on insecure one
my $url = self_url;
unless($url =~ /https/) {
$url =~ s/http/https/;
print redirect($url);
exit(0);
}
# the ip address of the remote router and the remote network
# have been entered.
my $process_mcast_request = sub {
my $retmsg = "";
# for some strange reason you have to create temporary variables
# that store values extracted from the param() calls.
my $net = param("Network");
my $prefix = new Net::IP($net);
my $ipaddr = param("IpAddr");
my $ipaddress = new Net::IP($ipaddr);
my $op = param("Operation");
#print "net = $net ";
#print "prefix: ", ((defined $prefix) ? "defined" : "Undefined");
#print "ipaddr: ", ((defined $ipaddress) ? "defined" : "Undefined");
my $ip = (defined $ipaddress) ? $ipaddress->ip() : "0.0.0.0";
my $base = (defined $prefix) ? $prefix->ip() : "0.0.0.0";
my $bits = (defined $prefix) ? $prefix->prefixlen() : 0;
##########################################
# next a series of checks for the input values...
##########################################
# make sure you have the correct inputs...
my $errtype = 0;
my $error = "";
#Print "ipaddress = $ip", $ipaddress->iptype(), "prefixlen = ", $ipaddress->prefixlen(), "\n";
if ( $op ne "Show" and $op ne "Create" and $op ne "Delete"){
die("Incorrect Operation");
}
if ( not defined $ipaddress or
$ipaddress->prefixlen() != 32 or
$ipaddress->iptype() eq "RESERVED" or
$ipaddress->iptype() eq "PRIVATE"
){
$errtype++;
param("IpAddr", "");
$error .= "IP Address has wrong format or is reserved. <br>";
}
if (not defined $prefix or
$prefix->iptype() eq "RESERVED" or
$prefix->iptype() eq "PRIVATE"
){
param("Network", "");
$errtype++;
#$error .= (defined $prefix) ? $prefix->iptype() : "Undefined";
$error .= "Network prefix has wrong format or is reserved. <br>";
}
# show requires only one of the two parameters to be defined.
if ((($op eq "Show") and ($errtype == 2)) or
(($op ne "Show") and ($errtype > 0))){
#atleast one should be specified
die($error);
}
# check to make sure that our ip addresses and networks are not specified.
my $ourprefix;
foreach $ourprefix (@our_networks){
my $net = new Net::Netmask($ourprefix);
if ($net->match($ip) or $net->match($base)){
die("You must specify non-ISI ip address/network");
}
} # for..
##########################################
# It is not clear why this should be here but
# left it here for now. TODO: cleanup.
##########################################
if (param("IpAddr") eq ""){ param("IpAddr", "0.0.0.0"); }
if (param("Network") eq ""){ param("Network", "0.0.0.0/32"); }
# now process the input files...
my $file = "/etc/mrouted.conf";
open CONF, "<$file" || die("Cannot open the configuration file");
my $newfile = "/tmp/mrouted.conf.new";
my $status = 0;
eval {
if ($op eq "Create"){
open CONFNEW, ">$newfile" || die("Cannot open temporary file ");
###############################################################
# status = 0 => no phyint (physical interface) lines seen as yet
# status = 1 => phyint lines seen
# status = 2 => phyint line added
# status = 3 => have seen tunnel entries
# status = 4 => end of tunnel entries
# status = 5 => have seen a tunnel entry to the same destination.
# so add the destination network prefix.
###############################################################
my $interface = "";
while ( <CONF> )
{
SWITCH: {
(/^\#/ || /^\s*$/) and do {
if ($status == 1){
# we are at the end of the phyint section.
# so introduce a new phyint line
print CONFNEW "phyint $interface deny $base/$bits bidir\n";
$status = 2;
} elsif ($status == 3) {
# we have come to the end of the tunnels section.
# so add the tunnel lines...
print CONFNEW
"tunnel $our_router $ip metric 1 threshold 1 " .
"rate_limit 50 accept $base/$bits\n";
$retmsg .= p("\nThe following route entry created at ISI. ".
"Please add a corresponding entry at your ".
"router. Route entry added to ISI-end router's ".
i("mrouted") . " configuration file is\n\n");
$retmsg .= p({-class => "normalheader", -align => "center"},
"tunnel $our_router $ip metric 1 threshold 1 ".
" rate_limit 50 accept $base/$bits");
$retmsg .= p("\nAn example entry in your " . i("mrouted") .
" configuration file is\n\n");
$retmsg .= p({-class => "normalheader", -align => "center"},
"tunnel $ip $our_router metric 1 threshold 8 ".
" rate_limit 50 accept @our_networks bidir");
$status = 4;
}
last SWITCH;
};
/phyint/ and do {
# started seeing the phyint entries...
if (/$base/) { die("Route entry to the destination network already exists\n"); }
if ($status == 0) {
my @components = split /\s+/;
$interface = $components[1];
$status = 1;
}
last SWITCH;
};
/tunnel/ and do {
# started seeing the tunnel entries...
# make sure that you have seen the phyint entries...
if ($status < 2) {
die ("Internal Error: Did not find phyint entry ");
}
# ok. have seen the phyint entry.
# does this tunnel entry to the same destination
# router?
if (/$ip/ and not /$base/) {
# there exists a line for the remote router. so
# update the entry here by appending the network
# prefix.
chomp($_);
$_ .= " $base/$bits\n";
$status = 5;
$retmsg .= p("\nThe following route entry created at ISI. Please add a corresponding \n" .
"entry at your router. Route entry added to ISI-end router's \n". i("mrouted") .
" configuration file is\n\n");
$retmsg .= p({-class => "normalheader", -align => "center"},
"$_");
$retmsg .= p("\n\nAn example entry in an your " .
i("mrouted") . " configuration file is\n\n");
$retmsg .= p({-class => "normalheader", -align => "center"},
"tunnel $ip $our_router metric 1 threshold 8 \n".
" rate_limit 50 accept @our_networks bidir\n");
} else {
# no overlapping entry exists...
if (/$base/) {
die("Overlapping network entry already exists $base\n");
} else {
$status = 3;
}
}
last SWITCH;
}; # tunnel
} # end switch....
print CONFNEW $_;
}; # while...
if ($status == 2 || $status == 3 ){
# havent seen any tunnel commands or in the process of
# skipping all the tunnels, I have come to the end.
print CONFNEW
"tunnel $our_router $ip metric 1 threshold 1 " .
"rate_limit 50 accept $base/$bits\n";
$retmsg .= p("\nThe following route entry created at ISI. Please add a corresponding \n" .
"entry at your router. Route entry added to ISI-end router's \n". i("mrouted") .
" configuration file is\n\n");
$retmsg .= span({-class => "whitefg"},
"<blockquote>tunnel $our_router $ip metric 1 threshold 1 \n".
" rate_limit 50 accept $base/$bits\n</blockquote>");
$retmsg .= p("\n\nAn example entry in an your " . i("mrouted") .
" configuration file is\n\n");
$retmsg .= span({-class => "whitefg"},
"<blockquote>tunnel $ip $our_router metric 1 threshold 8 \n".
" rate_limit 50 accept @our_networks bidir\n </blockquote>");
}
} elsif ($op eq "Delete") {
# delete
open CONFNEW, ">$newfile" || die("Cannot open temporary file ");
WHILE: while ( <CONF> )
{
SWITCH: {
(/^\#/ || /^\s*$/) and do {
last SWITCH;
};
/phyint/ and do {
if (/$base\/$bits/){
$status=1;
#$retmsg .= $_ . "<br>";
next WHILE;
}
last SWITCH;
}; #end phyint
/tunnel/ and do {
# started seeing the tunnel entries...
if ($status < 1) {
die ("No entries corresponding to input found in".
" mrouted.conf.");
}
if (/$ip/ and /$base\/$bits/){
# first remove the network specified
$_ =~ s/$base\/$bits//;
# see if this the last network to which this router is
# used to connect.
/accept\s+$/ and do {
# dont save the modified $_
$status = 2;
$retmsg .= p("Multicast route entry deleted.");
next WHILE;
};
$status = 2;
$retmsg .= p("Multicast route entry modified.");
}
last SWITCH;
}; # end tunnel
} # end switch....
print CONFNEW $_;
} # while...
} elsif ($op eq "Show") {
#print "base = $base bits = $bits ip = $ip <br>";
my @entries = (Tr({-class => "secheader"},
td("From") . td("To") . td("Network(s)")));
#push @entries, Tr(th({-colspan => 3}, hr));
WHILE: while ( <CONF> )
{
next if (/^\#/ || /^\s*$/);
next if (/phyint/);
# these are the tunnel messages then...
if ((($base ne "0.0.0.0") and /$base\/$bits/)
|| (($ip ne "0.0.0.0") and /$ip/)){
my ($localend, $remoteend, $remotenetworks) = () x 3;
my @arr = split /\s+/;
shift @arr;
$localend = shift @arr;
$remoteend = shift @arr;
while ($arr[0] ne "accept" and $arr[0] ne "") { shift @arr; };
shift @arr; # drop accept;
if ($#arr == 0) {
$remotenetworks = shift @arr;
} else {
$remotenetworks = join(",", @arr);
}
push @entries, Tr({-class => "normalheader"},
td("$localend") .
td("$remoteend") .
td("$remotenetworks"));
}
} # while ....
$retmsg .= table({-border => 1,
-cellspacing => 5, -cellpadding => 5},
@entries);
} # show...
}; # eval...
close(CONF);
close(CONFNEW);
if ($@){
unlink($newfile);
die($@);
} elsif ($op ne "Show"){
# copy the contents
open CONF, ">$file" || die("Cannot open the configuration file");
open CONFNEW, "<$newfile" || die("Cannot open the configuration file");
while (<CONFNEW>){
print CONF $_;
}
close(CONF);
close(CONFNEW);
unlink($newfile) || die("Cannot unlink the $file");
}
return $retmsg;
};
# die if we cannot authenticate the user
#unless(CGI::https()) {
# fail_page "Secure Connection Required",
# "Host certificates must be requested over a secure, " .
# "authenticated connection.";
#}
# if we have all required parameters, process request, else display form
my $showmainpage = 1;
my $retmsg = "";
eval {
if((param("IpAddr") ne "") or (param("Network") ne "")){
$retmsg = &$process_mcast_request;
#everything was successful. otherwise process_mcast_request would
# have thrown an exception.
$showmainpage = 0;
my $op = param("Operation");
if ($op ne "Show"){
# show the result of the operation..
print header,
start_html(-title => "Request Succeeded",
-style => { -src =>"/xml/xbone.css" }),
h1({-class => "secheader"},
"Router Configuration Modified. "),
$retmsg,
a({-href=>"/cgi-bin/xb-mcast-conf.pl"}, "Back"),
end_html;
} else {
print header,
start_html(-title => "Request Succeeded",
-style => { -src =>"/xml/xbone.css" }),
h1({-class => "secheader"},
"Matching Multicast Route Entries"),
p("The following entries matched your request:"),
$retmsg,
a({-href => "/cgi-bin/xb-mcast-conf.pl"}, "Back"),
end_html;
}
} # retms
}; #eval...
##########################################################
# Log the update and also send a mail.
#
##########################################################
if (((param("IpAddr") ne "") or (param("Network") ne ""))
and (param("Operation") ne "Show")){
# log the request
my $email = param("emailAddress");
my $sender = param("commonName");
my $header = "User: $sender <$email>\n" .
"Request = ". param("Operation"). "\n".
"Local Router's address: $our_router\n" .
"Remote Router's address = ". param("IpAddr"). "\n".
"Remote Network = ". param("Network"). "\n";
my $logfile = "/nfs/jade/xbone/xtend-logs/ww-xbone.log";
open LOG, ">>$logfile" || die("Cannot open the file");
print LOG "**\n";
print LOG $header;
my $message;
if ($@) {
$message = "Result: Error\n$@ \n";
} else {
$message = "Result: Success\n$retmsg \n";
}
# remove all the html tags to make the message plain text.
$message =~ s/<[^>]*>//g;
my $date= `/bin/date "+%m/%d/%Y"`;
if ($date =~ /(\d+\/\d+\/\d+)/){
$date = $1;
} else {
$date = "";
}
print LOG "Date:$date\n";
print LOG "$message\n**\n";
close LOG;
# mail only successful form fills
if (not $@) {
# send an email with the same information.
my %letter = ( #To => "XBone <xbone\@isi.edu>",
From => "$sender <$email>",
To => "$sender <$email>",
Subject => "Multicast Tunnel (De)Configured",
Message => "$header$message"."\n\nlogfile: $logfile\n",
smtp => "boreas.isi.edu"
);
unless (Mail::Sendmail::sendmail(%letter)) {
fail_page "Error Sending Mail",
p("Could not send email: $Mail::Sendmail::error");
}
} # end if...
}
###########################################################
# If the processing has happened successfully and operation is a
# not a readonly operation (show), then HUP the mrouted daemon.
###########################################################
if (! $@ && ! $showmainpage){
if (param("Operation") ne "Show"){
# from XB_Common.pm
my $base_dir = $ENV{'DOCUMENT_ROOT'};
if ($base_dir =~ /^((\/([[:alnum:]]|[-_\.])*)*)$/) { $base_dir = $1; }
else { die "tainted: $base_dir"; }
$base_dir =~ s/\/(s-)?htdocs//;
my $hupscript = "$base_dir/s-cgi-bin/mroutedctl.pl";
if (! -e $hupscript || -x $hupscript){
# assume that the mroutedctl is in the s-cgi-bin directory
my $status = `$hupscript`;
if ($status ne "") {
die("Couldnt restart the server.");
}
}
}
exit(0);
}
##############################################################
# Show the main page with error messages, if necessary.
##############################################################
my $errmsg = $@;
$errmsg =~ s/ at .*$//;
my $title = "Configure Multicast Tunnel to X-Bone Network";
print header, start_html(-title => $title,
-style => {-src =>"/xml/xbone.css"}).
h1({-class => "secheader"}, $title),
p("You can use this web page to view/modify the multicast router ".
"configuration at ".
"ISI to tunnel X-Bone related multicast traffic to your site. ".
"We use " . a({-href => "http://www.freebsd.org"}, 'FreeBSD') .
" " . i("mrouted") . ". The following operations are supported:" ),
ol(li(strong("Show") .
": Show entries that match the non-ISI end router's IP address ".
"and/or network prefix"),
li(strong("Create"), ": Create a multicast tunnel to a remote node"),
li(strong("Delete"), ": Delete a multicast tunnel to a remote node")
),
p("In case of a create/delete, upon successful execution, the next" .
"page will show the entries created at ISI end and sample " .
i("mrouted") . " entries that must be created at your end"),
p("<br>"),
p("Note: Email address has been initialized with information from your user ",
"certificate. Note that you cannot change this ",
"entry; You must fill out ",
span({-class => "redbg"}, "all remaining red fields")),
p(span({-class => "redbg"}, i($errmsg))),
startform(-action => url(-relative => "1"), -method => "post"),
table(
Tr(th({-class => "secheader", -colspan => "2"}, " Configure Multicast Tunnel")),
Tr(th({-class => "secheader"}, "Contact E-Mail"),
td({-class => "normalheader"}, (tt(param("emailAddress"))))),
Tr(th({-class => "secheader"}, "Your Multicast Router's" . br . "IP Address"),
td({-class => "normalheader"},
textfield(-name => "IpAddr", -size => "18", -maxlength => "32"))),
Tr(th({-class => "secheader"}, "Operation"),
td({-class => "normalheader"},
popup_menu(-name => "Operation",
-value => {"Create" => "Create",
"Delete" => "Delete",
"Show" => "Show" }))),
Tr(th({-class => "secheader"}, "Your Network Prefix"),
td({-class => "normalheader"},
textfield(-name => "Network", -size => "18",
-maxlength => "32")))),
submit(-class => "normalheader",
-name => "SUBMIT",
-value => "Submit Multicast Configuration Request"), " ",
CGI::reset({-class => "normalheader"}, "Undo Changes"), end_form,
p("Back to the ", a({-href => "/"}, "X-Bone Control Page") . "."),
end_html;
1;
syntax highlighted by Code2HTML, v. 0.9.1