### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
#
# -------------------------------------------------------------------
# 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_Utils.pm,v $
#
# $Revision: 1.7 $
# $Author: pingali $
# $Date: 2005/03/31 07:04:00 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Authors: Yu-Shun Wang
# Original Authors: Anindo Banerjea, Gregory Finn
#
# Utility functions for XBone:
#
# - SSL socket functions
#
#############################################
#
# Common utilities used by XBONE Perl modules.
#
#############################################
package XB_Utils;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(XB_mcast_recv_socket XB_udp_socket
XB_obsolete XB_banner_msg);
@EXPORT_OK = qw(ssl_grep_cert ssl_accept);
use strict;
use sigtrap;
use Socket;
use Time::Local;
use XB_Params;
use XB_Log;
##############################
#
# XB_mcast_recv_socket ( \fh, ip_iface, mcast_addr, mcast_port )
#
# Obtains a multicast receive socket that is associated with the IP
# interface passed in ip_iface. The multicast address is passed by
# mcast_addr and the port by mcast_port.
#
# ip_iface is a string and may be either a recognized host name or a
# dotted decimal address. If it is NULL, the INADDR_ANY address is
# substituted.
#
# The filehandle used to attach to the socket is passed by reference
# in \fh.
##############################
sub XB_mcast_recv_socket ($$$$)
{
my ($fh, $ip_iface, $mcast_addr, $mcast_port) = @_;
my $subrname = "XB_mcast_recv_socket";
my ($mcastaddr, $ipaddr, $mcastport, $conn_protonumber);
XB_Log::log ("info", "->$subrname (@_)");
if ($ip_iface)
{
# IPv6 arg: inet_aton
unless ($ipaddr = inet_aton ($ip_iface))
{ die "Cannot resolve IP address.\n"; };
}
else { $ipaddr = INADDR_ANY; };
unless ($mcastaddr = inet_aton ($mcast_addr))
{ die "Cannot resolve mcast_addr.\n"; };
$mcast_port = pack_sockaddr_in ($mcast_port, $mcastaddr);
unless ($conn_protonumber = getprotobyname ('udp'))
{die "Cannot resolve UDP protocol.\n"; };
unless (socket ($fh, PF_INET, SOCK_DGRAM, $conn_protonumber))
{die "Cannot obtain socket: $!.\n"; };
unless (setsockopt ($fh, SOL_SOCKET, SO_REUSEADDR, pack ("l", 1)))
{die "Cannot reuse socket address: $!.\n"; };
# Set the socket receive buffer large, to prevent drops when the
# process can't receive the data fast enough. UDP has this problem
# with perl, it seems.
setsockopt $fh, SOL_SOCKET, SO_RCVBUF, pack ("l", $XB_Params::SO_RCVBUF)
or die "setsockopt SO_RCVBUF $XB_Params::SO_RCVBUF: $!";
unless (setsockopt ($fh, $XB_Params::SOL_IP,
$XB_Params::IP_ADD_MEMBERSHIP,
pack ("a4a4", $mcastaddr, $ipaddr)))
{die "Cannot set multicast membership: $!.\n"; };
unless (bind ($fh, $mcast_port))
{die "Cannot bind to multicast group: $!.\n"; };
XB_Log::log ("info", "<-$subrname");
}
##############################
#
# XB_udp_socket ( \fh, dest_addr, udp_port )
#
# Obtains a UDP socket. The destination address is passed by dest_addr
# and the port by udp_port. If dest_addr is false, INADDR_ANY is assumed.
#
# The filehandle used to attach to the socket is passed by reference
# in \fh.
##############################
sub XB_udp_socket ($$$)
{
my ($fh, $dest_addr, $udp_port) = @_;
my $subrname = "XB_udp_socket";
my ($destaddr, $ipaddr, $mcastport, $conn_protonumber);
XB_Log::log ("info", "->$subrname (@_)");
if ($dest_addr)
{
# IPv6 arg: inet_aton
unless ($destaddr = inet_aton ($dest_addr))
{ die "Cannot resolve dest_addr.\n"; };
}
else { $destaddr = INADDR_ANY; };
$udp_port = pack_sockaddr_in ($udp_port, $destaddr);
unless ($conn_protonumber = getprotobyname ('udp'))
{die "Cannot resolve UDP protocol.\n"; };
unless (socket ($fh, PF_INET, SOCK_DGRAM, $conn_protonumber))
{die "Cannot obtain socket: $!.\n"; };
unless (setsockopt ($fh, SOL_SOCKET, SO_REUSEADDR, pack ("l", 1)))
{die "Cannot reuse socket address: $!.\n"; };
XB_Log::log ("info", "<-$subrname");
}
# Description:
# Detects and returns a value for XB_Params::NODEOS based on the
# current system.
# Arguments:
# -
# Returns:
# One of: freebsd, linux, solaris, kame, nist
# Exceptions:
# "node_os" on failure.
sub XB_IPsec::is_present ();
sub node_os () {
XB_Log::log "info", "-> XB_Utils::node_os";
my ($osname, $osvers, $arch);
eval {
# taint-safe backticks equivalent
my $pid = open KID, "-|";
unless(defined $pid) { die "open: $!"; }
unless($pid) {
foreach my $uname ("/usr/bin/uname", "/bin/uname") {
if(-x $uname) { exec $uname, "-msr" or die "exec: $!"; }
}
die "cannot find uname";
}
($osname, $osvers, $arch) = split ' ', lc <KID>;
close KID or die "close: $!";
# XB_IPsec::is_present requires $XB_Params::NODEOS to be set correctly.
my $old_osname = $XB_Params::NODEOS;
$XB_Params::NODEOS = $osname;
if (XB_IPsec::is_present) {
if ($osname eq "freebsd") { $osname = "kame"; }
elsif ($osname eq "linux") { $osname = "nist"; }
}
$XB_Params::NODEOS = $old_osname;
};
XB_Log::log "info", "<- XB_Utils::node_os";
return $osname unless $@; # success if no exception
# exception handling
if($@ !~ /^(open|close)/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Utils::node_os caught unexpected exception $@";
}
# pass defined exceptions up to caller
die "node_os";
}
# Description:
# Return value of sysctl variable $var.
# Arguments:
# $var sysctl variable to check
# Returns:
# value of $var if found
# undef if $var not found
# Exceptions:
# "sysctl_read" on failure
sub sysctl_read ($)
{
my $var = shift; # variable to read
my $val;
# print trace line
XB_Log::log "info", "-> XB_Utils::sysctl_read $var";
eval {
# get the value by reading from a pipe to sysctl
my $pipe = "/sbin/sysctl -n $var 2> /dev/null |";
open PIPE, $pipe or XB_Log::log "err", "cannot open pipe $pipe: $!"
and die "open";
# read the output
$val = <PIPE>;
# done with pipe
close PIPE or not $! or XB_Log::log "err", "cannot close pipe $pipe: $!"
and die "close";
# post-process
if(defined $val) { chomp $val; }
};
# print trace line
XB_Log::log "info", "<- XB_Utils::sysctl_read $var";
return $val unless $@; # success if no exception
# exception handling
if($@ =~ /^(open|close)/) {
# known exception, nothing to handle, pass up
} else {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Utils::sysctl_read: caught unexpected " .
"exception $@";
}
# pass defined exceptions up to caller
die "sysctl_read";
}
# Description:
# set value of sysctl variable $var.
# Arguments:
# $var sysctl variable to set
# $val value
# Returns:
# 1 if succeed
# undef if fail
# Exceptions:
# "sysctl_write" on failure
sub sysctl_write ($;$)
{
my ($var, $val) = @_; # variable to write
# print trace line
XB_Log::log "info", "-> XB_Utils::sysctl_write $var $val";
eval {
if (not defined $val or $val eq "") { $val = 1; }
my @cmd = ("sysctl", "-w", "$var=$val");
XB_Log::log "debug3", "Command: @cmd";
my $rc = 0xff & system (@cmd);
($rc == 0 ) or
XB_Log::log "err",
"Unable to set variable $var. @cmd failed : $!" and die "system";
};
#print trace line
XB_Log::log "info", "<- XB_Utils::sysctl_write $var";
return 1 unless $@; # success if no exception
# exception handling
if ($@ =~ /^(system)/) {
# known exception, nothing to handle, pass up
} else {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Utils::sysctl_write: caught unexpected " .
"exception $@";
}
# pass defined exceptions up to caller
die "sysctl_write";
}
sub rand_seed ()
{
# init random number generator in a portable and relatively secure fashion
my ($rand_seed, $rand_src) = (undef, undef);
# try to find a "good" random source"
foreach my $s ("/dev/urandom", "/dev/random") {
if(-e $s) { $rand_src = $s; last; }
}
if(defined ($rand_src) and -e $rand_src) {
# found good random source, now get a seed
open RAND, $rand_src
or XB_Log::log "warning", "cannot open $rand_src: $!, continuing";
if(read(RAND, $rand_seed, 4) == 4) {
# transmogrify into a string
$rand_seed = unpack "L", $rand_seed;
} else {
# warn and discard value
XB_Log::log "warning",
"cannot read 4 random bytes from $rand_src: $!, continuing";
$rand_seed = undef;
}
close RAND #or not $!
or XB_Log::log "warning", "cannot close $rand_src: $!, continuing";
}
else
{
# we have to use a somewhat compromised seed value
XB_Log::log "warning",
"cannot find good random source, generated keys will be weak";
$rand_seed = time ^ ($$ + ($$ << 15));
}
return $rand_seed;
}
sub XB_obsolete ()
{
my $seconds;
my ($day, $month, $year) =
split /\//, $XB_Params::XBONE_VERSION_DATE;
$seconds = timelocal (0, 0, 0, $day, $month-1, $year-1900);
if ((time() - $seconds) >= (2 * $XB_Params::XBONE_OBSOLETE_LIMIT))
{
return -1;
}
elsif ((time() - $seconds) >= $XB_Params::XBONE_OBSOLETE_LIMIT)
{
return 0;
}
return 1;
}
sub XB_banner_msg () {
my $msg = "\n";
$msg = "################################################################\n";
$msg .= "Startup: ". $FindBin::Bin ."/". $FindBin::Script . "@ARGV\n";
$msg .= "Release: $XB_Params::XBONE_RELEASE\n";
$msg .= "Protocol: $XB_Params::XBONE_PROTOCOL\n";
$msg .= "Time: ". (scalar localtime) ."\n";
$msg .= "################################################################\n";
XB_Log::log "warning", $msg;
}
1; # Make sure this file evaluates to TRUE.
syntax highlighted by Code2HTML, v. 0.9.1