### 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_Common.pm,v $
#
# $Revision: 1.70 $
# $Author: pingali $
# $Date: 2005/04/21 00:14:32 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Yu-Shun Wang
# Description: XBone common utility functions
package XB_Common;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(
ssl_accept ssl_read_cert fh_read_until tcp_ssl_sock
udp_sock
record_state restore_state
api_error_msg ctl_error_msg ctl_msg
check_create_dir reset_state
get_string update_conf_file
);
use strict;
use sigtrap;
use FileHandle;
use Data::Dumper;
use Socket;
use Socket6;
#use IO::Select;
#use IO::Socket::SSL 0.92;
#use IO::Socket::SSLv6;
use IPC::Open3;
use Net::IP;
use Data::Dumper;
use XB_Params;
#use XB_Log;
my $modname = "XB_Common::";
###############################################################################
# UTILITY FUNCTIONS
###############################################################################
# Description:
# -
# Arguments:
# -
# Returns:
# -
# Exceptions:
# -
#
###############################################################################
# EXPORTED API
###############################################################################
# ===========================================================================
# XBone SSL functions
# ===========================================================================
# Description:
# Parse IO::Socket::SSL::accept.
# Arguments:
# $ssl socket handle to accept
# Returns:
# $cliens client socket handle
# Exceptions:
# "ssl_accept" on error, nothing to clean up by caller
#
sub ssl_accept ($){
my $ssl = shift;
my ($client);
my $procname = "ssl_accept";
XB_Log::log "info", "-> $modname$procname $ssl";
eval{
# set alarm because IO::Socket::SSL::accept would block forever waiting
# for ssl handshake with a non-SSL client!
local $SIG{ALRM} = sub {die "alarm\n"};
alarm 15; # TIMEOUT #
unless ($client = $ssl->accept){
XB_Log::log "err", " SSL accept failed" . $ssl->errstr();
alarm 0; # reset alarm
die "accept\n";
}
alarm 0; # reset alarm
};
XB_Log::log "info", "<- $modname$procname";
return $client unless $@;
if($@ eq "alarm\n"){
XB_Log::log "err", " ! SSL accept timeout, possibly non-SSL client";
}elsif($@ !~ /^(accept)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
}
# Description:
# Get peer certificate, extract issuer & subject names.
# Arguments:
# $ssl handle to ssl connection
# Returns:
# $peer peer canonical name on the cert
# $issuer issuer canonical name on the cert
# $cipher supported cipher list (not sure if we need it)
# Exceptions:
# "ssl_read_cert" on error, caller should close the socket
sub ssl_read_cert ($){
my $ssl = shift;
my ($peer_cert, $peer, $issuer, $cipher);
my $procname = "ssl_read_cert";
XB_Log::log "info", "-> $modname$procname $ssl";
eval{
if( ref($ssl) eq "IO::Socket::SSL" or ref($ssl) eq "IO::Socket::SSLv6"){
$peer = $ssl->peer_certificate("subject");
$issuer = $ssl->peer_certificate("issuer");
$cipher = $ssl->get_cipher();
XB_Log::log "debug8", " - peer: $peer";
XB_Log::log "debug8", " - issuer: $issuer";
XB_Log::log "debug8", " - cipher: $cipher";
if ($peer =~ /\/CN=([^\/]*)\/.*/){
$peer = $1;
}else{
XB_Log::log "err", " [$procname] error parsing peer CN";
die "cn";
}
if ($issuer =~ /\/OU=([^\/]*)(\/.*)?$/){
$issuer = $1;
}else{
XB_Log::log "err", " [$procname] error parsing issuer OU";
die "ou";
}
}else{
XB_Log::log "err", " [$procname] $ssl not an SSL socket!";
die "sock";
}
};
XB_Log::log "info", "<- $modname$procname ($peer, $issuer, $cipher) ";
return ($peer, $issuer, $cipher) unless $@;
unless ($@ =~ /^(cn|ou|cert|sock)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
}
# Description:
# Read the given file handle until the delimiter
# Arguments:
# $sock socket handle to read
# $eom message delimiter
# Returns:
# $message message read without the delimiter
# Exceptions:
# -
sub fh_read_until($$){
my ($sock, $eom) = @_;
my ($message);
my $procname = "fh_read_until";
XB_Log::log "info", "-> $modname$procname $sock, $eom";
eval{
local $SIG{ALRM} = sub {die "alarm\n"};
alarm 100;
while( my $line=<$sock> ){
# keep blank lines?
#next unless ($line =~ /\S/); # blank line
if($line =~ /\b$eom\b/){
my $pending = $sock->pending;
if($pending>0){
my $string;
$string = $sock->readline;
XB_Log::log "debug8", " [$procname] leftover: $string";}
else{
XB_Log::log "debug8", " [$procname] nothing pending"; }
last;
}
$message .= $line;
}
alarm 0;
};
XB_Log::log "info", "<- $modname$procname";
XB_Log::log "debug7", " Received message --------------------------\n".
$message. "\n==============================================";
return $message unless $@;
if($@ eq "alarm\n"){
XB_Log::log "err", " ! procname timeout waiting for \"$eom\"";
return "";
}else{
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
}
# Description:
# Create & bind to a TCP/SSL socket on the given local address & port
# Arguments:
# $ipproto ipv4 or ipv6
# $addr local address or hostname
# $port local port
# Returns:
# sock TCP/SSL socket handle
# Exception:
# "XB_Common::ssl_listen_sock" on failure, nothing to clean up by caller
#
sub ssl_listen_sock($$$){
my ($ipproto, $addr, $port) = @_;
my $sock;
my $procname = "ssl_listen_sock";
XB_Log::log "info", "-> $modname$procname $ipproto, $addr, $port";
eval{
if($ipproto eq 'ipv4'){
$sock = IO::Socket::SSL->new(
LocalAddr => $addr,
LocalPort => $port,
Proto => 'tcp',
Reuse => 1,
Listen => SOMAXCONN,
SSL_server => 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"}
);
unless($sock){
XB_Log::log "err", " [$procname] create/bind SSL socket ".
"$ipproto $addr:$port failed: $!";
die "sock";
}else{
XB_Log::log "notice", " [$procname] open SSL listening socket on ".
"$ipproto $addr:$port";
}
}elsif($ipproto eq 'ipv6'){
$sock = IO::Socket::SSLv6->new(
LocalAddr => $addr,
LocalPort => $port,
Proto => 'tcp',
Reuse => 1,
Listen => SOMAXCONN,
SSL_server => 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"}
);
unless($sock){
XB_Log::log "err", " [$procname] create/bind SSL socket ".
"$ipproto $addr:$port failed: $!";
die "sock";
}else{
XB_Log::log "notice", " [$procname] open SSL listening socket on ".
"$ipproto $addr:$port";
}
}else{
XB_Log::log "err", " [$procname] unknown IP protocol: $ipproto";
die "ipproto";
}
};
XB_Log::log "info", "<- $modname$procname";
return $sock unless $@;
unless($@ =~ /(sock|ipproto)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Create a TCP/SSL socket to given destination address and port
# Arguments:
# ipproto ipv4 or ipv6
# dest destination hostname
# port destination port number
# Returns:
# sock TCP/SSL socket handle
# Exception:
# "XB_Common::tcp_ssl_sock" on failure, nothing to clean up by caller
sub tcp_ssl_sock ($$$;$){
my ($ipproto, $dest, $port, $addr) = @_;
my $procname = "tcp_ssl_sock";
my $argstr = join ", ", @_;
XB_Log::log "info", "-> $modname$procname $argstr";
my $sock;
if (not defined($ipproto) or $ipproto eq ""){
$ipproto ="ipv4";
}
eval{
#=> check if a socket to the dest::port already exist
if(defined $XB_Params::persistent_socks{$ipproto}{$dest}{$port}){
# TODO should also verify if the socket is valid, with "ref"?
XB_Log::log "info", " [$procname] a socket to $dest:$port exists";
$sock = $XB_Params::persistent_socks{$ipproto}{$dest}{$port};
}else{
# XXX this check should depend on the ip version chosen for the
# control.
if ($ipproto eq "ipv6"){
if(defined $addr and $addr ne ''){
$sock = IO::Socket::SSLv6->new(
LocalAddr => $XB_Params::node_opts{"ctl_addr6"},
PeerAddr => $addr,
PeerPort => $port,
Proto => "tcp",
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"}
);
}else{
my $addrs = getaddr($dest, 'ipv6');
foreach my $peer (@{$addrs}){
$sock = IO::Socket::SSLv6->new(
LocalAddr => $XB_Params::node_opts{"ctl_addr6"},
PeerAddr => $peer,
PeerPort => $port,
Proto => "tcp",
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 $sock;
} # foreach
} # else
} else {
my $addrs = getaddr($dest, 'ipv4');
my $peer = ${$addrs}[0];
$sock = IO::Socket::SSL->new(
LocalAddr => $XB_Params::node_opts{"ctl_addr"},
PeerAddr => $peer,
PeerPort => $port,
Proto => "tcp",
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(!$sock){
XB_Log::log "err", " [$procname] create ssl socket to $dest:$port ".
"failed: $!" and die "socket";
}else{
XB_Log::log "info", " [$procname] open ssl socket to $dest:$port";
if($XB_Params::PERSISTENT_SOCK){
$XB_Params::persistent_socks{$ipproto}{$dest}{$port} = $sock;
}
}
}
my $select = IO::Select->new($sock);
while (my @w = $select->can_write){
for my $s (@w){
if($s == $sock){
$select->remove($s);
last;
}
}
}
};
XB_Log::log "info", "<- $modname$procname";
return $sock unless $@;
unless($@ =~ /(socket)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Close all opened TCP/SSL sockets inside a forked process
# Arguments:
# -
# Returns:
# 1 on success
# Exception:
# "XB_Common::child_close" on failure, nothing to clean up by caller
sub child_close ($){
my ($tag) = @_;
my $procname = "child_close";
XB_Log::log "info", "-> $modname$procname $tag";
eval{
if($XB_Params::NO_FORK){
# do nothing if we didn't fork
XB_Log::log "info", " [$procname] fork disabled, no need to close";
}else{
while(my ($ip, $hosthash) = each %XB_Params::persistent_socks){
while(my ($host, $porthash) = each %{$hosthash}){
while(my ($port, $sock) = each %{$porthash}){
unless(ref($sock) =~ /IO::Socket::SSL/){
XB_Log::log "warning", " [$procname] wrong socket type: ".
ref($sock);
}
$sock->close('SSL_no_shutdown' => 1);
XB_Log::log "debug1", " [$procname:$tag] close $ip:$host:$port";
}
}
}
}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
die "$modname$procname";
}
# ===========================================================================
# XBone Network & Socket functions
# ===========================================================================
# Description:
# Create a multicast socket bind to given local address and port.
# Arguments:
# $ipproto ipv4 or ipv6
# $addr local address or hostname
# $port local port
# Returns:
# $sock multicast socket handle
# Exceptions:
# "mcast_sock" on error, nothing to clean up by caller
#
sub mcast_sock($$$){
my ($ipproto, $addr, $port) = @_;
my $sock;
my $procname = "mcast_sock";
XB_Log::log "info", "-> $modname$procname $ipproto, $addr, $port";
eval{
if($ipproto eq 'ipv4'){
$sock = IO::Socket::Multicast->new(
LocalAddr => $addr,
LocalPort => $port,
Proto => "udp"
);
unless($sock){
XB_Log::log "err", " [$procname] create multicast/udp socket ".
"$ipproto $addr:$port failed: $!";
die "sock";
}else{
XB_Log::log "notice", " [$procname] bind to multicast/udp socket".
" on $ipproto $addr:$port";
}
}elsif($ipproto eq 'ipv6'){
$sock = IO::Socket::Multicast6->new(
LocalAddr => $addr,
LocalPort => $port,
Proto => "udp"
);
unless($sock){
XB_Log::log "err", " [$procname] create multicast/udp socket ".
"$ipproto $addr:$port failed: $!";
die "sock";
}else{
XB_Log::log "notice", " [$procname] bind to multicast/udp socket".
" on $ipproto $addr:$port";
}
}else{
XB_Log::log "err", " [$procname] unknown IP protocol: $ipproto";
die "ipproto";
}
};
XB_Log::log "info", "<- $modname$procname";
return $sock unless $@;
unless($@ =~ /(sock|ipproto)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Create an UDP socket of given destination & port
# Arguments:
# $dest destination host
# $port destination port
# $ip ipv4 or ipv6
# Returns:
# $udp udp socket handle
# Exceptions:
# "udp_sock" on error, nothing to clean up by caller
sub udp_sock($$$){
my ($dest, $port, $ip) = @_;
my $procname = "udp_sock";
my $udp;
XB_Log::log "info", "-> $modname$procname $dest, $port, $ip";
eval{
if($ip ne "ipv6"){
$udp = new IO::Socket::INET(
LocalAddr => $XB_Params::node_opts{"ctl_addr"},
PeerAddr => $dest,
PeerPort => $port,
Proto => "udp"
);
}else{
# ipv6. test if the destination is a name or an ip address
my $n = new Net::IP($dest);
if (defined $n){
$udp = new IO::Socket::INET6(
LocalAddr => $XB_Params::node_opts{"ctl_addr6"},
PeerAddr => $dest,
PeerPort => $port,
Proto => "udp"
);
} else {
# otherwise resolve the address
my $addrs = getaddr($dest, 'ipv6');
my $peer = ${$addrs}[0];
if (defined $peer){
$udp = new IO::Socket::INET6(
LocalAddr => $XB_Params::node_opts{"ctl_addr6"},
PeerAddr => $peer,
PeerPort => $port,
Proto => "udp"
);
}; #defined peer
}
} #else
if(!$udp){
XB_Log::log "err",
" [$procname] failed to create UDP socket to $dest:$port: $!";
die "sock";
}else{
XB_Log::log "info", " [$procname] UDP socket to $dest:$port";
}
};
XB_Log::log "info", "<- $modname$procname";
return $udp unless $@;
unless($@ =~ /sock/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Front end to call appropriate socket create functions with given
# destination and port.
# Arguments:
# $dest destination host
# $port destination port
# $ipproto ipv4 or ipv6
# $type TCP/SSL, UDP, or Multicast
# Returns:
# $sock socket handle
# Exceptions:
# "create_sock" on error, nothing to clean up by caller
#
sub create_sock($$$$){
my ($dest, $port, $ipproto, $type) = @_;
my $procname = "create_sock";
my $argstr = join ", ", @_;
my $sock;
XB_Log::log "debug1", "-> $modname$procname $argstr";
eval{
};
return $sock unless $@;
unless($@ =~ //){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Connection Manager: fork a child process to handle all persistent
# connections between this node and all its selected RDs & sub-OMs.
# It has two modes of operation: direct mode and proxy mode:
# - direct mode: open TCP/SSL connection to the given destination, and
# return the TCP/SSL socket directly to the caller;
# subsequent communications between parent and the given
# destination happen directly through the returned socket
# - proxy mode: open TCP/SSL connection to the given destination, then
# open another UNIX domain socket between main process &
# the connection manager process, return the internal UNIX
# domain socket to the caller; subsequent communications
# between the parent and the given destination are proxied
# through the connection manager
# Arguments:
# command open/close/exit
# dest destination hostname
# port destination port number
# Returns:
# sock socket handle for "open", nothing for "close" & "exit"
# Exception:
# "XB_Common::connection_manager" on failure, nothing to clean up by
# caller
#
sub connection_manager($$$){
my ($cmd, $host, $port) = @_;
my $procname = "connection_manager";
XB_Log::log "info", "-> $modname$procname $cmd, $host, $port";
eval{
# main (parent)
# check if a cm process already exists
# - yes: form the command & send to the cm process through cm_sock
# - no: create a socketpair & fork; then form the command & send
# to the cm process through cm_sock
# cm (chile)
# init: create an IO::Select object and add the main socket; then
# enter select loop
# loop: switch on socket ready to read
# [main_sock]: command?
# - open $ovlname $host $port:
# - open TCP/SSL socket to $host:$port
# - direct mode: return the TCP/SSL socket
# - proxy mode: create
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless($@ =~ /\S+/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Manipulate file handles in the parent of a fork process.
# Arguments:
# -
# Returns:
# 1 on success
# Exception:
# "XB_Common::fork_parent_close" on failure, nothing to clean up by caller
sub fork_parent_close($$$$){
my ($select, $read, $write, $id) = @_;
my $procname = "fork_parent_close";
XB_Log::log "debug1", "-> $modname$procname $select, $read, $write, $id";
eval{
# add the read handle to the select object
$select->add($read) or die "select";
# close the write handle
$write->close or die "close";
};
XB_Log::log "debug1", "<- $modname$procname";
return 1 unless $@;
unless ($@ =~ /\b(select|close)\b/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# ===========================================================================
# XBone State File Processing
# ===========================================================================
# - record_state:
# calls write_state with XBone-specific parameters to record the XBone
# node state
# - restore_state:
# calls read_state with XBone-specific parameters to restore the XBone
# node state, then proceed to re-configure the node accrodingly
# - write_state:
# generic function to write given variables/names into the given file
# - read_state:
# generic function to read and eval the given file
# Description:
# Writes the given data structures with specified names out to the state
# file for crash recovery purpose. The state must be rewritten each time
# a change is made to an overlay.
# Arguments:
# $file filename to write to
# $vars (ref) array of variables to be written
# $varnames (ref) array of variable names specified in @{$vars}
# Returns:
# 1 on success
# Exception:
# "XB_Common::write_state" on failure
# Note:
# o This is a generic function to write any data structures to the given
# file. No XBone-specific assumptions are made.
# o This function is called by "record_state" to write XBone node state.
#
sub write_state ($$$){
my ($file, $vars, $varnames) = @_;
my $procname = "write_state";
my $state;
my $fh = new FileHandle;
XB_Log::log "info", "-> $modname$procname @_";
eval{
# open the file for writing
if(!$fh->open ($file, ">")){
XB_Log::log "err", " [$modname] failed to open file $file: $!";
die "open";
}
# set permission
if(!chmod(0600, $file)){
XB_Log::log "err", " [$modname] failed to set permission 0600 on".
" $file: $!";
die "chmod";
}
$state = Data::Dumper->Dump($vars, $varnames);
$fh->print ("$state") or die "print: $!";
$fh->close or die "close: $!";
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless($@ =~ /(open|chmod|print|close)/){
XB_Log::log "warning", " [$procname] caught unkown exception: $@";
}
die "$modname$procname";
}
# Description:
# Read the given state file and evaluate its contents
# Arguments:
# $state state file (full path)
# Returns:
# 1 on success, 0 if file doesn't exist
# Exception:
# "XB_Common::read_state" on failure, nothing to cleanup by caller
# Side Effect:
# The variables stored in the state file will overwrite those of the same
# names in the current process.
# Note:
# o This is a generic function to read any state files generated by
# Data::Dumper->Dump. No XBone-specific assumptions are made about
# the contents of the state file.
# o This function is called by "restore_state" to restore XBone state file.
#
sub read_state($){
my $state = shift;
my $result = 1;
my $procname = "read_state";
XB_Log::log "info", "-> $modname$procname $state";
eval{
my $fh = new FileHandle;
my $data;
if(-e $state){
if($fh->open($state, "<")){
XB_Log::log "debug1", " [$procname] read from $state";
while(<$fh>){
$data .= $_;
XB_Log::log "debug6", "[STATE] $_";
}
$data =~ /(.*)/s; # untaint the value
XB_Log::log "debug1", " [$procname] evaluate the data";
eval $data;
$fh->close or
XB_Log::log "err", " [$procname] could not close $state: $!" and
die "close";
}else{
XB_Log::log "warning", " [$procname] failed to open $state: $!";
$result = 0;
}
}else{
XB_Log::log "warning", " [$procname] state file $state doesn't exist";
$result = 0;
}
};
XB_Log::log "info", "<- $modname$procname";
return $result unless $@;
unless($@ =~ /(open|close)/){
XB_Log::log "warning", " [$procname] caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Record XBone node state.
# Arguments:
# -
# Returns:
# 1 on success
# Exception:
# "XB_Common::record_state" on failure,
#
sub record_state{
my $procname = "record_state";
XB_Log::log "info", "-> $modname$procname";
eval{
my $state = $XB_Params::node_opts{workdir}. "/".
$XB_Params::node_opts{state_file};
$XB_Params::state_time = time;
my @vars = ($XB_Params::state_time, \%XB_Params::node_state);
my @varnames = qw ( *XB_Params::state_time *XB_Params::node_state);
write_state $state, \@vars, \@varnames;
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless($@ =~ /(write_state)/){
XB_Log::log "warning", " [$procname] caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Restore XBone node state.
# Arguments:
# -
# Returns:
# -
# Exception:
# "XB_Common::restore_state" on failure, ???
#
sub restore_state{
my $result = 1;
my $procname = "restore_state";
XB_Log::log "info", "-> $modname$procname";
eval{
my $state = $XB_Params::node_opts{workdir}. "/".
$XB_Params::node_opts{state_file};
my $now = time;
#1. read and eval the state file
$result = read_state $state; # set %XB_Params::node_state if succeeded
if($result){
if($XB_Params::state_time != $now){
if($XB_Params::state_time > $now){
XB_Log::log "warning", " [$procname] Reading state from the ".
"future! Check your system time.";
}
my $stime = localtime $XB_Params::state_time;
XB_Log::log "info", " [$procname] restored state from [$stime]";
}
#-> restore IP address server state
if($XB_Params::node_state{ip_allocator}){
if($XB_Params::node_opts{addrserv}){
my ($diff, $str) = (0, "");
my $ip = $XB_Params::node_state{ip_blocks};
# go through each block to check for consistency
if($XB_Params::new_alloc){
if(exists $ip->{ipv4}){
# only care if state has it before
unless($ip->{ipv4}{cidr} eq $XB_Params::node_opts{netv4}){
# if no active leases, just ignore the old ones
unless(keys(%{$ip->{ipv4}{leases}}) == 0){
$diff = 1;
$str .= " o IPv4 netblocks: $ip->{ipv4}{cidr} vs. ".
"$XB_Params::node_opts{netv4} (new)\n";
}
}
}
if(exists $ip->{ipv6}){
# only care if state has it before
unless($ip->{ipv6}{cidr} eq $XB_Params::node_opts{netv6}){
unless(keys (%{$ip->{ipv6}{leases}}) == 0){
$diff = 1;
$str .= " o IPv6 netblocks: $ip->{ipv6}{cidr} vs. ".
"$XB_Params::node_opts{netv6} (new)\n";
}
}
}
}else{
unless($ip->{ipv4}{netblock} eq $XB_Params::node_opts{netv4}){
$diff = 1;
$str .= " o IPv4 netblocks: $ip->{ipv4}{netblock} vs. ".
"$XB_Params::node_opts{netv4} (new)\n";
}
unless($ip->{ipv4}{linkblock} eq $XB_Params::node_opts{linkv4}){
$diff = 1;
$str .= " o IPv4 linkblocks: $ip->{ipv4}{linkblock} vs. ".
"$XB_Params::node_opts{linkv4} (new)\n";
}
unless($ip->{ipv6}{netblock} eq $XB_Params::node_opts{netv6}){
$diff = 1;
$str .= " o IPv6 netblocks: $ip->{ipv6}{netblock} vs. ".
"$XB_Params::node_opts{netv6} (new)\n";
}
unless($ip->{ipv6}{linkblock} eq $XB_Params::node_opts{linkv6}){
$diff = 1;
$str .= " o IPv6 linkblocks: $ip->{ipv6}{linkblock} vs. ".
"$XB_Params::node_opts{linkv6} (new)\n";
}
}
if($diff){
XB_Log::log "err",
" [$procname] Saved state conflicted with new config option:\n".
" This node was an IP addr server with different ranges:".
"\n$str";
die "addrblks";
}else{
XB_Log::log "info", " [$procname] restored IP addr server state";
}
}else{
XB_Log::log "warning",
" [$procname] Saved state conflicted with new config option:\n".
" This node was an IP addr server, but it's disabled now.";
#die "addrserv";
}
# else compare the range of IP pools, die if different
}else{
# state file has nothing, don't care if it's server this time around
}
#-> restore active applications (overlay) state
# for each overlay
# top level om
# if last refresh is sent within expiration interval
# [om] refresh/recreate
# elsif(persistent overlay)
# [om] refresh/recreate
# else
# remove state
# sub-om or rds
# [om] or [rd] refresh/recreate state
# (and let it timeout automatically)
# * om should wait for a heartbeat before sending refresh, or
# wait until a heartbeat is rejected?
#if(exists $XB_Params::node_state{user_stats}){
# # re-count from scratch
# delete $XB_Params::node_state{user_stats};
#}
for my $a (keys %{$XB_Params::node_state{active_apps}{overlay}}){
my $app = $XB_Params::node_state{active_apps}{overlay}{$a};
if(exists $app->{node}){
# simple node [rd], get app info and restore
my $ncmd = $app->{node}{command};
my $cred = $app->{node}{credential};
my $type = $ncmd->{app_type};
my $name = $ncmd->{app_name};
my $level = $ncmd->{level};
XB_Log::log "info", " [$procname] restoring $type $name";
# delete but retain the state
my $dummy = XB_CTL::ctl_stop($type, $name, $level,
"localhost", 1);
# create again
$dummy = XB_CTL::ctl_config($app->{node}, 1);
#$XB_Params::node_state{user_stats}{$cred->{user_email}}++;
}elsif(exists $app->{network}){
# recursive meta node
XB_Log::log "warning", " [$procname] Recursive crash recovery ".
"is not supported yet.";
}elsif(exists $app->{application}){
# top level meta node
XB_Log::log "info", " [$procname] Creator of $a, restore state".
" only.";
#$XB_Params::node_state{user_stats}{$app->{credential}{user_email}}++;
}else{
XB_Log::log "warning", " [$procname] Unrecognized overlay hash:".
"\n". Dumper($app);
}
XB_Log::log "debug6", " [$procname] restored state:".
"\n". Dumper(\%XB_Params::node_state);
}
}
};
XB_Log::log "info", "<- $modname$procname";
return $result unless $@;
unless($@ =~ /(open|close|addrblks|addrserv|ctl_stop|ctl_config)/){
XB_Log::log "warning", " [$procname] caught unknown exception: $@";
}
die "$modname$procname";
}
#sub XB_read_state ($$)
#{
# my ($nodehref, $cfgfile) = @_;
# my $fh = new FileHandle;
# my ($dsdata, $end_found, $dstime, %newstate);
#
# XB_Log::log ("info", "->XB_read_state (@_)");
#
# XB_Log::log ("debug0", "Initializing node database ...");
#
# $end_found = 0;
#
# if (! -d $XB_Params::DAEMON_STATE_DIR)
# {
# my @md = ("mkdir", "-m", "0755", "$XB_Params::DAEMON_STATE_DIR");
# my $rc = 0xff & system (@md);
# ($rc == 0) or
# XB_Log::log "err", "mkdir $XB_Params::DAEMON_STATE_DIR failed: $!";
# }
#
# if ($fh->open ($XB_Params::DAEMON_STATE_FILE, "<"))
# {
# ##############################################
# # Read in state data and look for STATE_TIME
# # written, used to indicate that file is good.
## ##############################################
#
# XB_Log::log ("debug0",
# "Reading daemon state file: $XB_Params::DAEMON_STATE_FILE");
#
# $dsdata = $dstime = "";
#READLINE:
# while (<$fh>)
# {
# if ($_ !~ m'\$XB_Params::DAEMON_STATE_TIME\s*=')
# { $dsdata .= $_; }
# else
# {
# $end_found = 1;
# $dstime = $_;
# last READLINE;
# };
# };
#
# $fh->close;
#
# if ($end_found)
# {
# $dsdata =~ /(.*)/s; # Taint fixup. State file is in a root
# $dsdata = $1; # privileged directory, so we trust it.
#
# eval $dsdata; # This EVAL sets $XB_Params::DAEMON_STATE.
#
# $nodehref = \%XB_Params::DAEMON_STATE;
#
# XB_runtime_state ($nodehref); # Reassert runtime state
#
# $XB_Params::NODEOS = $XB_Params::DAEMON_STATE{'OS'};
# };
# };
#
# ###########################################
# # If we either cannot access the state file
# # or did not see it properly terminated the
# # state is initialized from the config file.
# ###########################################
#
# if (!$end_found)
# {
# XB_Log::log ("warning", "State data file damaged or missing.");
# XB_Log::log ("warning", "Reinitializing using config file alone.");
#
# %XB_Params::DAEMON_STATE = ();
#
# XB_read_config_file ($cfgfile, \%XB_Params::DAEMON_STATE);
#
# $nodehref = \%XB_Params::DAEMON_STATE;
#
# XB_runtime_state ($nodehref); # Reassert runtime state
#
# $XB_Params::NODEOS = $XB_Params::DAEMON_STATE{'OS'};
#
#{
# my $state = Dumper ($nodehref);
# XB_Log::log ("info", "###################################\n");
# XB_Log::log ("info", "########## INIT STATE ##########\n");
# XB_Log::log ("info", "\n$state\n");
# XB_Log::log ("info", "############### END ###############\n");
# XB_Log::log ("info", "###################################\n");
#}
#
# }
# else
# {
# XB_Log::log "info", "Using state file: $XB_Params::DAEMON_STATE_FILE";
# };
#
#
# eval { XB_IPsec::init() };
# if ($@)
# {
# XB_Log::log ("err", "XB_IPsec::init failed with $@");
# die "";
# };
#
# eval { XB_Tunnel::init() };
# if ($@)
# {
# XB_Log::log ("err", "XB_Tunnel::init failed with $@");
# die "";
# };
#
# eval { XB_Route::init() };
# if ($@)
# {
# XB_Log::log ("err", "XB_Route::init failed with $@");
# die "";
# };
#
# ###########################################
# # If developing, ensure a clean route,
# # tunnel and IPsec state in the host.
# #
# # NOTE: ERASE_AT_STARTUP will eliminate
# # ALL host tunnels and IPsec rules,
# # not just Xbone tunnels and rules.
# ###########################################
#
# if ($XB_Params::ERASE_AT_STARTUP)
# {
# XB_erase_host_state ();
# }
#
# ###########################################
# # If we read what we believe is good state
# # the overlays are reinitialized to reflect
# # that state.
# ###########################################
#
# XB_Log::log ("debug0", "Restoring using daemon state file ...");
#
# XB_restore_state ($nodehref);
#
# XB_Log::log ("debug0", "State has been restored.");
#
# ####################################
# # Always reread current config file.
# # This can alter some of the just
# # reloaded state data, particularly
# # changed access control lists.
# ####################################
#
# XB_Log::log ("debug0", "Reading current host config file.");
#
# %newstate = ();
# XB_read_config_file ( $cfgfile, \%newstate );
#
# XB_update_daemon_state ($nodehref, \%newstate);
# %$nodehref = %newstate;
#
# XB_runtime_state ($nodehref); # Reassert runtime state
#
#
# #################################
# # Now that config state is loaded
# # perform gross legality checks.
# #################################
#
# {
# my $tmp = XB_node_check ($nodehref);
#
# if ($tmp)
# {
# XB_Log::log ("err", "\n****************************\n");
# XB_Log::log ("err", "$tmp\n");
# XB_Log::log ("err", "****************************\n\n");
#
# die "";
# }
# }
#
#EXIT:
# XB_Log::log ("debug0", "Node database initialized.");
# XB_Log::log ("info", "<-XB_read_state ()");
#}
# ===========================================================================
# Generate common XBone API/CTL Messages
# ===========================================================================
# Description:
# Construct the hashes & lists required to build the XBone API XML
# messages and call corresponding functions in XB_XML_GUI modules to
# build the messages.
# Arguments:
# $app_obj (ref) application object
# $msg_type message type
# Returns:
# $msg_ref (ref) message
# Exceptions:
# -
sub api_error_msg ($$$$$){
my ($name, $email, $auth_type, $cmd, $emsg) = @_;
my $procname = "api_error_msg";
XB_Log::log "info", "-> $modname$procname $name, $email, $auth_type, $cmd";
# cleanup the error message
chomp($emsg);
$emsg =~ s/^\s*(\S.*\S)\s*$/$1/;
$emsg =~ s/</[/g;
$emsg =~ s/>/]/g;
XB_Log::log "info", " Error Msg:========================================".
"\n$emsg\n".
" ==================================================";
my $msg_ref;
eval{
my (%ahref);
$ahref{protocol} = $XB_Params::api_ver;
$ahref{release} = $XB_Params::rel_ver;
$ahref{auth_type} = $auth_type;
$ahref{user_email} = $email;
$ahref{user_name} = $name;
$ahref{command} = $cmd;
$msg_ref = XB_XML_GUI::XB_build_api_errmsg (\%ahref, $emsg);
XB_Log::log "debug1", " [$procname] message:\n". $$msg_ref;
};
XB_Log::log "info", "<- $modname$procname";
return $msg_ref unless $@;
XB_Log::log "warning", " ! $procname caught unknown exception $@";
die "$modname$procname";
}
# Description:
# Construct the XBone CTL error messages from the given parameters.
# Arguments:
# $cmd error command
# $type application type
# $name application name
# $level application level
# $msg (ref) error messages
# Returns:
# $msg_ref (ref) message
# Exceptions:
# -
sub ctl_error_msg ($$$$$){
my ($cmd, $type, $name, $level, $msg) = @_;
my $argstr = join ", ". @_;
my $procname = "ctl_error_msg";
XB_Log::log "debug1", "-> $modname$procname $argstr";
$cmd = ((defined $cmd) and ($cmd =~ /\S+/))? $cmd : "unknown";
$type = ((defined $type) and ($type =~ /\S+/))? $type : "unknown";
$name = ((defined $name) and ($name =~ /\S+/))? $name : "unknown";
$level= ((defined $level) and ($level =~ /\S+/))? $level: 0;
$msg = $$msg;
$msg =~ s/^\s*(\S.*\S)\s*$/$1/; # remove white space from both ends
$msg = ($msg =~ /\S+/)? $msg : "empty message";
$msg =
"(xbone-ctl $XB_Params::ctl_ver $XB_Params::rel_ver\n".
" (error\n".
" (command $cmd)\n".
" (application $type)\n".
" (name $name)\n".
" (level $level)\n".
" (message \"$msg\")\n".
" )\n".
")\n".
"$XB_Params::msg_delimiter\n";
XB_Log::log "debug1", "<- $modname$procname";
return \$msg;
}
# Description:
# Generate the credential section with given info.
# Arguments:
# $name user name
# $email user email
# $auth auth type
# Returns:
# \$msg (ref) message
sub make_credential($$$){
my ($name, $email, $auth) = @_;
my $procname = "make_credential";
XB_Log::log "info", "-> $modname$procname $name, $email, $auth";
my $msg =
" (credential (user_name \'$name\')\n".
" (user_email \'$email\')\n".
" (auth_type \'$auth\'))\n";
return \$msg;
}
# Description:
# Generate simple XBone Control messages of the given types.
# Arguments:
# $cmd command type
# $app application type
# $name application name
# $level application level
# $hostname hostname
# $extra %@#$..>&*, (it's extra)
# Returns:
# \$msg (ref) message
# Exceptions:
# "XB_Common::ctl_ack" on failure, nothing to cleanup by caller
sub ctl_msg($$$$;$$){
my ($cmd, $app, $name, $level, $hostname, $extra) = @_;
my $msg;
my $procname = "ctl_msg";
my $argstr = join ", ", @_;
XB_Log::log "debug1", "-> $modname$procname $argstr";
if(defined $hostname and $hostname =~ /^\S+$/){
$hostname = " (hostname $hostname)\n";
}else{
$hostname = "";
}
if(not defined $extra){ $extra = ""; }
$msg =
"(xbone-ctl $XB_Params::ctl_ver $XB_Params::rel_ver\n".
" ($cmd\n".
" (application $app)\n".
" (name $name)\n".
" (level $level)\n".
$hostname.
$extra.
" )\n".
")\n".
"$XB_Params::msg_delimiter\n";
XB_Log::log "debug1", "<- $modname$procname";
return \$msg;
}
# ===========================================================================
# User ACL functions
# ===========================================================================
# Description:
# Parse and return the user ACL spec'd in config file (strings) into
# a structured user ACL hash.
# Arguments:
# $acl (ref) user ACL from node config option (rule_no. => acl_str)
# $ignore ignore the no user acl message (typical for shared user acls)
# Returns:
# $new_acl (ref) parsed user ACL
# Exception:
# "parse_user_acl" on failure, nothing to cleanup by caller
# Note:
# ACL should work like firewall, order of rules matters.
#
sub parse_user_acl($;$){
my ($acl,$ignore) = @_;
my $procname = "parse_user_acl";
XB_Log::log "info", "-> $modname$procname $acl";
my (@new_acl);
eval{
my @rules = keys %{$acl};
unless(@rules > 0){
XB_Log::log "err", " [$procname] NO user ACL entry!"
if (not defined $ignore);
die "none";
}
# sort based on rule numbers because hash is not ordered
@rules = sort { $a <=> $b } @rules;
for my $n (@rules){
my $acl_str = $acl->{$n};
my %new_acl;
if($acl_str =~ /^(\S+)\s+(\S+)\s+(\d+)\s+(\S+)$/){
# format: "$match_uid $level $max_ovl $app_suid"
# example: "isi.edu deploy 25 guest"
# "john_doe guest 0 nobody"
$new_acl{$1}{def} = $acl_str;
$new_acl{$1}{no} = $n;
$new_acl{$1}{level} = $2;
$new_acl{$1}{max} = $3;
$new_acl{$1}{suid} = $4;
XB_Log::log "debug6",
" [$procname] acl entry: [no. $n: $1/$2/$3/$4]";
push @new_acl, \%new_acl;
}else{
XB_Log::log "err", " [$procname] error parsing user ACL string:\n".
" $n => [$acl_str]";
die "format";
}
}
XB_Log::log "debug6", " [$procname] User ACL hash:", Dumper(\@new_acl);
};
XB_Log::log "info", "<- $modname$procname";
return \@new_acl unless $@;
unless($@ =~ /(none|format)/){
XB_Log::log "err", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Verfiy a user email against the user ACL.
# Arguments:
# $name user name
# $email user email
# $auth authentication type
# Returns:
# $result 1 if ok, 0 if failed
# $uid effective uid of the matching entry
# Exception:
# -
sub check_user_acl($$$$){
my ($name, $email, $auth, $cmd) = @_;
my $procname = "check_user_acl";
my $result = 0;
my $uid = '';
XB_Log::log "info", "-> $modname$procname @_";
eval{
# check auth type
unless(defined $auth){
XB_Log::log "err", " [$procname] auth type missing";
die "missing";
}else{
my $auth_pass = 0;
for my $a (@XB_Params::auth_type){
if(lc($a) eq lc($auth)){
$auth_pass = 1;
last;
}
}
unless($auth_pass){
# die if failed auth type check
XB_Log::log "err", " [$procname] auth type $auth not allowed";
die "auth";
}
}
# go through acl rules
foreach my $aclhash ( $XB_Params::node_opts{"user_acl"},
$XB_Params::node_opts{"shared_user_acl"}) {
for (my $i = 0; $i < @{$aclhash}; $i++){
for my $u (keys %{$aclhash->[$i]}){
my $h = $aclhash->[$i]{$u};
XB_Log::log "debug2", " [$procname] entry $i: $u";
if($email =~ /$u/i){
# matched! check the rule
# check the command against the access level
my $cmd_pass = 0;
my ($l, $m, $s) = ($h->{level}, $h->{max}, $h->{suid});
$uid = $s;
XB_Log::log "debug2", " [$procname] match: $u/$l/$m/$s";
my @action = grep /^$cmd$/, @{$XB_Params::access_level{$l}};
if(@action == 1){
$cmd_pass = 1;
}elsif(@action > 1){
$cmd_pass = 1;
# probably duplicates in the access level spec
XB_Log::log "warning", " [$procname] multiple commands! ".
(join ", ", @action);
}
# if failed, move on to the next rule
unless($cmd_pass){ next; }
else{
if($cmd =~ /(create_overlay|invite)/){
# check max number of overlay allowed if create
if(not defined $XB_Params::node_state{user_stats}{$email}){
$XB_Params::node_state{user_stats}{$email} = 0;
}
if($XB_Params::node_state{user_stats}{$email} < $m){
$result = 1;
last;
}else{
XB_Log::log "err", " [$procname] $name reached the max ".
"overlay limit ($m)";
die "over";
}
}else{
# not create, we passed
$result = 1;
}
}
}
};
if($result){ last; }
};
if ($result) { last; }
}; # acl hash - user_acl, shared_user_acl
};
XB_Log::log "info", "<- $modname$procname $result";
return ($result, $uid) unless $@;
unless($@ =~ /(auth|over)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
return 0;
}
# Description:
# Verfiy a user email against the user ACL.
# Arguments:
# $msg_type XBone control or XBone API messages
# $msg_name name of the message
# $socktype TCP/SSL, UDP, or multicast
# $ipproto IPv4 or IPv6
# $node_hash (ref) hash ("$node" => "$msg")
# $have_reply 1: have replies, 0: not
# Returns:
# \%replies (ref) hash ("$node" => "$reply_msg")
# \@missing (ref) array of nodes that didn't reply
# Exception:
# -
sub fork_and_send($$$$$$$){
my ($msg_type, $msg_name, $socktype, $ipproto, $node_hash, $have_reply) = @_;
my $procname = "fork_and_send";
my $argstr = join ", ", @_;
my (%replies, @missing);
XB_Log::log "info", "-> $modname$procname $argstr";
eval{
#=> check parameters
my @nodelist = keys(%{$node_hash});
my $max_procs = ($XB_Params::NO_FORK)? 0 : @nodelist;
my $node_count = @nodelist;
my %node_fh;
my $pm = new Parallel::ForkManager($max_procs);
my $sel = IO::Select->new;
#=> define callback functions during forking
$pm->run_on_start(
sub {
my ($pid, $ident) = @_;
XB_Log::log "info", " [$procname] fork: $ident (pid: $pid)";
}
);
$pm->run_on_finish(
sub {
my ($pid, $exit_code, $ident) = @_;
if($exit_code){
XB_Log::log "info",
" [$procname] child: $ident (pid $pid) exits $exit_code";
}else{
XB_Log::log "warning",
" [$procname] child: $ident (pid $pid) exits $exit_code";
}
$node_count--;
}
);
$pm->run_on_wait(
sub {
XB_Log::log "debug1", " [$procname] $node_count processes left";
}
);
#=> fork loop
for my $node (@nodelist){
#-> create socket
#=> create or retrieve tcp/ssl socket
my $ssl_sock;
if($XB_Params::PERSISTENT_SOCK){
$ssl_sock = tcp_ssl_sock ($ipproto,
$node, $XB_Params::node_opts{xbone_ctl_port});
}
#=> create a pipe for the child to write back to parent
my $rh = IO::Handle->new;
my $wh = IO::Handle->new;
pipe $rh, $wh or die "pipe";
$node_fh{$rh} = $node;
#=> fork
my $pid = $pm->start($node)
and fork_parent_close($sel, $rh, $wh, $node)
and next;
#=> begin child process ============================================
# exception handling inside the child process: need to catch all
# dies by the child process and exit with different code
my $received = 0;
eval{
#=> close the read handle
$rh->close or die "close";
#=> create or retrieve tcp/ssl socket if not yet created
unless(defined $ssl_sock){
$ssl_sock = tcp_ssl_sock ($ipproto,
$node, $XB_Params::node_opts{xbone_ctl_port});
}
#=> send select
XB_Log::log "info", " [$procname] send status to $node";
print $ssl_sock $node_hash->{$node};
#=> wait & receive ack-status
my $new_sel;
unless ($new_sel = IO::Select->new($ssl_sock)){
XB_Log::log "err", " [$procname:$node] select failed: $!"
and die "select";
}
while(my @r = $new_sel->can_read()){ # TODO set timeout
for my $fh (@r){
if($fh != $ssl_sock){
XB_Log::log "err", " [$procname:$node] wrong socket for $node";
next;
}else{
#=> read command & write it back to the parent process
my $ctl_msg = fh_read_until ($fh,
$XB_Params::msg_delimiter);
print $wh $ctl_msg;
$received = 1;
}
}
if($received == 1){ last; }
}
if(not $XB_Params::PERSISTENT_SOCK){
$ssl_sock->close or
XB_Log::log "err", " [$procname:$node] socket close failed: $!"
and die "close";
}
unless($received){
XB_Log::log "err", " [$procname:$node] did not received the ".
"whole message" and die "rcv";
}
};
if($@ && $@ !~ /(tcp_ssl_sock|select|fh_read_until|close|rcv)/){
XB_Log::log "err", " [$procname:$node] caught unknown exception: $@";
}
unless($XB_Params::NO_FORK){
child_close($node);
}
$pm->finish($received);
#=> end child process ==============================================
}
#=> collect responses from all the nodes
while (my @handles = $sel->can_read){ # TODO set timeout
for my $h (@handles){
my $n = $node_fh{$h};
XB_Log::log "debug1", " [$procname] receive from $n";
my @lines = $h->getlines;
my $ack_msg = join "", @lines;
my $ctl_cmd = $XB_CTL::parser->xb_ctl($ack_msg);
unless (defined $ctl_cmd){
XB_Log::log "err", " [$procname] error parsing message ".
"from $n =====\n$ack_msg\n==========";
}else{
unless ($ctl_cmd->{command}{command} =~ /(ack-status|error)/){
XB_Log::log "err", " [$procname] wrong command: ".
"$ctl_cmd->{command}{command}";
}else{
XB_Log::log "debug6", " [$procname] CTL command: ".
Dumper($ctl_cmd);
delete $node_fh{$h};
$replies{$n} = $ctl_cmd;
}
}
$sel->remove($h);
$h->close or die "close";
}
}
$pm->wait_all_children;
#=> process replies
#if($type eq 'overlay'){
# XB_VN_funcs::process_status($app_obj, \%node_reply);
#}else{ # add support for other applications here
# XB_Log::log "err", " [$procname] application $type not supported"
# and die "app";
#}
#=> generate the reply message
my @missing = values %node_fh;
if(@missing > 0){
XB_Log::log "err", " [$procname] select failed on ".
(join ", ", @missing) and die "ack";
}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless($@ =~ //){
XB_Log::log "warning", " ! $procname caught unkown exception: $@";
}
# die or return 0
return 0;
}
# ===========================================================================
# Init checks
# ===========================================================================
#-> check directory -------------------------------------------------
# Description:
# Check if the given directory exists; create it if not.
# Arguments:
# $dir directory to check
# Returns:
# 1 on success
# Exception:
# "XB_Common::check_create_dir" on failure
#
sub check_create_dir($){
my $dir = shift;
my $procname = $modname. "check_create_dir";
eval{
unless(-d $dir){
#mkdir $dir, 0755 or die "mkdir $dir, 0755: $!";
my @cmd = ('mkdir', '-p', "$dir");
my $cmdstr = join ' ', @cmd;
my $rc = 0xff & system (@cmd);
($rc == 0) or
XB_Log::log "err", " [$procname] $cmdstr failed: $!" and
die "mkdir";
}
chmod 0755, $dir or
XB_Log::log "err", " [$procname] chmod 0755, $dir failed: $!" and
die "chmod";
};
return 1 unless $@;
unless($@ =~ /(mkdir|chmod)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$procname";
}
#-> node os ---------------------------------------------------------
# Description:
# Detects and returns a list of OS info for the current system.
# Arguments:
# Returns:
# @os [OS, release version, arch, kernel version]
# Exceptions:
# "node_os" on failure.
sub node_os (){
my $procname = "node_os";
XB_Log::log "info", "-> $modname$procname";
my ($os, $vers, $arch, $kern);
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 "uname";
}
($os, $vers, $arch) = split ' ', lc <KID>;
close KID or die "close: $!";
# check the minimum os version supported
# - note: must verify the following for each supported platform for
# they will be different
# (1) how to obtain kernel versions
# (2) how to compare kernel versions cause they might not be numbers
if($os =~ /FreeBSD/i){
$kern = sysctl_read('kern.osreldate');
unless($kern >= $XB_Params::os_support{freebsd}){
XB_Log::log "err",
" [$procname] $os $vers (kernel $kern) not supported.\n".
" Must be $XB_Params::os_support{freebsd} or above.)";
die "vers";
}
}elsif($os =~ /Linux/i){
($kern, my $version) = split (/-/, $vers);
my @my_kernel = split (/\./, $kern);
$my_kernel[2] =~ s/[a-zA-Z].*$//g;
my @support_kernel = split (/\./, $XB_Params::os_support{linux});
my $support = 0;
if ($my_kernel[0] > $support_kernel[0]){
$support = 1;
} elsif (($my_kernel[0] == $support_kernel[0]) &&
($my_kernel[1] > $support_kernel[1])){
$support = 1;
} elsif (($my_kernel[0] == $support_kernel[0]) &&
($my_kernel[1] == $support_kernel[1]) &&
($my_kernel[2] >= $support_kernel[2])){
$support = 1;
}
unless($support){
XB_Log::log "err",
" [$procname] $os $vers (kernel $kern) not supported.\n".
" Must be $XB_Params::os_support{linux} or above.)";
die "vers";
}
}else{
XB_Log::log "err",
" [$procname] $os $vers (kernel $kern) not supported.";
die "os";
}
};
XB_Log::log "info", "<- $modname$procname $os, $vers, $arch, $kern";
return ($os, $vers, $arch, $kern) unless $@;
# exception handling
if($@ !~ /^(open|uname|close|sysctl_read|vers|os)/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Common::node_os caught unexpected exception $@";
}
# pass defined exceptions up to caller
die "$modname$procname";
}
#-> check gif nesting ------------------------------------------------
# Description:
# Check if gif nesting is enabled
# Arguments:
# daemon type
# automode
# Returns:
# 1 on succecss
# Exceptions:
# "check_gifnesting" on error, nothing to clean up by caller
#
sub check_gifnesting($$){
my ($nodetype,$auto) = @_;
my $procname = "check_gifnesting";
XB_Log::log "info", "-> $modname$procname $nodetype $auto";
eval{
unless($nodetype =~ /(meta|om)/i){
if($XB_Params::node_opts{os} =~ /(freebsd|kame|cairn)/i){
my $nesting = sysctl_read('net.link.gif.max_nesting');
if ($nesting < 2) {
if ($auto =~ /(yes)/i){
XB_Log::log "notice",
"Automode default: setting gifnesting to 256";
XB_Utils::sysctl_write('net.link.gif.max_nesting', 256);
} else {
XB_Log::log "err", "Please set sysctl net.link.gif.max_nesting to atleast 2. We recommend 256";
die "nesting";
};
} elsif ($nesting < 256){
XB_Log::log "warning", "We recommend setting sysctl net.link.gif.max_nesting to 256";
}
}
} #unless
}; # eval
XB_Log::log "info", "<- $modname$procname $@ ";
return 1 unless ($@);
if ($@ !~ /(nesting)/){
XB_Log::log "warning", "$modname$procname caught unexpected exception $@";
}
# pass defined exceptions up to caller
die "$modname$procname";
}
#-> check ipsec ------------------------------------------------
# Description:
# Check if ipsec is enabled
# Arguments:
# daemon type
# Returns:
# 1 on succecss
# Exceptions:
# "check_ipsec" on error, nothing to clean up by caller
#
sub check_ipsec($$){
my ($nodetype, $ipproto) = @_;
my $procname = "check_ipsec";
XB_Log::log "info", "-> $modname$procname $nodetype $ipproto";
eval{
if ($XB_Params::node_opts{IPsec} =~ /yes/i){
unless($nodetype =~ /(meta|om)/i){
if($XB_Params::node_opts{os} =~ /(freebsd|kame|cairn)/i){
if ($ipproto =~ /(ipv4|both)/i){
my $ipsec4 = XB_Utils::sysctl_read('net.inet.ipsec.debug');
if (not defined $ipsec4){
XB_Log::log "err", "This kernel does not support IPv4 IPsec. " .
"Please recompile the kernel or disable IPsec by setting IPsec to \"no\".";
die "ipsec";
};
} # ipproto
if ($ipproto =~ /(ipv6|both)/i){
my $ipsec6 = XB_Utils::sysctl_read('net.inet6.ipsec6.debug');
if (not defined $ipsec6){
XB_Log::log "err", "This kernel does not support IPv6 IPsec. " .
"Please recompile the kernel or disable IPsec by setting IPsec to \"no\".";
die "ipsec";
};
}# ipproto
} # freebsd
} #unless
}; # if
}; # eval
XB_Log::log "info", "<- $modname$procname $@ ";
return 1 unless ($@);
if ($@ !~ /(ipsec)/){
XB_Log::log "warning", "$modname$procname caught unexpected exception $@";
}
# pass defined exceptions up to caller
die "$modname$procname";
}
#-> check forwarding ------------------------------------------------
# Description:
# Check if the combination of the node type and proto work
# Arguments:
# $ipproto ipv4/ipv6/both
# $nodetype = meta/node/router/host
# $auto = yes/no (automatic mode)
# Returns:
# 1 on success or exception on error
# Exceptions:
# "check_ipsupport2" on error
# nothing to clean up by caller
# no errors logged if automatic mode is enabled.
#
sub check_ipsupport2($$$){
my ($ipproto, $nodetype,$auto) = @_;
my $procname = "check_ipsupport2";
my ($forward4, $forward6) = (1, 1);
XB_Log::log "info", "-> $modname$procname $ipproto, $nodetype $auto";
my ($var4, $var6);
eval{
# Read the sysctls. Dont print debug messages in case of
# automode.
# check for whether routing is enabled or not.
if($XB_Params::node_opts{os} =~ /linux/i){
#-> Linux
if($ipproto !~ /ipv4/){
XB_Log::log "err", " [$procname] Linux IPv6 is not supported"
if ($auto =~ /no/i);
die "linuxv6";
# enable these when the IPv6 support exists
#$var6 = 'net.ipv6.conf.all.forwarding';
#$forward6 = sysctl_read($var6);
}
if($ipproto !~ /ipv6/){
$var4 = 'net.ipv4.ip_forward';
$forward4 = sysctl_read($var4);
}
}elsif($XB_Params::node_opts{os} =~ /freebsd/i){
#-> FreeBSD
if($ipproto !~ /ipv4/){
$var6 = 'net.inet6.ip6.forwarding';
$forward6 = XB_Utils::sysctl_read($var6);
}
if($ipproto !~ /ipv6/){
$var4 = 'net.inet.ip.forwarding';
$forward4 = XB_Utils::sysctl_read($var4);
}
}elsif($XB_Params::node_opts{os} =~ /cisco/i){
if ($ipproto !~ /ipv4/) {
XB_Log::log "err", " [$procname] Cisco IPv6 is not supported"
if ($auto =~ /no/i);
die "ciscov6";
}
}
else{
XB_Log::log "err", " [$procname] OS $XB_Params::node_opts{os} is ".
"not supported" if ($auto =~ /no/i);
die "os";
}
# for a host/meta check, it is sufficient to not have an exception
# thrown by now.
unless ($XB_Params::node_opts{os} =~ /cisco/i) {
# check if the basic support exists which we do by checking
# if any of the variables is undefined. the platform (linux/
# freebsd) does not matter.
if ($ipproto !~ /ipv6/i and not defined $forward4){
XB_Log::log "err", " [$procname] IPv4 is not supported while the ".
"ipproto is set to" . $XB_Params::node_opts{ipproto} . "\n"
if ($auto =~ /no/i);
die "ipv4";
}
# check for ipv6
if ($ipproto !~ /ipv4/i and not defined $forward6){
XB_Log::log "err", " [$procname] IPv6 is not supported while the ".
"ipproto is set to " . $XB_Params::node_opts{ipproto} . "\n"
if ($auto =~ /no/i );
die "ipv6";
}
# check routing
if ( $nodetype =~ /(router|node)/){
if ( $XB_Params::node_opts{'force-router'}){
if (!$forward4) {
XB_Utils::sysctl_write ($var4) or die "sysctl";
$forward4 = 1;
}
if (!$forward6) {
XB_Utils::sysctl_write ($var6) or die "sysctl";
$forward6 =1 ;
}
}
unless($forward4 and $forward6){
my $msg = "";
$msg .= (!$forward4)? "\n\t(IPv4)\tsysctl -w $var4=1 " : "";
$msg .= (!$forward6)? "\n\t(IPv6)\tsysctl -w $var6=1 " : "";
XB_Log::log "err", " [$procname] XBone node type $nodetype ".
"requires IP forwarding.\n You can run following command(s):".
$msg .
"and restart XBone node daemon.\n Or just restart ".
"Xbone node daemon with option --force-router."
if ($auto =~ /no/i );
die "forward";
}
}; # router/node check
} # except cisco
};
XB_Log::log "info", "<- $modname$procname $@";
return 1 unless $@;
unless($@ =~ /(linuxv6|os|forward|ciscov6|sysctl|ipv6|ipv4)/){
XB_Log::log "warning", " ! $procname caught unkown exception: $@";
}
die "$modname$procname";
}
# Description:
# Check if forwarding is enabled
# Arguments:
# $ipproto ipv4/ipv6/both
# $nodetype meta/node/router/host
# Returns:
# combination of (ipproto, daemontype) that works...
# Exceptions:
# "check_forwarding" on error, nothing to clean up by caller
#
sub check_ipsupport($$){
my ($ipproto, $nodetype) = @_;
my $procname = "check_ipsupport";
my ($forward4, $forward6) = (1, 1);
XB_Log::log "info", "-> $modname$procname $ipproto, $nodetype";
my ($var4, $var6);
eval {
# generate the combination that works from the defaults with
# "decreasing" level in terms of capabilities in some sense.
my @testprotolist = ();
if ($ipproto =~ /(both)/i ){
@testprotolist = ("both", "ipv6", "ipv4");
} else {
@testprotolist = ( $ipproto );
};
my @testtypelist = ( $nodetype );
$_ = $nodetype;
SWITCH: {
/node/ and do {
@testtypelist = ("node", "router", "host");
last SWITCH;
};
/router/ and do {
@testtypelist = ("router", "host");
last SWITCH;
};
last SWITCH;
};
# if the auto is enabled, walk through the list to see
# which combination works. If it does not, then bail
# out.
if ($XB_Params::node_opts{"auto"} =~ /no/i) {
check_ipsupport2($ipproto, $nodetype, "no");
} else {
my $found = 0;
foreach my $testproto (@testprotolist) {
foreach my $testtype (@testtypelist){
$@ = undef;
eval {
check_ipsupport2($testproto, $testtype, "yes");
};
# if exception thrown, try another combo
next if ($@);
# save the values so that they can be returned.
$ipproto = $testproto;
$nodetype = $testtype;
$found = 1;
last;
}
last if ($found);
};
if (! $found){
XB_Log::log "notice",
" Automatic mode of operations. " .
"Unable to find a combination of node type" .
"and ip version that works ";
die ("auto");
}
};
};
XB_Log::log "info", "<- $modname$procname";
return ($ipproto, $nodetype) unless $@;
unless($@ =~ /(check_forwarding|auto)/){
XB_Log::log "warning", " ! $procname caught unkown exception: $@";
}
die "$modname$procname";
};
#-> get addresses from a hostname lookup ----------------------------
# 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:
# "XB_Common::getaddrinfo" on failure, nothing to cleanup by caller
# Notes - The recommended way to lookup IPv4 & IPv6 addresses from hostnames
# is getipnodebyname in dual stack implementations. Perl Socket6
# module (0.11) has bugs in processing this call, so we use
# gethostbyname2 until it's upgraded.
# - Bug on gethostbyname2 of Socket6 0.11: $hostent[4] should be an
# an array of all IP addresses, but they are actually pushed in to
# the main array (@hostent) instead of @{hostent[4]};
sub getaddr($$){
my ($hostname, $ipproto) = @_;
my $procname = "getaddr";
my @addrs;
XB_Log::log "debug1", "-> $modname$procname $hostname, $ipproto";
eval{
unless($hostname =~ /\S+/){
XB_Log::log "err", " [$procname] empty hostname";
die "hostname";
}
unless($ipproto =~ /(ipv6|ipv4)/){
XB_Log::log "err", " [$procname] unknown IP protocol: $ipproto";
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){
XB_Log::log "err", " [$procname] getaddrinfo failed to return ".
"IPv4 addresses for $hostname";
die "getaddrinfo";
};
} else {
@res = getaddrinfo($hostname,
'daytime', # dummy service
AF_INET6);
unless(scalar(@res) >= 5){
XB_Log::log "err", " [$procname] getaddrinfo failed to return ".
"IPv6 addresses for $hostname";
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){
XB_Log::log "err", " [$procname] host $hostname has no IP addresses!";
die "noaddr";
}
# Bring the 2001 addresses to the beginning. It seems to matter
# since the first address is picked.
if($ipproto ne 'ipv4'){
my @new = ();
foreach my $addr (@addrs){
if ($addr =~ /2001/){
@new = ($addr, @new);
} else {
@new = (@new, $addr);
};
};
@addrs = @new;
};
}; #eval
XB_Log::log "debug1", "<- $modname$procname";
return \@addrs unless $@;
unless($@ =~ /(hostname|ipproto|getaddrinfo|noaddr)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# Check if the peer IP address of the given socket handle matches the
# the given hostname.
# Arguments:
# $sock socket handle
# $hostname hostname
# $ipproto ipv4 or ipv6
# Returns:
# (peername, peerport) on succeed
# Exceptions:
# "get_sock_host" on error, nothing to clean up by caller
# Notes:
# Ideally, should use reverse DNS lookup on the IP address of the socket
# with function like gethostbyaddr for IPv4 or getipnodebyaddr for IPv6.
# But given that sysadmins don't always enter reverse DNS entries for
# hostnames, use the given hostname (from certificates or in the cmd) to
# get the IP addresses and check if the socket IP matches any of them.
#
sub chk_sockaddr($$$){
my ($sock, $hostname, $ipproto) = @_;
my ($peername, $peerport, $hostinfo, $peeraddr);
my $procname = "chk_sockaddr";
XB_Log::log "info", "-> $modname$procname @_";
eval{
my $matched = 0;
$peeraddr = $sock->peerhost; #returns the ip address in text
$peerport = $sock->peerport;
my $addrs = getaddr($hostname, $ipproto);
XB_Log::log "debug1", " [$procname] peeraddr: $peeraddr";
XB_Log::log "debug1", " [$procname] $hostname: ". (join ", ", @{$addrs});
for my $a (@{$addrs}){
if($peeraddr eq $a){
$matched = 1;
last;
}
}
unless($matched){
XB_Log::log "err", " [$procname] $peeraddr isn't an address of ".
"$hostname";
die "match";
}
};
XB_Log::log "info", "<- $modname$procname $peeraddr, $peerport";
return ($peeraddr, $peerport) unless $@;
unless($@ =~ /(getaddr|match)/){
XB_Log::log "warning", " ! [$procname] caught unkown exception: $@";
}
die "$modname$procname";
}
# ===========================================================================
# Misc. Utilities
# ===========================================================================
# Description:
# Return value of given sysctl variable $var.
# Arguments:
# $var name of the sysctl variable to read
# Returns:
# $val value of $var if found
# undef if $var not found
# Exceptions:
# "XB_Common::sysctl_read" on failure
sub sysctl_read ($)
{
my $var = shift;
my $val;
my $procname = "sysctl_read";
XB_Log::log "info", "-> $modname$procname $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", " [$procname] cannot open pipe $pipe: $!"
and die "open";
# read the output
$val = <PIPE>;
# done with pipe
close PIPE or not $! or
XB_Log::log "err", " [$procname] cannot close pipe $pipe: $!"
and die "close";
# post-process
if(defined $val) { chomp $val; }
};
XB_Log::log "info", "<- $modname$procname";
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 "$modname$procname";
}
# Description:
# Clean up the application object hash if it exists; also cleanup the
# application deployment scripts if any.
# Arguments:
# $type application type
# $name application name
# Returns:
# 1 on success
# Exception:
# -
sub cleanup_app($$){
my ($type, $name) = @_;
my $procname = $modname. "cleanup_app";
XB_Log::log "info", "-> $procname $type, $name";
if(exists $XB_Params::node_state{active_apps}{$type}{$name}){
my $app = $XB_Params::node_state{active_apps}{$type}{$name};
if(exists $app->{app_deploy}){
for my $appname (keys %{$app->{app_deploy}}){
if(-f $app->{app_deploy}{$appname}{script}){
unlink $app->{app_deploy}{$appname}{script};
}
}
}
delete $XB_Params::node_state{active_apps}{$type}{$name};
}else{
XB_Log::log "warning", " [$procname] $type $name does not exist";
}
return 1;
}
# Description:
# Reset the node state to idle.
# Returns:
# 1
sub reset_state{
$XB_Params::node_state{state} = "idle";
$XB_Params::node_state{creator} = "";
$XB_Params::node_state{application} = "";
$XB_Params::node_state{name} = "";
$XB_Params::node_state{start} = 0;
$XB_Params::node_state{level} = 0;
XB_Log::log "debug1", " -> Rreset node state";
return 1;
}
# Description:
# Check IP version support
# Arguments:
# $ipproto requested
# Returns:
# 1 supported
# 0 not supported
# Exceptions:
# -
sub check_ip($){
my $ipproto = shift;
my $procname = "check_ip";
XB_Log::log "info", "-> $modname$procname $ipproto";
if(lc $ipproto eq $XB_Params::node_opts{ipproto} or
$XB_Params::node_opts{ipproto} eq 'both'){
#XB_Log::log "info", "$str supported";
#return 1;
}else{
XB_Log::log "err", "$ipproto not supported";
die "$modname$procname";
}
XB_Log::log "info", "<- $modname$procname $ipproto";
return 1;
}
# Description:
# Check if a given entity is in the list.
# Arguments:
# $it entity to check
# $list (ref) list to be checked against
# Returns:
# 0 no match
# 1 match
# 2 empty list
# Exceptions:
# -
sub check_list ($$){
my ($it, $list) = @_;
my $procname = $modname. "check_list";
XB_Log::log "info", "-> $procname $it, $list";
if (scalar(@{$list}) > 0){
for my $i (@{$list}){
if($it eq $i){
XB_Log::log "info", "<- $procname - match";
return 1;
}
}
XB_Log::log "info", "<- $procname - no match";
return 0;
}else{
XB_Log::log "info", "<- $procname - empty list";
return -1;
}
}
# Description:
# Check if current conf satisfies request under "yes" & "no" comparison.
# Arguments:
# $name name of the resource or question
# $req request value
# $conf config (available) value
# Returns:
# 1 if satisfied
# 0 if not
# Note:
# satisfied if (req == no) or (req == conf == yes)
#
sub check_resource($$$){
my ($name, $req, $conf) = @_;
my $ok=1;
XB_Log::log "debug1", "-> check [$name] request=$req, configured=$conf";
if ((lc($req) eq 'yes') and (lc($conf) eq 'no')){ $ok = 0; }
XB_Log::log "debug1", "<- check_resource $ok";
return $ok;
}
# Description:
# Check given versions for compatibility.
# Arguments:
# $rver client version
# $lver local version
# $type version for what
# Returns:
# 1 (=) matched
# 0 (>) client > local
# -1 (<) client < local
# Exception:
# -
sub check_vers($$$){
my ($rver, $lver, $type) = @_;
my $result = 1;
XB_Log::log "debug1", "-> check $type version: client=$rver, local=$lver";
# TODO Should decompose versions into sections separated by dot (.) and
# TODO compare each pair until one is greater than the other or reach
# TODO the end of the field and the two are equal.
# TODO Right now, just see if they are the same.
unless($rver eq $lver){ $result = 0; }
XB_Log::log "debug1", "<- check_version $result";
return $result;
}
#
# Description:
# Get a string input from user
# Arguments:
# text for prompt
# optional default value
# Returns:
# the string
# Exceptions:
#
sub get_string ($;$)
{
my ($prompt, $default) = @_;
my ($str, $pat);
while (1)
{
if (defined ($default))
{
print "$prompt: ($default) ";
} else {
print "$prompt: ";
}
$str = <STDIN>;
chomp $str;
if (!$str) {
$str = $default;
};
next if (!$str);
last;
}
return ($str);
}
# Description:
# Add/replace a variable in a configuration file.
# Notes: The idea here is that the user should be
# able to specify any variables that should
# Arguments:
# conffile = configuration file (path)
# var = variable that needs to be updated
# value = new value to be assigned
# multiple = could there be multiple
# instances of this variable
# (only append in this case)
# Returns:
#
# Exceptions:
#
sub update_conf_file($$$;$)
{
my ($conffile, $var, $value, $multiple) = @_;
my @arr = ();
my $done = 0;
if (not defined $multiple) { $multiple = 0; };
# read the existing configuration
if (-f $conffile){
open(CONF, "<$conffile") or die("file");
while(<CONF>){ push @arr, $_ ; };
close(CONF);
};
# open and truncate the file.
open(CONF, "+>$conffile") or
XB_Log::log "err", "Cannot open configuration file $conffile for updating." and
die("file");
# append/replace the configuration line
foreach my $row (@arr){
if (($row =~ /$var/) and ($multiple == 0)){
if ($done == 0){
print CONF "$var = $value\n";
$done = 1;
}
} else {
print CONF $row;
};
};
if ($done == 0){
print CONF "$var = $value\n";
}
close(CONF);
};
# Description:
# Execute the system call and return the results
# Arguments:
# \@cmd : reference of a list
# Returns:
# $msg: output of the command
# Exceptions:
# Cant execute the command
sub execcmd($){
my ($cmd) = @_;
my $cmdline = join (" ", @{$cmd});
my ($cpid, $msg, $status) = (0,"",0);
my $procname = "execcmd";
#XB_Log::log "info", "-> $modname$procname ";
eval {
if ( ($cmd->[0] =~ /\//) and
(! -e $cmd->[0] or ! -x $cmd->[0] )) {
XB_Log::log "err", " [$procname] Script/Executable " .
$cmd->[0] . " does not exist or" .
" does not have the right permissions";
die ("cmd");
}
my @prefix = (\*WTR, \*RDR, \*ERR);
$cpid = open3(@prefix, @{$cmd}) or
XB_Log::log "err", "Unable to execute command. $!: Command failed"
and die "cmd";
if (defined $cpid) {
waitpid $cpid, 0 == $cpid or
XB_Log::log "err", "Operating system resource error. ".
"No child $cpid"
and die "wait";
$status = $? >> 8;
};
# Read all the error messages...
while (<RDR>) { $msg .= $_; }
while (<ERR>) { $msg .= $_; }
#close(WTR);
#close(RDR);
#close(ERR);
};
#XB_Log::log "info", "<- $modname$procname ";
return ($status, $msg) unless $@;
unless($@ =~ /(cmd|wait)/){
XB_Log::log "warning", " ! [$procname] caught unkown exception: $@";
}
die "$modname$procname";
};
1;
syntax highlighted by Code2HTML, v. 0.9.1