GIMSAdmin.cgi 000555 002315 013577 00000056702 11417433047 013540 0 ustar 00cthomas GIMS 000000 000000 #! /usr/bin/perl -w
#=============================================================================
# G I M S A D M I N . C G I
#
# GIMS project administration tool
# Written by C. Thomas
#
# $Id: GIMSAdmin.cgi,v 1.7 2010/07/14 22:11:30 cthomas Exp $
#=============================================================================
#=============================================================================
# U S E / R E Q U I R E
#=============================================================================
use CGI qw(:standard);
use CGI::Carp ('fatalsToBrowser'); # Send any errors to the browser
use XML::RPC;
use XML::Simple qw(:strict); # for converting XML <=> hash
use Data::Dumper; # debugging data structures
use POSIX; # for strftime
use CGI::Cookie; # to handle cookies
use XmlRpcUtils; # for writing XML/RPC code
use GIMSDBUtils; # to connect to database
use GIMSJavascript; # for javascript magic
use strict;
#=============================================================================
# P R O T O T Y P E S
#=============================================================================
sub getParams();
sub printModeSelectForm($);
sub printEditDeviceForm($$;$;$);
sub printDeleteDeviceForm($$$);
sub processEditDevice($);
sub writeToLog(;$);
sub getTimestamp();
sub printJavascript();
#=============================================================================
# C O N F I G
#=============================================================================
my $this_script = 'http://www.schooner.wail.wisc.edu/gims/GIMSAdmin.cgi';
my $agg_man_url = 'http://www.schooner.wail.wisc.edu/gims/gims_aggregate_manager.cgi';
my $log_file = 'gims_admin.log';
my $javascript_file = 'GIMSControl.js';
#=============================================================================
# P A R A M E T E R S
#=============================================================================
my $mode = '';
my $device_location = '';
my $device_name = '';
my $device_type = '';
my $hostname = '';
my $device_port = '';
my $descr = '';
my $selected_loc = '';
my $selected_dev = '';
#=============================================================================
# G L O B A L V A R I A B L E S
#=============================================================================
my $dbh = undef;
my $cgi_obj = undef;
my $username = undef;
my $LOG = undef;
my %device_info = ();
my %cur_devices = ();
my @aggregation_types = ('none','combine_pkt_flows','count_pkts');
my %device_caps = ('storage_types'=>{'local'=>0,
's3'=>0,
'ssh'=>0},
'anon_types' => {'none'=>0,'anonymize'=>0},
'filter_types' => {'src_addr'=>0,'dst_addr'=>0,
'src_port'=>0,'dst_port'=>0,
'protocol'=>0,'vlan_num'=>0},
'protocol_types' => {'tcp'=>0,
'udp'=>0,
'icmp'=>0},
'sampling_types' => {'none'=>0,
'everyN'=>0,
'uniformrandom'=>0},
'aggregation_types' => {'none'=>0,
'combine_pkt_flows'=>0,
'count_pkts'=>0},
'misc' => {'libpcap_strings'=>0,
'metadata'=>0},
);
#=============================================================================
# M A I N
#=============================================================================
$| = 1; # set to unbuffered display
#===== Get a CGI object
$cgi_obj = new CGI or die "Unable to create CGI object!\n";
#===== Get all parameters passed into the script
getParams();
#===== Get a database handle
$dbh = GIMSDBUtils::getDBHandle();
die "Could not connect to database!\n" unless ref($dbh);
#==== Open log file
unless(open($LOG, ">>$log_file"))
{
warn "Couldn't open log file! : $!\n";
}
#===== Print HTML header stuff
print "Content-type: text/html\n\n";
print qq~\n~;
print qq~\n~;
print qq~
\n~;
print "
GIMSAdmin.cgi\n";
print "\n";
#===== Banner
print qq~\n~;
#===== User logged in?
if ($username)
{
print "
User $username logged in.
\n";
}
else
{
print "
User authentication not obtained.
\n";
}
#===== Configure experiment mode
if ($mode and $mode eq 'add_device')
{
#===== Set defaults for device capabilities
$device_caps{aggregation_types}{none} = 1;
$device_caps{anon_types}{none} = 1;
$device_caps{filter_types}{protocol} = 1;
$device_caps{filter_types}{vlan_num} = 1;
$device_caps{misc}{metadata} = 1;
$device_caps{misc}{libpcap_strings} = 1;
$device_caps{sampling_types}{none} = 1;
$device_caps{storage_types}{local} = 1;
GIMSDBUtils::getDeviceInfo($dbh, \%cur_devices);
printEditDeviceForm(\%cur_devices, \%device_caps);
}
elsif ($mode and $mode eq 'edit_device')
{
my $xml_code = '';
#===== Get info for current devices
GIMSDBUtils::getDeviceInfo($dbh, \%cur_devices);
#===== Get the XML/RPC representation of the selected device's
# capabilities
$xml_code = $cur_devices{$selected_loc}{$selected_dev}{'capabilities'};
#====== Set the device capabilities hash to current settings
XmlRpcUtils::getDeviceCapsHash($xml_code, \%device_caps);
#===== Print the device form
printEditDeviceForm(\%cur_devices, \%device_caps,
$selected_loc, $selected_dev);
}
elsif ($mode and $mode eq 'delete_device')
{
GIMSDBUtils::getDeviceInfo($dbh, \%cur_devices);
printDeleteDeviceForm(\%cur_devices, $selected_loc, $selected_dev);
}
elsif ($mode and $mode eq 'process_add_device')
{
processEditDevice(\%device_info);
}
elsif ($mode and $mode eq 'process_edit_device')
{
my %edit_device = ();
GIMSDBUtils::getDeviceInfo($dbh, \%cur_devices);
$edit_device{'location'} = $selected_loc;
$edit_device{'device_name'} = $selected_dev;
$edit_device{'type'} = $cur_devices{$selected_loc}{$selected_dev}{'type'};
$edit_device{'hostname'} = $cur_devices{$selected_loc}{$selected_dev}{'hostname'};
$edit_device{'port'} = $cur_devices{$selected_loc}{$selected_dev}{'port'};
$edit_device{'descr'} = $cur_devices{$selected_loc}{$selected_dev}{'descr'};
$edit_device{'capabilities'} = $device_info{'capabilities'};
GIMSDBUtils::getDeviceInfo($dbh, \%cur_devices);
processEditDevice(\%edit_device);
}
elsif ($mode and $mode eq 'process_delete_device')
{
GIMSDBUtils::getDeviceInfo($dbh, \%cur_devices);
processDeleteDevice(\%cur_devices, $selected_loc, $selected_dev);
}
else
{
GIMSDBUtils::getDeviceInfo($dbh, \%cur_devices);
printModeSelectForm(\%cur_devices);
}
#==== Print HTML footer stuff
print "
\n";
print end_html, "\n";
#===== Print javascript
printJavascript();
#===== Disconnect from database
$dbh->disconnect;
exit;
######################### BEGIN SUBROUTINES ##################################
#=============================================================================
# G E T P A R A M S
#=============================================================================
sub getParams()
{
if ($ENV{REMOTE_USER})
{
$username = $ENV{REMOTE_USER};
}
#===== Get basic info
if (param('mode')){ $mode = param( 'mode');}
if (param('device_location')){ $device_location = param( 'device_location');}
if (param('device_name')){ $device_name = param( 'device_name');}
if (param('device_type')){ $device_type = param( 'device_type');}
if (param('hostname')){ $hostname = param( 'hostname');}
if (param('device_port')){ $device_port = param( 'device_port');}
if (param('descr')){ $descr = param( 'descr');}
#===== Get capabilities
my @params = $cgi_obj->param;
foreach my $param (@params)
{
my ($struct, $member) = split('::', $param);
if ($struct and $member)
{
push(@{$device_info{'capabilities'}{$struct}},$member);
}
}
#===== Store basic info
$device_info{'location'} = $device_location;
$device_info{'device_name'} = $device_name;
$device_info{'type'} = $device_type;
$device_info{'hostname'} = $hostname;
$device_info{'port'} = $device_port;
$device_info{'descr'} = $descr;
#===== Selected device
if (param('selected_loc')){$selected_loc = param('selected_loc');}
if (param('selected_dev'))
{
$selected_dev = param( 'selected_dev');
if ($selected_dev =~ m/\:\:/)
{
($selected_loc, $selected_dev) = split('::', $selected_dev);
}
}
return;
} # end of getParams()
#=============================================================================
# P R I N T M O D E S E L E C T F O R M
#
# Arg1: Hash ref containing device info
#=============================================================================
sub printModeSelectForm($)
{
my $device_ref = shift or
die "Must supply hash ref to printModeSelectForm()!\n";
print "
GIMS Administration Tool
\n";
print "
\n";
print qq~
\n";
return;
} # end of printModeSelectForm()
#=============================================================================
# P R I N T E D I T D E V I C E F O R M
#=============================================================================
sub printEditDeviceForm($$;$;$)
{
my $dev_info_ref = shift or
die "Must supply device info hash ref to printEditDeviceForm()!\n";
my $caps_ref = shift or
die "Must supply device caps hash ref to printEditDeviceForm()!\n";
my $edit_loc = shift;
my $edit_dev = shift;
my $edit_type = '';
my $edit_hostname = '';
my $edit_port = '';
my $edit_descr = '';
print "
GIMS Administration Tool
\n";
print "
\n";
#===== Get info
if ($edit_loc and $edit_dev)
{
$edit_type = $dev_info_ref->{$edit_loc}{$edit_dev}{'type'};
$edit_hostname = $dev_info_ref->{$edit_loc}{$edit_dev}{'hostname'};
$edit_port = $dev_info_ref->{$edit_loc}{$edit_dev}{'port'};
$edit_descr = $dev_info_ref->{$edit_loc}{$edit_dev}{'descr'};
}
print qq~
\n";
return;
} # end of printEditDeviceForm()
#=============================================================================
# P R I N T D E L E T E D E V I C E F O R M
#=============================================================================
sub printDeleteDeviceForm($$$)
{
my $info_ref = shift or
die "Must supply hash ref to printDeleteDeviceForm()!\n";
my $del_loc = shift or
die "Must supply a location to printDeleteDeviceForm()!\n";
my $del_dev = shift or
die "Must supply a device_name to printDeleteDeviceForm()!\n";
print "
GIMS Administration Tool
\n";
print "
\n";
print qq~
\n";
return;
} # end of printDeleteDeviceForm()
#=============================================================================
# P R O C E S S E D I T D E V I C E
# Arg1: Hash ref holding device info
#=============================================================================
sub processEditDevice($)
{
my $info_ref = shift or
die "Must supply hash ref to processEditDevice()!\n";
my $log_str = '';
#===== Get info from hash
my $location = $info_ref->{'location'};
my $device_name = $info_ref->{'device_name'};
my $type = $info_ref->{'type'};
my $hostname = $info_ref->{'hostname'};
my $port = $info_ref->{'port'};
my $descr = $info_ref->{'descr'};
my $caps = $info_ref->{'capabilities'};
#===== Get the XML code from the hash
my $xml_code = XmlRpcUtils::getDeviceCapsXML($caps);
$info_ref->{'capabilities'} = $xml_code;
$xml_code =~ s/>/>/g;
$xml_code =~ s/</g;
#===== Write the change to the database
my $errors = GIMSDBUtils::updateDevice($dbh, $info_ref);
if ($errors)
{
print "ERROR: $errors!
\n";
}
else
{
print "Device update successful!
\n";
}
#===== Print the info sent to DB
print "Location: $location \n";
print "Device Name: $device_name \n";
print "Type: $type \n";
print "Hostname: $hostname \n";
print "Port: $port \n";
print "Descr: $descr \n";
print "Capabilities (as XML/RPC): \n";
print "
$xml_code
";
print "
\n";
#===== Return to start link
print qq~Return to Start\n~;
#===== Write to the log
if ($mode eq 'process_add_device')
{
$log_str = "Added device $location:$device_name to database.\n";
}
else
{
$log_str = "Edited device $location:$device_name in database.\n";
}
writeToLog($log_str);
return;
} # end of processEditDevice()
#=============================================================================
# P R O C E S S D E L E T E D E V I C E
# Arg1: Hash ref holding device info
#=============================================================================
sub processDeleteDevice($$$)
{
my $info_ref = shift or
die "Must supply hash ref to processDeleteDevice()!\n";
my $del_loc = shift or
die "Must supply location to processDeleteDevice()!\n";
my $del_dev = shift or
die "Must supply device_name to processDeleteDevice()!\n";
#===== Get info from hash
my $type = $info_ref->{$del_loc}{$del_dev}{'type'};
my $hostname = $info_ref->{$del_loc}{$del_dev}{'hostname'};
my $port = $info_ref->{$del_loc}{$del_dev}{'port'};
my $descr = $info_ref->{$del_loc}{$del_dev}{'descr'};
#===== Update the database
my $errors = GIMSDBUtils::deleteDevice($dbh, $del_loc, $del_dev);
#===== Print device info
print "Deleted Device: \n";
print " Location: $del_loc \n";
print " Device Name: $del_dev \n";
print " Type: $type \n";
print " Hostname: $hostname \n";
print " Port: $port \n";
print " Description: $descr \n";
print "
\n";
if ($errors)
{
print "ERROR: $errors!
\n";
}
else
{
print "Device deleted successfully!
\n";
}
#===== Return to start link
print qq~Return to Start\n~;
#===== Write to the log
my $log_str = "Deleted device $del_loc:$del_dev in database.\n";
writeToLog($log_str);
return;
} # end of processDeleteDevice()
#===========================================================
# W R I T E T O L O G
#===========================================================
sub writeToLog(;$)
{
my $output_str = shift;
if ($output_str)
{
print $LOG getTimestamp() . ": ";
print $LOG $output_str;
}
return;
} # end of writeToLog()
#===========================================================
# G E T T I M E S T A M P
#===========================================================
sub getTimestamp()
{
return(strftime("%Y-%m-%d %H:%M:%S", localtime));
} # end of getTimestamp()
#===========================================================
# P R I N T J A V A S C R I P T
#===========================================================
sub printJavascript()
{
print <<"EOF";
\n";
} # end of printJavascript()
GIMSControl.cgi 000755 002315 013577 00000115500 11417674322 014125 0 ustar 00cthomas GIMS 000000 000000 #! /usr/bin/perl -w
#=============================================================================
# G I M S C O N T R O L . C G I
#
# Test widget for GIMS project
# Written by C. Thomas
#
# $Id: GIMSControl.cgi,v 1.36 2010/07/12 20:28:08 cthomas Exp cthomas $
#=============================================================================
#=============================================================================
# U S E / R E Q U I R E
#=============================================================================
use CGI qw(:standard);
use CGI::Carp ('fatalsToBrowser'); # Send any errors to the browser
use XML::RPC;
use XML::Simple qw(:strict); # for converting XML <=> hash
use Data::Dumper; # debugging data structures
use CGI::Cookie; # to handle cookies
use XmlRpcUtils; # for writing XML/RPC code
use GIMSDBUtils; # to connect to database
use GIMSAuth; # for user authentication
use GIMSJavascript; # for javascript magic
use strict;
#=============================================================================
# P R O T O T Y P E S
#=============================================================================
sub getParams($);
# Print
sub printSetParamsForm();
sub printControlForm(;$);
sub printActionSelectForm($$);
sub printConfigResultsPage(;$);
sub printExperimentStatusPage(;$);
sub printExperimentSettingsPage(;$);
# Handle
sub handleCommand($$);
# Utils
sub getDeviceCapsFromXML($);
sub sendXMLToServer($$);
sub createLibpcapString($);
sub getCookies();
#=============================================================================
# C O N F I G
#=============================================================================
my $this_script = 'http://www.schooner.wail.wisc.edu/gims/GIMSControl.cgi';
my $agg_man_url = 'http://www.schooner.wail.wisc.edu/gims/gims_aggregate_manager.cgi';
my $log_file = 'gims_backend.log';
my $javascript_file = 'GIMSControl.js';
#=============================================================================
# P A R A M E T E R S
#=============================================================================
my $mode = '';
my $control_action = '';
my $site_location = '';
my $device_name = '';
my $device_hostname = '';
my $device_port = '';
my @monitor_locations = ();
my $storage_type = '';
my $local_storage_dir = '';
my $s3key = '';
my $s3secret = '';
my $s3bucket = '';
my $sshuser = '';
my $sshhost = '';
my $sshport = '';
my $sshpath = '';
my $sshkey = '';
my $rollover_interval = '';
my $filter_host_addr = '';
my $host_addr = '';
my $filter_src_addr = '';
my $src_addr = '';
my $filter_dst_addr = '';
my $dst_addr = '';
my $filter_src_port = '';
my $src_port = '';
my $filter_dst_port = '';
my $dst_port = '';
my $filter_protocol = '';
my $protocol_type = '';
my $filter_bit_comp = '';
my $sampling_type = '';
my $sampling_param = '';
my $interval_secs = '';
my $aggregation_type = '';
my $anon_type = '';
my $libpcap_string = '';
my $vlan_num = '';
my $experiment_id = '';
my $meta_data_text = '';
#=============================================================================
# G L O B A L V A R I A B L E S
#=============================================================================
my %experiment_params = ();
my %filter_types = ();
my %storage_types = ();
my @sampling_types = ();
my @protocol_types = ();
my @aggregation_types = ();
my @anon_types = ();
my $username = '';
my $dbh = undef;
my $LOG = undef;
#=============================================================================
# M A I N
#=============================================================================
$| = 1; # set to unbuffered display
#===== Get a database handle
$dbh = GIMSDBUtils::getDBHandle();
die "Could not connect to database!\n" unless ref($dbh);
#==== Open log file
unless(open($LOG, ">>$log_file"))
{
warn "Couldn't open log file! : $!\n";
}
#===== Print HTML header stuff
print "Content-type: text/html\n\n";
print qq~\n~;
print qq~\n~;
print qq~
\n~;
print "
GIMSControl.cgi\n";
print "\n";
#===== Banner
print qq~\n~;
#===== Get the experiment params
getParams(\%experiment_params);
#===== Authentication
my ($code, $status) = GIMSAuth::checkAuth();
if ($code)
{
print "
\n";
}
#===== Handle cookies
getCookies();
#===== Configure experiment mode
if ($mode and $mode eq 'configure_experiment')
{
# NOTE: experiment_params hash is filled by getParams() sub.
#===== Communicate with device
my $response = handleCommand(\%experiment_params, $agg_man_url);
#===== Display Results
printConfigResultsPage($response);
} # configure_experiment
#===== Get capture params mode
elsif ($mode and $mode eq 'get_capture_params')
{
#===== Set up params
my %params = ();
$params{MethodName} = 'GetDeviceCapabilities';
$params{ExperimentID} = $experiment_id;
$params{SiteLocation} = $site_location;
$params{DeviceName} = $device_name;
#===== Communicate with database
my $response = handleCommand(\%params, $agg_man_url);
#===== Display Form
print "
Setup GIMS Capture Parameters
\n";
print $response;
if ($response !~ m/ERROR/)
{
printSetParamsForm();
}
#===== Return to start link
print qq~Return to Start\n~;
} # get_capture_params
#===== Capture control mode
elsif ($mode and $mode eq 'capture_control')
{
my $response = '';
#===== If we have an action already submitted, push it to the device
if ($control_action)
{
#===== Write XML:RPC code
my %control = ();
$control{'MethodName'} = $control_action;
$control{'ExperimentID'} = $experiment_id;
#===== Communicate with database
$response = handleCommand(\%control, $agg_man_url);
} # if we're processing a previously-submitted action
#===== Print the rest of the control form
printControlForm($response);
} # capture_control
elsif ($mode and $mode eq 'get_status')
{
#===== Write XML::RPC code
my %params = ();
$params{'MethodName'} = 'GetExperimentStatus';
$params{'ExperimentID'} = $experiment_id;
#===== Communicate with device
my $response = handleCommand(\%params, $agg_man_url);
#===== Print the results page
printExperimentStatusPage($response);
}
elsif ($mode and $mode eq 'get_settings')
{
my %params = ();
$params{'MethodName'} = 'GetExperimentSettings';
$params{'ExperimentID'} = $experiment_id;
#===== Communicate with device
my $response = handleCommand(\%params, $agg_man_url);
#===== Print the results page
printExperimentSettingsPage($response);
}
#===== Mode select
else
{
my %devices = ();
my %experiments = ();
print "
Welcome to GIMS!
\n";
print "\n";
#===== Get location/device info
GIMSDBUtils::getDeviceInfo($dbh, \%devices);
#===== Get experiment info
GIMSDBUtils::getExperimentInfo($dbh, \%experiments, '', 'true');
#===== Print the form
printActionSelectForm(\%devices, \%experiments);
}
#==== Print HTML footer stuff
print "
\n";
print end_html, "\n";
#===== Print javascript
GIMSJavascript::printJavascript();
#===== Disconnect from database
$dbh->disconnect;
exit;
######################### BEGIN SUBROUTINES ##################################
#=============================================================================
# G E T P A R A M S
#=============================================================================
sub getParams($)
{
my $config_ref = shift or
die "Must supply hash ref to getParams()!\n";
if ($ENV{REMOTE_USER})
{
$username = $ENV{REMOTE_USER};
}
if (param('mode')){ $mode = param( 'mode');}
#===== Capture settings
if (param('monitor_locations')){ @monitor_locations = param('monitor_locations');}
if (param('storage_type')){ $storage_type = param( 'storage_type');}
if (param('local_storage_dir')){ $local_storage_dir = param('local_storage_dir');}
if (param('s3key')){ $s3key = param( 's3key');}
if (param('s3secret')){ $s3secret = param( 's3secret');}
if (param('s3bucket')){ $s3bucket = param( 's3bucket');}
if (param('sshuser')){ $sshuser = param( 'sshuser');}
if (param('sshhost')){ $sshhost = param( 'sshhost');}
if (param('sshport')){ $sshport = param( 'sshport');}
if (param('sshpath')){ $sshpath = param( 'sshpath');}
if (param('sshkey')){ $sshkey = param( 'sshkey');}
if (param('rollover_interval')){ $rollover_interval = param('rollover_interval');}
if (param('filter_src_addr')){ $filter_src_addr = param( 'filter_src_addr');}
if (param('src_addr')){ $src_addr = param( 'src_addr');}
if (param('filter_dst_addr')){ $filter_dst_addr = param( 'filter_dst_addr');}
if (param('dst_addr')){ $dst_addr = param( 'dst_addr');}
if (param('filter_src_port')){ $filter_src_port = param( 'filter_src_port');}
if (param('src_port')){ $src_port = param( 'src_port');}
if (param('filter_dst_port')){ $filter_dst_port = param( 'filter_dst_port');}
if (param('dst_port')){ $dst_port = param( 'dst_port');}
if (param('filter_protocol')){ $filter_protocol = param( 'filter_protocol');}
if (param('protocol_type')){ $protocol_type = param( 'protocol_type');}
if (param('filter_bit_comp')){ $filter_bit_comp = param( 'filter_bit_comp');}
if (param('sampling_type')){ $sampling_type = param( 'sampling_type');}
if (param('sampling_param')){ $sampling_param = param( 'sampling_param');}
if (param('interval_secs')){ $interval_secs = param( 'interval_secs');}
if (param('aggregation_type')){ $aggregation_type = param( 'aggregation_type');}
if (param('libpcap_string')) {$libpcap_string = param( 'libpcap_string');}
if (param('control_action')) {$control_action = param( 'control_action');}
if (param('site_location')) {$site_location = param( 'site_location');}
if (param('device_name'))
{
$device_name = param('device_name');
if ($device_name =~ m/\:/)
{
($site_location, $device_name) = split(':', $device_name);
}
}
if (param('experiment_id')) {$experiment_id = param( 'experiment_id');}
if (param('meta_data_text')) {$meta_data_text = param( 'meta_data_text');}
if (param('vlan_num')) {$vlan_num = param( 'vlan_num');}
if (param('anon_type')) {$anon_type = param( 'anon_type');}
#===== Create a new libpcap string
my %libpcap_info = ();
$libpcap_info{'filter_src_addr'} = $filter_src_addr;
$libpcap_info{'src_addr'} = $src_addr;
$libpcap_info{'filter_dst_addr'} = $filter_dst_addr;
$libpcap_info{'dst_addr'} = $dst_addr;
$libpcap_info{'filter_src_port'} = $filter_src_port;
$libpcap_info{'src_port'} = $src_port;
$libpcap_info{'filter_dst_port'} = $filter_dst_port;
$libpcap_info{'dst_port'} = $dst_port;
$libpcap_info{'filter_protocol'} = $filter_protocol;
$libpcap_info{'protocol_type'} = $protocol_type;
$libpcap_info{'libpcap_string'} = $libpcap_string;
$libpcap_string = createLibpcapString(\%libpcap_info);
#===== Store selected capture settings in a hash
$config_ref->{'MethodName'} = 'ConfigureExperiment';
$config_ref->{'ExperimentID'} = $experiment_id;
$config_ref->{'VLAN'} = $vlan_num;
$config_ref->{'DeviceName'} = $device_name;
$config_ref->{'SiteLocation'} = $site_location;
# MetaDataSpec
$config_ref->{'MetaDataSpec'}{'UserText'} = $meta_data_text;
# CaptureSpec
$config_ref->{'CaptureSpec'}{'filterexpr'} = $libpcap_string;
$config_ref->{'CaptureSpec'}{'device'} = $device_name;
# TransformSpec
$config_ref->{'TransformSpec'}{'SampleSpec'}{'sampletype'} = $sampling_type;
$config_ref->{'TransformSpec'}{'SampleSpec'}{'sampleparams'}{'N'} = $sampling_param;
$config_ref->{'TransformSpec'}{'SampleSpec'}{'sampleparams'}{'p'} = $sampling_param;
# AnonSpec
$config_ref->{'AnonSpec'}{'anontype'} = $anon_type;
# AggregationSpec
$config_ref->{'AggregationSpec'}{'aggtype'} = $aggregation_type;
# StorageSpec
$config_ref->{'StorageSpec'}{'storagetype'} = $storage_type;
$config_ref->{'StorageSpec'}{'storageparams'}{'local_storage_dir'} = $local_storage_dir;
$config_ref->{'StorageSpec'}{'storageparams'}{'s3key'} = $s3key if $s3key;
$config_ref->{'StorageSpec'}{'storageparams'}{'s3secret'} = $s3secret if $s3secret;
$config_ref->{'StorageSpec'}{'storageparams'}{'s3bucket'} = $s3bucket if $s3bucket;
$config_ref->{'StorageSpec'}{'storageparams'}{'sshuser'} = $sshuser if $sshuser;
$config_ref->{'StorageSpec'}{'storageparams'}{'sshhost'} = $sshhost if $sshhost;
$config_ref->{'StorageSpec'}{'storageparams'}{'sshport'} = $sshport if $sshport;
$config_ref->{'StorageSpec'}{'storageparams'}{'sshpath'} = $sshpath if $sshpath;
$config_ref->{'StorageSpec'}{'storageparams'}{'sshkey'} = $sshkey if $sshkey;
$config_ref->{'StorageSpec'}{'storageparams'}{'rollover_interval'} = $rollover_interval if $rollover_interval;
return;
} # end of getParams()
#=============================================================================
# P R I N T S E T P A R A M S F O R M
# Build the GUI based on capabilities received by
# getActionInfo()
#=============================================================================
sub printSetParamsForm()
{
print qq~
\n";
return;
} # end of printSetParamsForm()
#=============================================================================
# P R I N T C O N T R O L F O R M
#=============================================================================
sub printControlForm(;$)
{
my $result = shift;
print "
\n";
return;
} # end of printControlForm()
#=============================================================================
# P R I N T A C T I O N S E L E C T F O R M
#=============================================================================
sub printActionSelectForm($$)
{
my $devices_ref = shift or
die "Must supply device hash ref to printActionSelectForm()!\n";
my $exp_ref = shift or
die "Must supply experiment hash ref to printActionSelectForm()!\n";
print qq~\n";
return;
} # end of printActionSelectForm()
#=============================================================================
# P R I N T C O N F I G R E S U L T S P A G E
#=============================================================================
sub printConfigResultsPage(;$)
{
my $results = shift;
#===== Print our header
print "\n";
print "
GIMS: Results
\n";
print "\n";
#===== Print response string
print $results if $results;
#===== Return to start link
print "
\n";
print qq~Return to Start\n~;
#===== Hidden fields
print qq~\n~;
return;
} # end of printConfigResultsPage()
#=============================================================================
# P R I N T E X P E R I M E N T S T A T U S P A G E
#=============================================================================
sub printExperimentStatusPage(;$)
{
my $result = shift;
print "
\n";
print $result if $result;
#===== Return to start link
print qq~Return to Start\n~;
return;
} # end of printExperimentStatusPage()
#=============================================================================
# P R I N T E X P E R I M E N T S E T T I N G S P A G E
#=============================================================================
sub printExperimentSettingsPage(;$)
{
my $result = shift;
print "
\n";
print $result if $result;
#===== Return to start link
print qq~Return to Start\n~;
return;
} # end of printExperimentSettingsPage()
#=============================================================================
# H A N D L E C O M M A N D
#
# Arg1: Hash ref containing experiment settings.
# Arg2: The aggregate manager.
#=============================================================================
sub handleCommand($$)
{
my $exp_params_ref = shift or
die "Must supply hash ref to handleCommand()!\n";
my $agg_man_url = shift or
die "Must supply aggregate manager URL to handleCommand()!\n";
my $response = '';
my $parse_result = '';
#===== Generate the XML code
my $xml_code = XmlRpcUtils::getXMLFromHash($exp_params_ref);
# DEBUG
#my $debug_code = $xml_code;
#$debug_code =~ s/</g;
#$debug_code =~ s/>/>/g;
#print "
$debug_code
\n";
#===== Send XML code to server
my ($agr_mgr_data, $device_response_data) = sendXMLToServer($xml_code,
$agg_man_url);
#===== Get device capabilities from XML, if appropriate
if ($device_response_data =~ m/^<\?xml version/)
{
$parse_result = getDeviceCapsFromXML($device_response_data);
}
#===== Print the response from the GIMS Aggregate Manager
if ($agr_mgr_data or $device_response_data)
{
#===== Convert from XML to HTML
$agr_mgr_data =~ s/</g;
$agr_mgr_data =~ s/>/>/g;
if ($agr_mgr_data)
{
$response .= "";
$response .= "Received data from GIMS Aggregate Manager:";
$response .= " \n";
$response.= "$agr_mgr_data
\n";
}
if ($parse_result)
{
$response .= "";
$response .= "Result of parsing XML to get Device Capabilities:";
$response .= " \n";
$response.= "$parse_result
\n";
}
if ($device_response_data and !$parse_result)
{
$device_response_data = XmlRpcUtils::getResponseString($device_response_data);
$response .= "";
$response .= "Received response from device:";
$response .= " \n";
$response .= "$device_response_data
\n";
}
} # if we have results to display
else
{
$response .= "ERROR: Did not obtain a response from GIMS ";
$response .= "Aggregate Manager ($agg_man_url)!\n"
}
return ($response);
} # end of handleCommand()
#===========================================================
# G E T D E V I C E C A P S F R O M X M L
#
# Arg1: The XML text to be parsed
#===========================================================
sub getDeviceCapsFromXML($)
{
my $xml = shift or
die("Must supply XML code to getDeviceCapsFromXML()!\n");
my $result = '';
my $got_params = '';
# Debug
#my $xml_safe = $xml;
#$xml_safe =~ s/</g;
#$xml_safe =~ s/>/>/g;
#$xml_safe =~ s/\n/ /g;
#print "$xml_safe
";
#===== Use XML::Simple to turn the XML code into a hash
my $xml_ref = XMLin($xml, forcearray => 0, keyattr => ['name']);
# Debug
#$Data::Dumper::Indent = 1;
#return(Dumper($xml_ref));
#===== Check for faults
my ($fault_code, $fault_string) = XmlRpcUtils::checkForFault($xml);
#===== Handle faults
if ($fault_string)
{
$result = $fault_string;
}
else
{
#===== Get the response value from the hash
foreach my $param_name (keys %{$xml_ref->{params}{param}{value}{struct}{member}})
{
my @array_contents = ();
#===== Handle members that are strings
if ($param_name eq 'device_name')
{
$device_name = $xml_ref->{params}{param}{value}{struct}{member}{$param_name}{value}{string};
#$result .= "Reading device name => '$device_name'\n";
$got_params = 1;
}
elsif ($param_name eq 'site_location')
{
$site_location = $xml_ref->{params}{param}{value}{struct}{member}{$param_name}{value}{string};
#$result .= "Reading site_location => '$site_location'\n";
}
elsif ($param_name eq 'device_hostname')
{
$device_hostname = $xml_ref->{params}{param}{value}{struct}{member}{$param_name}{value}{string};
#$result .= "Reading device hostname => '$device_hostname'\n";
}
elsif ($param_name eq 'device_port')
{
$device_port = $xml_ref->{params}{param}{value}{struct}{member}{$param_name}{value}{string};
#$result .= "Reading device port => '$device_port'\n";
}
#===== Handle members that are arrays
else
{
foreach my $value_ref (@{$xml_ref->{params}{param}{value}{struct}{member}{$param_name}{value}{array}{data}{value}})
{
# Pull out the array of values
push(@array_contents, $value_ref->{string});
}
if ($param_name eq 'monitor_locations')
{
@monitor_locations = @array_contents;
#$result .= "Reading monitor locations...\n";
}
elsif ($param_name eq 'storage_types')
{
#===== Store as a hash because these are mostly boolean-type values
foreach my $type (@array_contents)
{
$storage_types{$type} = 1;
}
#$result .= "Reading storage locations...\n";
}
elsif ($param_name eq 'filter_types')
{
$result .= "Reading filtering types...\n";
#===== Store as a hash because these are mostly boolean-type values
foreach my $cap (@array_contents)
{
$filter_types{$cap} = 1;
}
#$result .= "Reading filtering types...\n";
}
elsif ($param_name eq 'protocol_types')
{
@protocol_types = @array_contents;
#$result .= "Reading protocol types...\n";
}
elsif ($param_name eq 'sampling_types')
{
@sampling_types = @array_contents;
#$result .= "Reading sampling types...\n";
}
elsif ($param_name eq 'aggregation_types')
{
@aggregation_types = @array_contents;
#$result .= "Reading aggregation types...\n";
}
elsif ($param_name eq 'anon_types')
{
@anon_types = @array_contents;
#$result .= "Reading aggregation types...\n";
}
} # array values
} # for each param
if ($got_params)
{
$result = "Unpacked device capabilities: location='$site_location', device='$device_name'";
} # if we got a param
} # no faults
return($result);
} # end of getDeviceCapsFromXML()
#=============================================================================
# S E N D X M L T O S E R V E R
# Arg1: The XML-RPC code to send
# Arg2: The URL of the aggregate manager
# Returns: The response from the aggregate manager and the
# response from the device.
#=============================================================================
sub sendXMLToServer($$)
{
my $xml_code = shift or
die "Must supply XML code to sendXMLToServer()!\n";
my $agg_man_url = shift or
die "Must supply aggregate manager URL to sendXMLToServer()!\n";
my $raw_xml_response = '';
my $agr_mgr_data = '';
my $device_response_data = '';
#===== Open a connection to the XML:RPC server
my $xmlrpc = XML::RPC->new($agg_man_url);
#===== Send call to server and obtain XML-RPC response
# in the form of a object
$raw_xml_response = $xmlrpc->call($xml_code);
#===== Check for faults
my ($fault_code, $fault_string) = XmlRpcUtils::checkForFault($raw_xml_response);
if ($fault_string)
{
$agr_mgr_data = "Fault detected!";
$device_response_data = $fault_string;
}
else
{
#===== Parse the XML-RPC code to a hash
my $hr = XMLin($raw_xml_response, forcearray => 0, keyattr =>['name']);
#===== Get the response values from the hash
$agr_mgr_data = $hr->{params}{param}{value}{struct}{member}{'agr_mgr_data'}{value}{string};
$device_response_data = $hr->{params}{param}{value}{struct}{member}{'device_response_data'}{value}{string};
}
return($agr_mgr_data, $device_response_data);
} # end of sendXMLToServer()
#===========================================================
# W R I T E T O L O G
#===========================================================
sub writeToLog(;$)
{
my $output_str = shift;
if ($output_str)
{
print $LOG getTimestamp() . ": ";
print $LOG $output_str;
}
return;
} # end of writeToLog()
#=============================================================================
# C R E A T E L I B P C A P S T R I N G
# Arg1: Hash ref containing setup params
# Returns: The libpcap string
#=============================================================================
sub createLibpcapString($)
{
my $param_ref = shift or
die "Must supply hash ref to createLibpcapString()!\n";
my $lib_str = '';
if ($param_ref->{'filter_src_addr'})
{
$lib_str .= " and " if $lib_str;
$lib_str .= "src host $param_ref->{'src_addr'}";
delete($param_ref->{'filter_src_addr'});
delete($param_ref->{'src_addr'});
}
if ($param_ref->{'filter_dst_addr'})
{
$lib_str .= " and " if $lib_str;
$lib_str .= "dst host $param_ref->{'dst_addr'}";
delete($param_ref->{'filter_dst_addr'});
delete($param_ref->{'dst_addr'});
}
if ($param_ref->{'filter_src_port'})
{
$lib_str .= " and " if $lib_str;
$lib_str .= "src port $param_ref->{'src_port'}";
delete($param_ref->{'filter_src_port'});
delete($param_ref->{'src_port'});
}
if ($param_ref->{'filter_dst_port'})
{
$lib_str .= " and " if $lib_str;
$lib_str .= "dst port $param_ref->{'dst_port'}";
delete($param_ref->{'filter_dst_port'});
delete($param_ref->{'dst_port'});
}
if ($param_ref->{'filter_protocol'})
{
$lib_str .= " and " if $lib_str;
$lib_str .= $param_ref->{'protocol_type'};
delete($param_ref->{'filter_protocol'});
delete($param_ref->{'protocol_type'});
}
if ($param_ref->{'libpcap_string'})
{
$lib_str .= " and $param_ref->{'libpcap_string'}";
}
$param_ref->{'libpcap_string'} = $lib_str;
return($lib_str);
} # end of createLibpcapString()
#=================================================================
# G E T C O O K I E S
#=================================================================
sub getCookies()
{
my %cookies = ();
#===== Get all cookies as a hash
%cookies = fetch CGI::Cookie;
#===== Process each cookie
foreach my $cookie_name (keys %cookies)
{
if ($cookie_name eq 'device_name')
{
$device_name = cookie($cookie_name);
($site_location, $device_name) = split(/:/, $device_name);
}
elsif ($cookie_name eq 'experiment_id')
{
$experiment_id = cookie($cookie_name);
}
} # for each cookie
return;
} # end of getCookies()
gims_aggregate_manager.cgi 000555 002315 013577 00000070125 11417676101 016462 0 ustar 00cthomas GIMS 000000 000000 #! /usr/bin/perl -w
#=============================================================================
# G I M S A G G R E G A T E M A N A G E R . P L
#
# XML/RPC server for GIMS project
# Written by C. Thomas
#
# $Id: gims_aggregate_manager.cgi,v 1.18 2010/07/15 21:23:09 cthomas Exp $
#=============================================================================
#===========================================================
# U S E / R E Q U I R E
#===========================================================
use CGI; # For form/params stuff
use XML::RPC; # Handles calls and responses
use XML::Simple; # For parsing XML:RPC code
use Data::Dumper;
use Socket; # For 2-way communication with device
use POSIX; # For strftime
use GIMSDBUtils; # To talk to database
use XmlRpcUtils; # To create and process XML/RPC code
use strict; # Always a good idea
#===========================================================
# C O N F I G
#===========================================================
my $log_file = 'gims_am.log';
#===========================================================
# P R O T O T Y P E S
#===========================================================
sub handleInput($$);
sub openSocket($$);
sub writeToSocket($$$);
sub sendToSocket($$);
sub readFromSocket($);
sub closeSocket($);
sub getConnectInfo($$);
sub validateExpState($$$$);
sub getDeviceCapabilities($$;$;$);
sub getExperimentSettings($$;$;$);
sub formatAsReply(;$;$);
sub isDeviceCommand($);
sub getTimestamp();
sub writeToLog(;$);
sub informAndDie(;$);
#===========================================================
# G L O B A L S
#===========================================================
my $cgi_obj = undef;
my $xml_rpc_obj = undef;
# Filehandles
my $LOG = undef;
#===========================================================
# M A I N
#===========================================================
#==== Open log file
unless(open($LOG, ">>$log_file"))
{
warn "Couldn't open log file! : $!\n";
}
writeToLog("started ag man\n");
#===== Get a CGI obj
$cgi_obj = new CGI;
warn "created cgi object! : $!\n";
#===== Get a new XML::RPC obj
$xml_rpc_obj = XML::RPC->new();
#===== Retrieve XML data
my $xml = $cgi_obj->param('POSTDATA');
#===== Print XML header
print $cgi_obj->header( -type => 'text/xml', -charset => 'UTF-8' );
#===== Send a response back to the client and
# get the xml code at the same time
# handleInput is where all the work happens!
print $xml_rpc_obj->receive($xml, \&handleInput);
#===== Close the log
close($LOG);
exit;
################## BEGIN SUBROUTINES #####################
#===========================================================
# H A N D L E I N P U T
# Arg1: The XML code
# Arg2: The XML parameters (ignored)
#===========================================================
sub handleInput($$)
{
my $socket = undef;
my $raw_xml = '';
my $response_xml = '';
my $cmd = '';
my $response = 'Aggregate manager generated an error.';
my $packaged_reply = '';
my $exp_id = '';
my $err_str = '';
#===== Get the xml code, store it in a global variable
$raw_xml = shift;
my @params = shift; # ignored
#===== Check for XML code
unless ($raw_xml)
{
$err_str = "Must supply XML code to handleInput()!\n";
writeToLog($err_str);
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
$packaged_reply = formatAsReply($response, $response_xml);
return($packaged_reply);
}
#===== Get the ExperimentID
$exp_id = XmlRpcUtils::getExperimentID($raw_xml);
unless ($exp_id)
{
$err_str = "Unable to get ExpID from XML!\n";
writeToLog($err_str);
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
$packaged_reply = formatAsReply($response, $response_xml);
return($packaged_reply);
}
#===== Get the command from the xml
$cmd = XmlRpcUtils::getCommand($raw_xml);
unless ($cmd)
{
$err_str = "Unable to extract command from XML!\n";
writeToLog($err_str);
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
$packaged_reply = formatAsReply($response, $response_xml);
return($packaged_reply);
}
writeToLog("Handling command $cmd...\n");
#===== Get a database handle
my $dbh = GIMSDBUtils::getDBHandle();
unless (ref($dbh))
{
$err_str = "Unable to get database handle!\n";
writeToLog($err_str);
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
$packaged_reply = formatAsReply($response, $response_xml);
return($packaged_reply);
}
writeToLog("Got DB handle...\n");
#===== Open sockets if we're talking to the device
if (isDeviceCommand($cmd))
{
#===== Get host and port connection info
my ($gims_device_host, $gims_device_port) = getConnectInfo($dbh, $exp_id);
#===== If we have the hostname and port, process the command
if ($gims_device_host and $gims_device_port)
{
my $valid_state = '';
#===== Get experiment status
my $status = GIMSDBUtils::getExpStatus($dbh, $exp_id);
#===== Validate the state of the experiment prior to
# sending the command
writeToLog("Validating experiment state...\n");
($valid_state, $response_xml) = validateExpState($dbh,
$cmd,
$status,
$exp_id);
#===== Send command if state is valid to do so
if ($valid_state)
{
my $success = '';
#===== Write code to socket
($success, $response_xml) = writeToSocket($gims_device_host,
$gims_device_port,
$raw_xml);
#===== POST-PROCESSING
if ($success and $cmd eq 'StartExperiment')
{
GIMSDBUtils::setExpStatus($dbh, $exp_id, 'running');
writeToLog("Updated status to 'running' on ExpID: $exp_id.\n");
}
elsif ($success and $cmd eq 'PauseExperiment')
{
GIMSDBUtils::setExpStatus($dbh, $exp_id, 'paused');
writeToLog("Updated status to 'paused' on ExpID: $exp_id.\n");
}
elsif ($success and $cmd eq 'StopExperiment')
{
GIMSDBUtils::setExpStatus($dbh, $exp_id, 'done');
writeToLog("Updated status to 'done' on ExpID: $exp_id.\n");
}
elsif ($success and $cmd eq 'ConfigureExperiment')
{
my ($location, $device) = XmlRpcUtils::getLocationAndDeviceName($raw_xml);
writeToLog("Updating config for $location : $device...\n");
my $errors = GIMSDBUtils::updateExpDeviceSettings($dbh,
$exp_id,
$location,
$device,
$raw_xml);
if ($errors)
{
writeToLog("$errors\n") if $errors;
}
else
{
writeToLog("Updated database with settings for $exp_id.\n");
}
#===== Update the experiment status
GIMSDBUtils::setExpStatus($dbh, $exp_id, 'configured');
writeToLog("Updated status to 'configured' on ExpID: $exp_id.\n");
} # if ConfigureExperiment
elsif ($success and $cmd eq 'GetExperimentStatus')
{
# FIX ME
} # if GetExperimentStatus
} # if state was validated
} # if we have a hostname and port
else
{
$err_str = "Couldn't get hostname and port for ExpID: $exp_id!\n";
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # if we couldn't find hostname and port
} # if isDeviceCommand()
####### COMMANDS THAT DON'T TALK TO THE DEVICE BELOW #########
elsif ($cmd eq 'GetDeviceCapabilities')
{
#===== Get location and device name from xml
my ($location, $device_name) = XmlRpcUtils::getLocationAndDeviceName($raw_xml);
$response_xml = getDeviceCapabilities($dbh,
$exp_id,
$location,
$device_name);
} # GetDeviceCapabilities
elsif ($cmd eq 'GetExperimentSettings')
{
#===== Get location and device name from xml
my ($location, $device_name) = XmlRpcUtils::getLocationAndDeviceName($raw_xml);
#===== Get the settings
$response_xml = getExperimentSettings($dbh,
$exp_id,
$location,
$device_name);
} # GetExperimentSettings
elsif ($cmd eq 'GetExperimentResults')
{
# FIX ME
} # GetExperimentResults
#===== Unknown command
else
{
$err_str = "Unknown or unspecified command in handleInput()!\n";
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # unknown command
#===== Package this reply as XML-RPC
$response = "Aggregate manager received command $cmd.";
$packaged_reply = formatAsReply($response, $response_xml);
#===== Debug
#writeToLog("Response XML:\n");
#writeToLog($response_xml . "\n");
#writeToLog("Packaged reply:\n");
#writeToLog($packaged_reply);
return($packaged_reply);
} # handleInput()
#===========================================================
# O P E N S O C K E T
#
# Arg1: The hostname.
# Arg2: The port.
# Returns: The socket filehandle and the socket.
#===========================================================
sub openSocket($$)
{
my $host = shift or
informAndDie("Must supply hostname to openSocket()\n");
my $port = shift or
informAndDie("Must supply port number to openSocket()\n");
my $SOCK_FH = undef;
my $sock = undef;
my $proto = getprotobyname('tcp');
my $iaddr = inet_aton($host);
my $paddr = sockaddr_in($port, $iaddr);
#===== Create the socket and store it in the filehandle
writeToLog("Calling socket()...\n");
unless(socket($SOCK_FH, PF_INET, SOCK_STREAM, $proto))
{
writeToLog("ERROR: socket: $!\n");
return(undef, undef);
}
#===== Set filehandle to unbuffered mode
writeToLog("Setting filehandle to unbuffered mode...\n");
my $old_fh = select($SOCK_FH);
$| = 1;
$sock = select($old_fh);
#==== Connect socket to our server address
writeToLog("Connecting...\n");
unless(connect($SOCK_FH, $paddr))
{
writeToLog("ERROR: connect() failed : $!\n");
return(undef, undef);
}
print "Client connected \n";
writeToLog("Socket opened to ${host}\:${port}.\n");
return($SOCK_FH, $sock);
} # end of openSocket()
#===========================================================
# W R I T E T O S O C K E T
#
# Arg1: The hostname
# Arg2: The port
# Returns: The response XML
#===========================================================
sub writeToSocket($$$)
{
my $host = shift or
die "Must supplly hostname to writeToSocket()!\n";
my $port = shift or
die "Must supply port to writeToSocket()!\n";
my $raw_xml = shift or
die "Must supply XML/RPC code to writeToSocket()!\n";
my $SOCK_FH = undef;
my $socket = undef;
my $response_xml = '';
my $success = 0;
#===== Add HTTP header to commands going to the device
my $xml_header = XmlRpcUtils::getHttpHeader(length($raw_xml));
my $xml_plus_header = $xml_header . $raw_xml;
#===== Open a socket to the capture device
writeToLog("Opening socket for $host, $port...\n");
($SOCK_FH, $socket) = openSocket($host, $port);
#===== Send the data
if ($socket)
{
writeToLog("Sending to socket...\n");
sendToSocket($xml_plus_header, $SOCK_FH);
#===== Listen for XML-RPC response
writeToLog("Listening for response...\n");
$response_xml = readFromSocket($SOCK_FH);
#===== Close the socket
writeToLog("Closing socket...\n");
closeSocket($SOCK_FH);
#===== Set the flag
$success = 1;
} # if we have a socket
else
{
writeToLog("No socket...\n");
my $err_str = "Couldn't get socket for $host:$port!\n";
$err_str .= "Check that device is ready to receive incoming commands.\n";
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # no socket
return($success, $response_xml);
} # writeToSocket()
#===========================================================
# S E N D T O S O C K E T
#
# Arg1: The message to send
# Arg2: The socket filehandle.
#===========================================================
sub sendToSocket($$)
{
my $msg = shift or
informAndDie("Must supply msg to sendToSocket()!\n");
my $socket = shift or
informAndDie("Must supply socket filehandle to sendToSocket()!\n");
print $socket "$msg\n\n"; # blank like is important!
# Debug
#writeToLog("CLIENT:\n$msg");
return;
} # end of sendToSocket()
#===========================================================
# R E A D F R O M S O C K E T
#
# Arg1: The socket filehandle.
# Returns: The message read from the socket.
#===========================================================
sub readFromSocket($)
{
my $socket_filehandle = shift
or informAndDie("Must supply filehandle to readFromSocket()!\n");
my $msg = '';
while (my $line = <$socket_filehandle>)
{
if ($line)
{
# debug
#writeToLog("DEVICE: $line");
$msg .= $line;
}
}
return($msg);
} # end of readFromSocket()
#===========================================================
# C L O S E S O C K E T
#
# Arg1: The socket filehandle.
#===========================================================
sub closeSocket($)
{
my $socket_filehandle = shift or
informAndDie("Must supply filehandle to closeSocket()!\n");
close ($socket_filehandle) or
informAndDie("close: $!");
writeToLog("Socket closed.\n");
return;
} # end of closeSocket()
#===========================================================
# G E T C O N N E C T I N F O
#
# Gets the hostname and port for the experiment in
# question.
#
# Arg1: A database handle
# Arg2: The ExperimentID
# Returns: The hostname and port for the given exp_id
#===========================================================
sub getConnectInfo($$)
{
my $dbh = shift or
informAndDie("Must supply database handle to getConnectInfo()!\n");
my $exp_id = shift or
informAndDie("Must supply ExperimentID to getConnectInfo()!\n");
my %devices = ();
my $hostname = '';
my $port = '';
#===== Get information about the capture device
my $errors = GIMSDBUtils::getExpDevices($dbh,
\%devices,
$exp_id,
'PKT_CAP');
#===== Should be only one device
my $num_devices = scalar(keys %{$devices{$exp_id}});
if ($num_devices != 1)
{
writeToLog("Warning: $num_devices devices returned for ExperimentID=$exp_id\n");
}
#===== Warn about DB errors, don't die
if ($errors)
{
writeToLog("ERROR: $errors\n");
}
#===== Get the hostname and port
foreach my $location (keys %{$devices{$exp_id}})
{
foreach my $device_name (keys %{$devices{$exp_id}{$location}})
{
$hostname = $devices{$exp_id}{$location}{$device_name}{'hostname'};
$port = $devices{$exp_id}{$location}{$device_name}{'port'};
} # foreach device_name
} # foreach location
return($hostname, $port);
} # end of getConnectInfo()
#===========================================================
# V A L I D A T E E X P S T A T E
#
# Arg1: The database handle.
# Arg2: The command.
# Arg3: The experiment state
# Arg4: The ExperimentID
# Returns: An array with two elements
# 0) Success or failure (boolean)
# 1) Any response XML (in case of failure)
#===========================================================
sub validateExpState($$$$)
{
my $dbh = shift or
informAndDie("Must supply database handle to validateExpState()!\n");
my $cmd = shift or
informAndDie("Must supply command to validateExpState()!\n");
my $status = shift or
informAndDie("Must supply status to validateExpState()!\n");
my $exp_id = shift or
informAndDie("Must supply ExperimentID to validateExpState()!\n");
my $response_xml = '';
my $success = 0;
my $err_str = '';
#===== Now make sure this command can be executed when the experiment
# is in the state given.
if ($cmd eq 'StartExperiment')
{
if (!defined($status) or $status eq 'instantiated')
{
$err_str = "Experiment $exp_id is not configured!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # instantiated
elsif ($status eq 'configured')
{
$success = 1;
} # configured
elsif ($status eq 'running')
{
$err_str = "Experiment $exp_id is already running!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # running
elsif ($status eq 'paused')
{
$success = 1;
} # paused
elsif ($status eq 'done')
{
$err_str = "Cannot restart finished experiment $exp_id?";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # done
} # StartExperiment
#===== PauseExperiment
elsif ($cmd eq 'PauseExperiment')
{
if (!defined($status) or $status eq 'instantiated')
{
$err_str = "Experiment $exp_id is not configured!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # instantiated
elsif ($status eq 'configured')
{
$err_str = "Experiment $exp_id is not running!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # configured
elsif ($status eq 'running')
{
$success = 1;
} # running
elsif ($status eq 'paused')
{
$err_str = "Experiment $exp_id is already paused!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # paused
elsif ($status eq 'done')
{
$err_str = "Cannot pause finished experiment $exp_id!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # done
} # PauseExperiment
#===== StopExperiment
elsif ($cmd eq 'StopExperiment')
{
if (!defined($status) or $status eq 'instantiated')
{
$err_str = "Experiment $exp_id is not configured!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # instantiated
elsif ($status eq 'configured')
{
$err_str = "Experiment $exp_id is not running!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # configured
elsif ($status eq 'running')
{
$success = 1;
} # running
elsif ($status eq 'paused')
{
$success = 1;
} # paused
elsif ($status eq 'done')
{
$err_str = "Experiment $exp_id has already been terminated!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # done
} # StopExperiment
#===== ConfigureExperiment
elsif ($cmd eq 'ConfigureExperiment')
{
if (!defined($status) or $status eq 'instantiated')
{
$success = 1;
} # instantiated
elsif ($status eq 'configured')
{
$success = 1;
} # configured
elsif ($status eq 'running')
{
$err_str = "Cannot configure running experiment $exp_id!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # running
elsif ($status eq 'paused')
{
$err_str = "Cannot configure paused experiment $exp_id!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # paused
elsif ($status eq 'done')
{
$err_str = "Cannot configure finished experiment $exp_id!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # done
} # ConfigureExperiment
#===== GetExperimentStatus
elsif ($cmd eq 'GetExperimentStatus')
{
if (!defined($status))
{
$err_str = "Experiment $exp_id not found in database!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
}
elsif ($status eq 'instantiated')
{
$err_str = "Experiment $exp_id is not running!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # instantiated
elsif ($status eq 'configured')
{
$err_str = "Experiment $exp_id is not running!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # configured
elsif ($status eq 'running')
{
$success = 1;
} # running
elsif ($status eq 'paused')
{
$success = 1;
} # paused
elsif ($status eq 'done')
{
$err_str = "Experiment $exp_id is done!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # done
} # GetExperimentStatus
#===== GetExperimentResults
elsif ($cmd eq 'GetExperimentResults')
{
if (!defined($status))
{
$err_str = "Experiment $exp_id not found in database!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
}
elsif ($status eq 'instantiated')
{
$err_str = "Experiment $exp_id not started yet!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # instantiated
elsif ($status eq 'configured')
{
$err_str = "Experiment $exp_id not started yet!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # configured
elsif ($status eq 'running')
{
$err_str = "Experiment $exp_id is still running!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # running
elsif ($status eq 'paused')
{
$err_str = "Must stop $exp_id before results will be available!";
$success = 0;
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # paused
elsif ($status eq 'done')
{
$success = 1;
} # done
} # GetExperimentResults
return($success, $response_xml);
} # validateExpState()
#===========================================================
# G E T D E V I C E C A P A B I L I T I E S
#
# Arg1: Database handle
# Arg2: ExperimentID
# Arg3: Location (optional)
# Arg4: Device name (optional)
# Returns: XML/RPC with caps or error, as appropriate
#===========================================================
sub getDeviceCapabilities($$;$;$)
{
my $dbh = shift or
informAndDie("Must supply database handle to getExperimentSettings()!\n");
my $exp_id = shift or
informAndDie("Must supply ExpID to getExperimentSettings()!\n");
my $location = shift;
my $device_name = shift;
my $response_xml = '';
#===== Get the capabilities
if ($location and $device_name)
{
#===== Get the device capabilities from the database
writeToLog("Getting capabilities for $location : $device_name...\n");
$response_xml = GIMSDBUtils::getDeviceCapabilities($dbh,
$location,
$device_name);
} # if we have location and device_name
else
{
my $err_str = "Missing location or device_name in handleInput()!\n";
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # no location_name or device_name
return($response_xml);
} # end of getDeviceCapabilities()
#===========================================================
# G E T E X P E R I M E N T S E T T I N G S
#
# Arg1: Database handle
# Arg2: ExperimentID
# Arg3: Location (optional)
# Arg4: Device name (optional)
# Returns: XML/RPC with settings or error, as appropriate
#===========================================================
sub getExperimentSettings($$;$;$)
{
my $dbh = shift or
informAndDie("Must supply database handle to getExperimentSettings()!\n");
my $exp_id = shift or
informAndDie("Must supply ExpID to getExperimentSettings()!\n");
my $location = shift;
my $device_name = shift;
my $response_xml = '';
my %settings = ();
#===== Get the device capabilities from the database
writeToLog("Getting settings for ExpID: $exp_id...\n");
GIMSDBUtils::getExpDeviceInfo($dbh,
\%settings,
$exp_id,
$location,
$device_name);
#===== Pull out each device's settings
foreach my $location (keys %{$settings{$exp_id}})
{
foreach my $device (keys %{$settings{$exp_id}{$location}})
{
if ($settings{$exp_id}{$location}{$device}{'settings'})
{
$response_xml .= $settings{$exp_id}{$location}{$device}{'settings'};
} # if we have settings
} # for each device
} # for each location
#===== Send a fault if no settings found
unless ($response_xml)
{
my $err_str = "No exp settings for";
$err_str .= " ExpID: $exp_id";
$err_str .= " Location: $location" if $location;
$err_str .= " Device: $device_name" if $device_name;
$err_str .= "?";
$response_xml = XmlRpcUtils::writeFaultXML(-1, $err_str);
} # if we have no response
return($response_xml);
} # end of getExperimentSettings()
#===========================================================
# F O R M A T A S R E P L Y
#
# Arg1: Data from the aggregate manager we wish to return
# Arg2: Data from the device we wish to return
#===========================================================
sub formatAsReply(;$;$)
{
my $agr_mgr_data = shift;
my $device_response_data = shift;
my $reply = '';
writeToLog("Formulating reply...\n");
#===== Encapsulate the method name in an XML-RPC response
$reply .= '' . "\n";
$reply .= "\n";
$reply .= "\n";
#===== Data from the Aggregate Manager we wish to return to user
$reply .= "\n";
$reply .= "agr_mgr_data\n";
$reply .= "\n";
$reply .= "\n";
#===== Response from the GIMS device
$reply .= "\n";
$reply .= "device_response_data\n";
$reply .= "\n";
$reply .= "\n";
$reply .= "\n";
$reply .= "\n";
return($reply);
} # end of formatAsReply()
#===========================================================
# I S D E V I C E C O M M A N D
#
# Arg1: The command.
# Returns: 1 if the command involves the device.
# 0 otherwise.
#===========================================================
sub isDeviceCommand($)
{
my $cmd = shift or
informAndDie("Must supply command to isDeviceCommand()!\n");
my $device_command = 0;
if ( $cmd eq 'ConfigureExperiment' or
$cmd eq 'StartExperiment' or
$cmd eq 'PauseExperiment' or
$cmd eq 'StopExperiment' or
$cmd eq 'GetExperimentStatus' or
$cmd eq 'GetExperimentResults' )
{
$device_command = 1;
}
return($device_command);
} # end of isDeviceCommand()
#===========================================================
# G E T T I M E S T A M P
#===========================================================
sub getTimestamp()
{
return(strftime("%Y-%m-%d %H:%M:%S", localtime));
} # end of getTimestamp()
#===========================================================
# W R I T E T O L O G
#===========================================================
sub writeToLog(;$)
{
my $output_str = shift;
if ($output_str)
{
print $LOG getTimestamp() . ": ";
print $LOG $output_str;
}
return;
} # end of writeToLog()
#===========================================================
# I N F O R M A N D D I E
# Tries to write to log, then dies
# Arg1: The error message
#===========================================================
sub informAndDie(;$)
{
my $output_str = shift;
if ($output_str)
{
print $LOG getTimestamp() . ": ";
print $LOG $output_str;
}
die "$output_str\n";
} # end of informAndDie()
GIMSAuth.pm 000755 002315 013577 00000014167 11417673565 013277 0 ustar 00cthomas GIMS 000000 000000 #!/usr/bin/perl -w
#==========================================================================
#
# G I M S A U T H . P M
#
# GENIPUBLIC-COPYRIGHT
# Copyright (c) 2008-2010 University of Utah and the Flux Group.
# All rights reserved.
#
#
# Interface to the GENI xmlrpc interface, invoked from the web server.
# The certificate information is in the environment set up by apache.
#
# $Id$
#
#==========================================================================
package GIMSAuth;
#==========================================================================
# U S E / R E Q U I R E
#==========================================================================
use CGI qw(:standard);
use CGI::Carp ('fatalsToBrowser'); # Send any errors to the browser
use English;
use Frontier::Responder;
use Frontier::RPC2;
use Data::Dumper;
use POSIX;
use Crypt::X509;
use Crypt::OpenSSL::X509;
#===== Testbed libraries.
use lib '/usr/testbed/lib';
use GeniCM;
use GeniCMV2;
use Genixmlrpc;
use GeniResponse;
use libaudit;
use strict;
#==========================================================================
# P R O T O T Y P E S
#==========================================================================
sub checkAuth();
##################### BEGIN SUBROUTINES #############################
#==========================================================================
# C H E C K A U T H
#
# Returns: An error code (OEO if none) and status message.
#==========================================================================
sub checkAuth()
{
#===== Apache does not close file descriptors before the exec,
# and if this dies we are left with a giant mess.
no warnings;
for (my $i = 3; $i < 1024; $i++)
{
POSIX:close($i);
}
#===== Do this early so that we talk to the right DB.
use vars qw($GENI_DBNAME);
BEGIN { $GENI_DBNAME = "geni-cm"; }
#===== Configure variables
my $EMULAB_PEMFILE = "/usr/testbed/etc/genicm.pem";
my $MAINSITE = 0;
my $VERSION = "2.0";
#===== Geniuser.
my $user = "geniuser";
my $group = "GeniSlices";
#===== Need a command line option.
my $debug = 0;
my $responder; # Determined by version.
#===== Turn off line buffering on output
$| = 1;
#===== Untaint the path
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
#===== So we know who/what we are acting as.
my $certificate = GeniCertificate->LoadFromFile($EMULAB_PEMFILE);
if (!defined($certificate))
{
die("*** $0:\n" . " Could not get uuid from $EMULAB_PEMFILE\n");
}
$ENV{'MYUUID'} = $certificate->uuid();
#===== The URN could also come from the certificate, and that might
# be preferable in some ways (if anybody is doing something
# silly like authenticating with somebody else's certificate).
# That would require everybody to upgrade to URNs in their
# certificates, so we can't assume it yet.
$ENV{'MYURN'} = "urn:publicid:IDN+schooner.wail.wisc.edu+authority+protogeni-test";
#===== Make sure the client presented a valid certificate that apache
# says is okay.
#
# THIS HAS TO BE HERE! Recent security patches disable SSL
# renegotiation, which is needed when a subdir turns on ssl client
# verification (as httpd.conf used to). Now, we set it to "optional",
# which avoids the renegotiation problem, but we have to make that
# this interface is always invoked by a client supplying a verifiable
# certificate.
if (!(exists($ENV{'SSL_CLIENT_VERIFY'}) and
$ENV{'SSL_CLIENT_VERIFY'} eq "SUCCESS"))
{
return(-1, "Invalid or missing certificate");
}
#===== In the prototype, we accept certificate signed by trusted roots
# (CA certs we have locally cached). This script runs as "geniuser"
# so that there is an emulab user context, or many of the scripts we
# invoke will complain and croak.
my $unix_uid = getpwnam("$user") or
die("*** $0:\n". " No such user $user\n");
my $unix_gid = getgrnam("$group") or
die("*** $0:\n". " No such group $group\n");
#===== Flip to user and never go back
$GID = $unix_gid;
$EGID = "$unix_gid $unix_gid";
$EUID = $UID = $unix_uid;
$ENV{'USER'} = $user;
$ENV{'LOGNAME'} = $user;
#===== The UUID of the client certificate is in the env var
# SSL_CLIENT_S_DN_CN. If it actually looks like a UUID,
# then this correponds to an actual user, and the supplied
# credentials/tickets must match. At present, if there is
# no UUID, it is another emulab making a request directly, with no user
# context, and we just let that pass for now.
if (exists($ENV{'SSL_CLIENT_S_DN_CN'}) &&
$ENV{'SSL_CLIENT_S_DN_CN'} =~ /^\w+\-\w+\-\w+\-\w+\-\w+$/)
{
$ENV{'GENIUSER'} = $ENV{'SSL_CLIENT_S_DN_CN'};
$ENV{'GENIUUID'} = $ENV{'SSL_CLIENT_S_DN_CN'};
}
else
{
return(-1, "Invalid certificate; no UUID");
}
#===== The CERT data from apache holds the URN of the caller.
if (exists($ENV{'SSL_CLIENT_CERT'}))
{
my $x509 = eval {
Crypt::OpenSSL::X509->new_from_string($ENV{'SSL_CLIENT_CERT'});
};
if ($@)
{
return(-1, "Invalid certificate: $@");
}
my $cert = $x509->as_string(Crypt::OpenSSL::X509::FORMAT_ASN1);
if (!defined($cert) or $cert eq '')
{
return(-1, "Could not convert certificate to ASN1");
}
my $decoded = Crypt::X509->new( cert => $cert );
if ($decoded->error)
{
return(-1, "Error decoding certificate:" . $decoded->error);
}
foreach my $tmp (@{ $decoded->SubjectAltName })
{
if ($tmp =~ /^uniformResourceIdentifier=(.*)$/ or
$tmp =~ /^(urn:.*)$/)
{
$ENV{'GENIURN'} = $1;
}
} # for each decoded name
} # if the SSL_CLIENT_CERT env exists
if (!exists($ENV{'GENIURN'}))
{
my $err_str = "Invalid authentication certificate; ";
$err_str .= "no URN. Please regenerate.";
return(-1, $err_str);
}
#===== Success!
my $return_str = "GeniUser $ENV{'GENIURN'} authenticated successfully.";
return(0E0, $return_str);
} # end of checkAuth()
1
GIMSDBUtils.pm 000444 002315 013577 00000102206 11417417022 013647 0 ustar 00cthomas GIMS 000000 000000 #!/usr/bin/perl -w
#==============================================================================
#
# G I M S D B U T I L S . P M
#
# Written by Charles Thomas (cthomas@wisc.edu)
#
# $Id: GIMSDBUtils.pm,v 1.16 2010/07/14 19:08:54 cthomas Exp $
#==============================================================================
package GIMSDBUtils;
#=========================================================
# U S E R E Q U I R E
#=========================================================
use DBI; # for database access
use Digest::MD5; # to generate random experiment id
use strict; # always a good idea
#=========================================================
# C O N F I G
#=========================================================
my $db_conf_file = '~/.my.cnf';
#=========================================================
# P R O T O T Y P E S
#=========================================================
sub getDBHandle();
sub getDeviceInfo($$;$;$);
sub getExpDevices($$$;$);
sub getDeviceCapabilities($$$);
sub addExperiment($$$);
sub getExperimentInfo($$;$;$);
sub addExpDevice($$$$);
sub getExpDeviceInfo($$$;$;$);
sub updateExpDeviceSettings($$$$$);
sub getExperimentDevices($$$;$);
sub addExperimentDevice($$$$;$);
sub deleteExperimentDevice($$;$;$);
sub getExpStatus($$);
sub setExpStatus($$$);
sub getDeviceStatus($$$$);
sub setDeviceStatus($$$$$);
sub genExperimentID($);
sub getNewExpID($$);
sub expIDExists($;$);
sub expDeviceExists($$$$);
sub deviceExists($$$);
sub updateDevice($$);
sub deleteDevice($$$);
#=========================================================
# G L O B A L V A R I A B L E S
#=========================================================
#################### BEGIN SUBROUTINES ###################
#=========================================================
# G E T D B H A N D L E
# Returns: A database handle
#=========================================================
sub getDBHandle()
{
my $dbh = undef;
#===== Configure to talk to WiscNIC
my @dsn = ('DBI:mysql:gims;mysql_read_default_file=' . $db_conf_file);
#===== Get database handle
$dbh = DBI->connect(@dsn);
die "Connection to GIMS database failed!\n" unless ref($dbh);
return($dbh);
} # end of getDBHandle()
#=========================================================
# G E T D E V I C E I N F O
# Arg1: Database handle
# Arg2: Hash ref to hold results
# Arg3: A location (optional)
# Arg4: A device_name (optional)
#=========================================================
sub getDeviceInfo($$;$;$)
{
my $dbh = shift or
die "Must supply database handle to getDeviceInfo()!\n";
my $info_ref = shift or
die "Must supply hash ref to getDeviceInfo()!\n";
my $location = shift;
my $device_name = shift;
my $sql = undef;
my $cursor = undef;
#===== Prepare the SQL statement
$sql = qq{
SELECT
location,
device_name,
type,
hostname,
port,
descr,
capabilities,
last_update
FROM
device
};
if ($location)
{
$sql .= " WHERE\n location = '$location'";
}
if ($location and $device_name)
{
$sql .= "\n AND\n"
}
if ($device_name)
{
$sql .= " device_name = '$device_name'";
}
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
my $LOCATION = 0;
my $DEVICE_NAME = 1;
my $TYPE = 2;
my $HOSTNAME = 3;
my $PORT = 4;
my $DESCR = 5;
my $CAPABILITIES = 6;
my $LAST_UPDATE = 7;
while (my @row = $cursor->fetchrow)
{
#===== Initialize to prevent warnings
foreach my $value (@row) { $value = '' unless (defined($value) and $value ne ''); }
#===== Store the values
$info_ref->{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'type'} = $row[$TYPE];
$info_ref->{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'hostname'} = $row[$HOSTNAME];
$info_ref->{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'port'} = $row[$PORT];
$info_ref->{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'descr'} = $row[$DESCR];
$info_ref->{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'capabilities'} = $row[$CAPABILITIES];
$info_ref->{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'last_update'} = $row[$LAST_UPDATE];
} # while we have more rows to read
return;
} # end of getDeviceInfo()
#=========================================================
# G E T E X P D E V I C E S
# Arg1: Database handle
# Arg2: Hash ref to hold results
# Arg3: The ExperimentID
# Arg4: A device type (optional)
#=========================================================
sub getExpDevices($$$;$)
{
my $dbh = shift or
die "Must supply database handle to getExpDevices()!\n";
my $info_ref = shift or
die "Must supply hash ref to getExpDevices()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to getExpDevices()!\n";
my $type = shift;
my $errors = '';
my $sql = undef;
my $cursor = undef;
#===== Prepare the SQL statement
$sql = qq{
SELECT
device.location,
device.device_name,
device.type,
device.hostname,
device.port,
device.descr,
device.capabilities,
device.last_update
FROM
device,
exp_device
WHERE
exp_device.exp_id = '$exp_id' AND
exp_device.location = device.location AND
exp_device.device_name = device.device_name
};
if ($type)
{
$sql .= " AND \n device.type = '$type'";
}
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
my $LOCATION = 0;
my $DEVICE_NAME = 1;
my $TYPE = 2;
my $HOSTNAME = 3;
my $PORT = 4;
my $DESCR = 5;
my $CAPABILITIES = 6;
my $LAST_UPDATE = 7;
while (my @row = $cursor->fetchrow)
{
#===== Initialize to prevent warnings
foreach my $value (@row) { $value = '' unless (defined($value) and $value ne ''); }
#===== Store the values
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'type'} = $row[$TYPE];
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'hostname'} = $row[$HOSTNAME];
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'port'} = $row[$PORT];
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'descr'} = $row[$DESCR];
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'capabilities'} = $row[$CAPABILITIES];
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'last_update'} = $row[$LAST_UPDATE];
} # while we have rows to read
return($errors);
} # end of getExpDevices()
#=========================================================
# G E T D E V I C E C A P A B I L I T I E S
# Arg1: Database handle
# Arg2: A location
# Arg3: A device_name
# Returns: Device capabilities in XML/RPC structure
#=========================================================
sub getDeviceCapabilities($$$)
{
my $dbh = shift or
die "Must supply database handle to getDeviceCapabilities()!\n";
my $location = shift or
die "Must supply site_location to getDeviceCapabilities()!\n";
my $device_name = shift or
die "Must supply device_name to getDeviceCapabilities()!\n";
my $sql = undef;
my $cursor = undef;
my $xml = '';
#===== Prepare the SQL statement
$sql = qq{
SELECT
capabilities
FROM
device
WHERE
location = '$location' AND
device_name = '$device_name'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
my $CAPABILITIES = 0;
while (my @row = $cursor->fetchrow)
{
#===== Initialize to prevent warnings
foreach my $value (@row) { $value = '' unless (defined($value) and $value ne ''); }
$xml = $row[$CAPABILITIES];
} # while we have more rows to read
return($xml);
} # end of getDeviceCapabilities()
#=========================================================
# A D D E X P E R I M E N T
#
# Arg1: Database handle
# Arg2: An ExperimentID
# Arg3: A string that identifies the user
# Returns: Errors if there are any, nothing otherwise
#=========================================================
sub addExperiment($$$)
{
my $dbh = shift or
die "Must supply database handle to addExperiment()!\n";
my $exp_id = shift or
die "Must supply hash ref to addExperiment()!\n";
my $user = shift or
die "Must supply user to addExperiment()!\n";
my $sql = undef;
my $cursor = undef;
my $errors = '';
#===== Prepare the SQL statement
$sql = qq{
INSERT INTO experiment
(
exp_id,
status,
exp_start,
exp_end,
created_by,
last_update
)
VALUES
(
'$exp_id',
'instantiated',
'0000-00-00 00:00:00',
'0000-00-00 00:00:00',
'$user',
NULL
)
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
# DEBUG
#$errors = $sql;
return($errors);
} # end of addExperiment()
#=========================================================
# G E T E X P E R I M E N T I N F O
# Arg1: Database handle
# Arg2: Hash ref to hold info
# Arg3: An ExperimentID (optional)
# Arg4: If true, return only active experiments (optional)
#=========================================================
sub getExperimentInfo($$;$;$)
{
my $dbh = shift or
die "Must supply database handle to getExperimentInfo()!\n";
my $info_ref = shift or
die "Must supply hash ref to getExperimentInfo()!\n";
my $exp_id = shift;
my $active = shift;
my $sql = undef;
my $cursor = undef;
my $errors = '';
#===== Prepare the SQL statement
$sql = qq{
SELECT
exp_id,
status,
exp_start,
exp_end,
created_by,
last_update
FROM
experiment
};
if ($exp_id and $active)
{
$sql .= "\nWHERE\n exp_id='$exp_id' AND status != 'done'";
}
elsif ($exp_id)
{
$sql .= "\nWHERE\n exp_id='$exp_id'";
}
elsif ($active)
{
$sql .= "\nWHERE\n status != 'done'";
}
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
my $EXPERIMENT_ID = 0;
my $STATUS = 1;
my $EXP_START = 2;
my $EXP_END = 3;
my $CREATED_BY = 4;
my $LAST_UPDATE = 5;
while (my @row = $cursor->fetchrow)
{
#===== Initialize to prevent warnings
foreach my $value (@row) { $value = '' unless (defined($value) and $value ne ''); }
#===== Store the values
$info_ref->{$row[$EXPERIMENT_ID]}{'status'} = $row[$STATUS];
$info_ref->{$row[$EXPERIMENT_ID]}{'exp_start'} = $row[$EXP_START];
$info_ref->{$row[$EXPERIMENT_ID]}{'exp_end'} = $row[$EXP_END];
$info_ref->{$row[$EXPERIMENT_ID]}{'created_by'} = $row[$CREATED_BY];
$info_ref->{$row[$EXPERIMENT_ID]}{'last_update'} = $row[$LAST_UPDATE];
} # while we have more rows to read
return($errors);
} # end of getExperimentInfo()
#=========================================================
# G E T E X P D E V I C E I N F O
#
# Arg1: Database handle
# Arg2: The experiment ID
# Arg3: The location (optional)
# Arg4: The device name (optional)
# Returns: Any errors. Nothing if success.
#=========================================================
sub addExpDevice($$$$)
{
my $dbh = shift or
die "Must supply database handle to addExpDevice()!\n";
my $exp_id = shift or
die "Must supply hash ref to addExpDevice()!\n";
my $location = shift or
die "Must supply location to addExpDevice()!\n";
my $device_name = shift or
die "Must supply device name to addExpDevice()!\n";
my $sql = undef;
my $cursor = undef;
my $errors = '';
#===== Prepare the SQL statement
$sql = qq{
INSERT INTO exp_device
(
exp_id,
location,
device_name,
settings,
last_update
)
VALUES
(
'$exp_id',
'$location',
'$device_name',
NULL,
NULL
)
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
return($errors);
} # end of addExpDevice()
#=========================================================
# G E T E X P D E V I C E I N F O
#
# Arg1: Database handle
# Arg2: The hash ref to hold results
# Arg3: The experiment ID
# Arg4: The location (optional)
# Arg5: The device name (optional)
# Returns: Any errors. Nothing if success.
#=========================================================
sub getExpDeviceInfo($$$;$;$)
{
my $dbh = shift or
die "Must supply database handle to getExpDeviceInfo()!\n";
my $info_ref = shift or
die "Must supply hash ref to getExpDeviceInfo()!\n";
my $exp_id = shift or
die "Must supply exp_id to getExpDeviceInfo()!\n";
my $location = shift;
my $device_name = shift;
my $sql = undef;
my $cursor = undef;
my $settings = '';
my $errors = '';
$sql = qq{
SELECT
location,
device_name,
settings,
status,
last_update
FROM
exp_device
WHERE
exp_id = '$exp_id'
};
$sql .= " AND location = '$location'" if $location;
$sql .= " AND device_name = '$device_name" if $device_name;
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
my $LOCATION= 0;
my $DEVICE_NAME= 1;
my $SETTINGS= 2;
my $STATUS = 3;
my $LAST_UPDATE = 4;
while (my @row = $cursor->fetchrow)
{
#===== Initialize to prevent warnings
foreach my $value (@row) { $value = '' unless (defined($value) and $value ne ''); }
#===== Store the values
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'settings'} = $row[$SETTINGS];
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'status'} = $row[$STATUS];
$info_ref->{$exp_id}{$row[$LOCATION]}{$row[$DEVICE_NAME]}{'last_update'} = $row[$LAST_UPDATE];
} # while we have more rows to read
return($errors);
} # end of getExpDeviceInfo()
#=========================================================
# U P D A T E E X P D E V I C E S E T T I N G S
# Arg1: Database handle
# Arg2: The experiment ID
# Arg3: The device location (e.g. 'msn')
# Arg4: The device_name
# Arg5: The settings used for this device/exp combination.
# Returns: Any errors. Nothing if success.
#=========================================================
sub updateExpDeviceSettings($$$$$)
{
my $dbh = shift or
die "Must supply database handle to updateExpDeviceSettings()!\n";
my $exp_id = shift or
die "Must supply experiment ID to updateExpDeviceSettings()!\n";
my $location = shift or
die "Must supply location to updateExpDeviceSettings()!\n";
my $device_name = shift or
die "Must supply device_name to updateExpDeviceSettings()!\n";
my $settings = shift or
die "Must supply settings to updateExpDeviceSettings()!\n";
my $sql = undef;
my $cursor = undef;
my $errors = '';
my $update = '';
my %exp_settings = ();
#===== See if we're inserting or updating
$update = expDeviceExists($dbh, $exp_id, $location, $device_name);
#==== Prepare the SQL statement
if ($update)
{
$sql = qq{
UPDATE
exp_device
SET
settings = '$settings',
last_update = CURRENT_TIMESTAMP()
WHERE
exp_id = '$exp_id' AND
location = '$location' AND
device_name = '$device_name'
};
}
else
{
$sql = qq{
INSERT INTO exp_device
(
exp_id,
location,
device_name,
settings,
last_update
)
values
(
'$exp_id',
'$location',
'$device_name',
'$settings',
CURRENT_TIMESTAMP()
)
};
} # if we're inserting
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
# Debug
$errors = $sql;
return($errors);
} # end of updateExpSettings()
#=========================================================
# G E T E X P E R I M E N T D E V I C E S
# Arg1: Database handle
# Arg2: Hash ref to hold results
# Arg3: The ExperimentID
# Arg4: A type of device (optional)
# Returns: Any errors. Nothing if success.
#=========================================================
sub getExperimentDevices($$$;$)
{
my $dbh = shift or
die "Must supply database handle to getExperimentDevices()!\n";
my $info_ref = shift or
die "Must supply hash ref to getExperimentDevices()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to getExperimentDevices()!\n";
my $type = shift;
my $sql = undef;
my $cursor = undef;
my $errors = '';
#===== Prepare the SQL statement
$sql = qq{
SELECT
device.location,
device.device_name,
device.hostname,
device.port,
device.descr,
device.capabilities,
device.last_update
FROM
device,
exp_device
WHERE
exp_device.exp_id = '$exp_id' AND
exp_device.device_name = device.device_name AND
exp_device.location = device.location
};
if ($type)
{
$sql .= " AND\n device.type = '$type'";
}
$cursor = $dbh->prepare($sql) or
$errors .= "Unable to prepare database query: " . $dbh->errstr . "\n";
unless ($errors)
{
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
}
unless ($errors)
{
my $LOCATION = 0;
my $DEVICE_NAME = 1;
my $HOSTNAME = 2;
my $PORT = 3;
my $DESCR = 4;
my $CAPABILITIES = 5;
my $LAST_UPDATE = 6;
while (my @row = $cursor->fetchrow)
{
#===== Initialize to prevent warnings
foreach my $value (@row) {$value = '' unless (defined($value) and $value ne '');}
#===== Store the values
$info_ref->{$exp_id}{$row[$DEVICE_NAME]}{'device_name'} = $row[$DEVICE_NAME];
$info_ref->{$exp_id}{$row[$DEVICE_NAME]}{'location'} = $row[$LOCATION];
$info_ref->{$exp_id}{$row[$DEVICE_NAME]}{'hostname'} = $row[$HOSTNAME];
$info_ref->{$exp_id}{$row[$DEVICE_NAME]}{'port'} = $row[$PORT];
$info_ref->{$exp_id}{$row[$DEVICE_NAME]}{'descr'} = $row[$DESCR];
$info_ref->{$exp_id}{$row[$DEVICE_NAME]}{'capabilities'} = $row[$CAPABILITIES];
$info_ref->{$exp_id}{$row[$DEVICE_NAME]}{'last_update'} = $row[$LAST_UPDATE];
} # while we have more rows to read
} # if we have no errors
return($errors);
} # end of getExperimentDevice()
#=========================================================
# A D D E X P E R I M E N T D E V I C E
# Arg1: A database handle
# Arg2: The ExperimentID
# Arg3: The site location for the device (e.g. 'msn')
# Arg4: The device_name
# Arg5: The device settings (XML/RPC text, optional)
# Returns: Errors if any, nothing otherwise.
#=========================================================
sub addExperimentDevice($$$$;$)
{
my $dbh = shift or
die "Must supply database handle to addExperimentDevice()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to addExperimentDevice()!\n";
my $location = shift or
die "Must supply site location to addExperimentDevice()!\n";
my $device_name = shift or
die "Must supply device_name to addExperimentDevice()!\n";
my $settings = shift;
my $sql = '';
my $cursor = '';
my $errors = '';
#===== Init
$settings = '' unless $settings;
#==== Prepare the SQL statement
$sql = qq{
INSERT INTO
exp_device
(
location,
device_name,
status,
settings,
last_update
)
VALUES
(
'$location',
'$device_name,
'instantiated',
'$settings',
NULL
)
WHERE
exp_id = '$exp_id'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
# Debug
#$errors = $sql;
return($errors);
} # end of addExperimentDevice()
#=========================================================
# D E L E T E E X P E R I M E N T D E V I C E
#
# This sub is flexible in that if you specify a site
# and a device, it will delete only that device, etc.
#
# Arg1: A database handle
# Arg2: The ExperimentID
# Arg3: The site location for the device (e.g. 'msn', optional)
# Arg4: The device_name (optional)
# Returns: Any errors, nothing if success.
#=========================================================
sub deleteExperimentDevice($$;$;$)
{
my $dbh = shift or
die "Must supply database handle to deleteExperimentDevice()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to deleteExperimentDevice()!\n";
my $location = shift;
my $device_name = shift;
my $sql = '';
my $cursor = '';
my $errors = '';
#==== Prepare the SQL statement
$sql = qq{
DELETE FROM
exp_device
WHERE
exp_id = '$exp_id'
};
if ($location and $device_name)
{
$sql .= " AND
location = '$location' AND
device_name = '$device_name'";
}
elsif ($location)
{
$sql .= " AND
location = '$location'";
}
$cursor = $dbh->prepare($sql) or
$errors .= "Unable to prepare database query: " . $dbh->errstr . "\n";
unless ($errors)
{
$cursor->execute;
$errors .= $dbh->errstr if $dbh->errstr;
}
return($errors);
} # end of deleteExperimentDevice()
#=========================================================
# G E T E X P S T A T U S
#
# Arg1: The database handle
# Arg2: The ExperimentID
#=========================================================
sub getExpStatus($$)
{
my $dbh = shift or
die "Must supply database handle to getExpStatus()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to getExpStatus()!\n";
my $sql = undef;
my $cursor = undef;
my $status = '';
#===== Prepare the SQL statement
$sql = qq{
SELECT
status
FROM
experiment
WHERE
exp_id = '$exp_id'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$status = $cursor->fetchrow;
return($status);
} # end of getExpStatus()
#=========================================================
# S E T E X P S T A T U S
#
# Arg1: The database handle
# Arg2: The ExperimentID
# Arg3: The status
#=========================================================
sub setExpStatus($$$)
{
my $dbh = shift or
die "Must supply database handle to setExpStatus()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to setExpStatus()!\n";
my $status = shift or
die "Must supply status to setExpStatus()!\n";
my $sql = undef;
my $cursor = undef;
#===== Prepare the SQL statement
$sql = qq{
UPDATE
experiment
SET
status='$status'
WHERE
exp_id = '$exp_id'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
return;
} # end of setExpStatus()
#=========================================================
# G E T D E V I C E S T A T U S
#
# Arg1: The database handle
# Arg2: The ExperimentID
# Arg3: The location
# Arg4: The device_name
#=========================================================
sub getDeviceStatus($$$$)
{
my $dbh = shift or
die "Must supply database handle to getDeviceStatus()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to getDeviceStatus()!\n";
my $location = shift or
die "Must supply location to getDeviceStatus()!\n";
my $device_name = shift or
die "Must supply device_name to getDeviceStatus()!\n";
my $sql = undef;
my $cursor = undef;
my $status = '';
#===== Prepare the SQL statement
$sql = qq{
SELECT
status
FROM
exp_device
WHERE
exp_id = '$exp_id' AND
location = '$location' AND
device_name = '$device_name'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$status = $cursor->fetchrow;
return($status);
} # end of getDeviceStatus()
#=========================================================
# S E T D E V I C E S T A T U S
#
# Arg1: The database handle
# Arg2: The ExperimentID
# Arg3: The location
# Arg4: The device_name
# Arg5: The status
#=========================================================
sub setDeviceStatus($$$$$)
{
my $dbh = shift or
die "Must supply database handle to setDeviceStatus()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to setDeviceStatus()!\n";
my $location = shift or
die "Must supply location to setDeviceStatus()!\n";
my $device_name = shift or
die "Must supply device_name to setDeviceStatus()!\n";
my $status = shift or
die "Must supply status to setDeviceStatus()!\n";
my $sql = undef;
my $cursor = undef;
#===== Prepare the SQL statement
$sql = qq{
UPDATE
exp_device
SET
status='$status'
WHERE
exp_id = '$exp_id' AND
location = '$location' AND
device_name = '$device_name'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
return;
} # end of setDeviceStatus()
#=========================================================
# G E N E X P E R I M E N T I D
#
# Arg1: The location
#=========================================================
sub genExperimentID($)
{
my $location = shift or
die "Must supply location to genExperimentID()!\n";
my $session_id = Digest::MD5::md5_hex(Digest::MD5::md5_hex(time().{}.rand().$$));
#===== Cut session id down to 8 characters
$session_id = substr($session_id, 0, 8);
#===== Make upper-case
$session_id = uc($session_id);
#===== Prepend location
$session_id = "${location}_${session_id}";
return($session_id);
} # end of genExperimentID()
#=========================================================
# G E T N E W E X P I D
#
# Arg1: The database handle
# Arg1: The location
#=========================================================
sub getNewExpID($$)
{
my $dbh = shift or
die "Must supply database handle to getNewExpID()!\n";
my $location = shift or
die "Must supply location to getNewExpID()!\n";
my $new_exp_id = '';
do
{
$new_exp_id = genExperimentID($location);
}
while (!$new_exp_id or expIDExists($new_exp_id));
return($new_exp_id);
} # end of getNewExpID()
#=========================================================
# E X P I D E X I S T S
#
# Arg1: The database handle.
# Arg2: The ExpID to test. Optional, but of little use
# unless one is given.
# Returns: The ExpID if it is in the database
# nothing otherwise.
#=========================================================
sub expIDExists($;$)
{
my $dbh = shift or
die "Must supply database handle to expIDExists()!\n";
my $exp_id = shift;
my $sql = undef;
my $cursor = undef;
my $exists = '';
if ($exp_id)
{
#===== Prepare the SQL statement
$sql = qq{
SELECT
exp_id
FROM
experiment
WHERE
exp_id = '$exp_id'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$exists = $cursor->fetchrow;
} # if we have an ExpID
return($exists);
} # end of expIDExists()
#=========================================================
# E X P D E V I C E E X I S T S
#
# Arg1: The database handle.
# Arg2: The ExpID to test.
# Arg3: The site location.
# Arg4: The device_name.
# Returns: Number of such devices (hopefully 0 or 1)
#=========================================================
sub expDeviceExists($$$$)
{
my $dbh = shift or
die "Must supply database handle to expDeviceExists()!\n";
my $exp_id = shift or
die "Must supply ExperimentID to expDeviceExists()!\n";
my $location = shift or
die "Must supply location to expDeviceExists()!\n";
my $device_name = shift or
die "Must supply device_name to expDeviceExists()!\n";
my $sql = undef;
my $cursor = undef;
my $exists = '';
#===== Prepare the SQL statement
$sql = qq{
SELECT
count(*)
FROM
exp_device
WHERE
exp_id = '$exp_id' AND
location = '$location' AND
device_name = '$device_name'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$exists = $cursor->fetchrow;
return($exists);
} # end of expDeviceExists()
#=========================================================
# D E V I C E E X I S T S
#
# Arg1: The database handle.
# Arg2: The site location.
# Arg3: The device_name.
# Returns: Number of such devices (hopefully 0 or 1)
#=========================================================
sub deviceExists($$$)
{
my $dbh = shift or
die "Must supply database handle to deviceExists()!\n";
my $location = shift or
die "Must supply location to deviceExists()!\n";
my $device_name = shift or
die "Must supply device_name to deviceExists()!\n";
my $sql = undef;
my $cursor = undef;
my $exists = '';
#===== Prepare the SQL statement
$sql = qq{
SELECT
count(*)
FROM
device
WHERE
location = '$location' AND
device_name = '$device_name'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$cursor->execute;
$exists = $cursor->fetchrow;
return($exists);
} # end of deviceExists()
#=========================================================
# U P D A T E D E V I C E
#
# Arg1: The database handle.
# Arg2: Hash ref containing device info.
# Returns: Nothing for success, an err string on failure.
#=========================================================
sub updateDevice($$)
{
my $dbh = shift or
die "Must supply database handle to updateDevice()!\n";
my $info_ref = shift or
die "Must supply hash ref to updateDevice()!\n";
my $sql = undef;
my $cursor = undef;
my $exists = '';
my $error = '';
my $status = '';
#===== Get device info
my $location = $info_ref->{'location'};
my $device_name = $info_ref->{'device_name'};
my $type = $info_ref->{'type'};
my $hostname = $info_ref->{'hostname'};
my $port = $info_ref->{'port'};
my $descr = $info_ref->{'descr'};
$descr = '' unless $descr;
my $capabilities = $info_ref->{'capabilities'};
$capabilities = '' unless $capabilities;
#===== Verify
die "Must supply location to updateDevice()!\n" unless $location;
die "Must supply device_name to updateDevice()!\n" unless $device_name;
die "Must supply type to updateDevice()!\n" unless $type;
die "Must suply hostname to updateDevice()!\n" unless $hostname;
die "Must supply port to updateDevice()!\n" unless $port;
#===== Massage
$descr =~ s/\'+/\'\'/g; # escape single quotes
#===== See if we're updating or inserting
$exists = deviceExists($dbh, $location, $device_name);
#===== Prepare the SQL statement
if ($exists)
{
$sql = qq{
UPDATE
device
SET
type = '$type',
hostname = '$hostname',
port = '$port',
descr = '$descr',
capabilities = '$capabilities',
last_update = CURRENT_TIMESTAMP()
WHERE
location = '$location' AND
device_name = '$device_name'
};
}
else
{
$sql = qq{
INSERT INTO device
(
location,
device_name,
type,
hostname,
port,
descr,
capabilities,
last_update
)
VALUES
(
'$location',
'$device_name',
'$type',
'$hostname',
'$port',
'$descr',
'$capabilities',
CURRENT_TIMESTAMP()
)
};
}
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$status = $cursor->execute;
$error = $dbh->errstr if $status;
if ($status eq '0E0')
{
$error = "Syntax error in SQL statement $sql!";
}
return($error);
} # end of updateDevice()
#=========================================================
# D E L E T E D E V I C E
#
# Arg1: The database handle.
# Arg2: The location
# Arg3: The device name
# Returns: Nothing for success, an err string on failure.
#=========================================================
sub deleteDevice($$$)
{
my $dbh = shift or
die "Must supply database handle to deleteDevice()!\n";
my $location = shift or
die "Must supply location to deleteDevice()!\n";
my $device_name = shift or
die "Must supply device name to deleteDevice()!\n";
my $sql = undef;
my $cursor = undef;
my $error = '';
my $status = '';
#===== Prepare the SQL statement
$sql = qq{
DELETE FROM
device
WHERE
location = '$location' AND
device_name = '$device_name'
};
$cursor = $dbh->prepare($sql) or
die "Unable to prepare database query: " . $dbh->errstr . "\n";
$status = $cursor->execute;
$error = $dbh->errstr if $status;
if ($status eq '0E0')
{
$error = "Device $location:$device_name was not deleted ";
$error .= "(may not have existed)";
}
return($error);
} # end of deleteDevice()
1
GIMSJavascript.pm 000444 002315 013577 00000047442 11412143676 014467 0 ustar 00cthomas GIMS 000000 000000 #! /usr/bin/perl -w
#=============================================================================
# G I M S J A V A S C R I P T . P M
#
# Written by C. Thomas
#
# $Id: GIMSJavascript.pm,v 1.6 2010/06/28 16:03:04 cthomas Exp $
#=============================================================================
package GIMSJavascript;
#=============================================================================
# U S E / R E Q U I R E
#=============================================================================
use strict;
#=============================================================================
# P R O T O T Y P E S
#=============================================================================
sub printJavascript();
#=============================================================================
# C O N F I G
#=============================================================================
#=============================================================================
# G L O B A L V A R I A B L E S
#=============================================================================
######################### BEGIN SUBROUTINES ##################################
#===================================================================
# P R I N T J A V A S C R I P T
#===================================================================
sub printJavascript()
{
print <<"EOF";
\n";
} # end of printJavascript()
1
XmlRpcUtils.pm 000444 002315 013577 00000067007 11417433065 014125 0 ustar 00cthomas GIMS 000000 000000 #!/usr/bin/perl -w
#==============================================================================
#
# X M L R P C U T I L S . P M
#
# Written by Charles Thomas (cthomas@wisc.edu)
#
# $Id: XmlRpcUtils.pm,v 1.21 2010/07/14 22:11:57 cthomas Exp $
#==============================================================================
package XmlRpcUtils;
#=========================================================
# U S E R E Q U I R E
#=========================================================
use XML::Simple;
use Data::Dumper;
use strict;
#=========================================================
# C O N F I G
#=========================================================
my $xml_version_str = '';
#=========================================================
# P R O T O T Y P E S
#=========================================================
sub getXMLFromHash($);
sub getCommandXML($);
sub getExtendedCommandXML($);
sub getDeviceCapsXML($);
sub getDeviceCapsHash($$);
sub writeMethodResponseXML(;$);
sub writeFaultXML(;$;$);
sub checkForFault($);
sub encodeStruct($;$);
sub encodeArray($;$);
sub encodeElement(;$;$);
sub encodeString(;$;$);
sub encodeInt(;$;$);
sub encodeDouble(;$;$);
sub encodeBoolean(;$;$);
sub getMethodCallHeaderXML($);
sub getMethodResponseHeaderXML();
sub getMethodCallFooterXML();
sub getMethodResponseFooterXML();
sub getValueFromHash($$);
sub getFormattedTextFromXML($);
sub getKeyValuePairs($);
sub getExperimentID($);
sub getCommand($);
sub getLocationAndDeviceName($);
sub getResponseString($);
sub getHttpHeader(;$);
#=========================================================
# G L O B A L V A R I A B L E S
#=========================================================
#################### BEGIN SUBROUTINES ###################
#=========================================================
# G E T X M L F R O M H A S H
#
# Arg1: Hash containing method call information.
# Returns: Formatted XML code as a scalar.
#=========================================================
sub getXMLFromHash($)
{
my $params_ref = shift or
die "Must supply hash ref to getXMLFromHash()!\n";
my $xml_code = '';
my $method_name = $params_ref->{'MethodName'};
#===== Parse the method name
if ($method_name eq 'StartExperiment' or
$method_name eq 'StopExperiment' or
$method_name eq 'PauseExperiment' or
$method_name eq 'GetExperimentStatus' or
$method_name eq 'GetExperimentSettings')
{
$xml_code .= getCommandXML($params_ref);
}
elsif ($method_name eq 'ConfigureExperiment' or
$method_name eq 'GetDeviceCapabilities')
{
$xml_code .= getExtendedCommandXML($params_ref);
}
else
{
$xml_code .= writeFaultXML(-1, "Unknown command $method_name in getXMLFromHash()!");
}
return ($xml_code);
} # end of getXMLFromHash()
#=========================================================
# G E T C O M M A N D X M L
#
# Arg1: Hash containing method call information.
# Returns: Formatted XML code as a scalar.
#=========================================================
sub getCommandXML($)
{
my $params_ref = shift or
die "Must supply hash ref to getCommandXML()!\n";
my $xml_code = '';
my $method_name = $params_ref->{'MethodName'};
my $exp_id = $params_ref->{'ExperimentID'};
#===== Write code if we have what we need
if (defined($exp_id) and $method_name)
{
$xml_code .= getMethodCallHeaderXML($method_name);
$xml_code .= "\n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " ExperimentID\n";
$xml_code .= " " . encodeString($exp_id) . "\n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= "\n";
$xml_code .= getMethodCallFooterXML();
}
else
{
#===== Handle error
$xml_code = writeFaultXML(-1, "Missing parameter to getCommandXML()!");
}
return ($xml_code);
} # end of getCommandXML()
#=========================================================
# G E T E X T E N D E D C O M M A N D X M L
#
# Arg1: Hash containing method call information.
# Returns: Formatted XML code as a scalar.
#=========================================================
sub getExtendedCommandXML($)
{
my $params_ref = shift or
die "Must supply hash ref to getExtendedCommandXML()!\n";
my $xml_code = '';
my $method_name = $params_ref->{'MethodName'};
my $exp_id = $params_ref->{'ExperimentID'};
#===== Write code if we have what we need
if (defined($exp_id) and $method_name)
{
$xml_code .= getMethodCallHeaderXML($method_name);
$xml_code .= "\n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= encodeStruct($params_ref, 4);
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= "\n";
$xml_code .= getMethodCallFooterXML();
}
else
{
#===== Handle error
$xml_code = writeFaultXML(-1, "Missing parameter to getExtendedCommandXML()!");
}
return ($xml_code);
} # end of geExtendedCommandXML()
#=========================================================
# G E T D E V I C E C A P S X M L
#
# Arg1: Hash containing information.
# Returns: Formatted XML code as a scalar.
#=========================================================
sub getDeviceCapsXML($)
{
my $params_ref = shift or
die "Must supply hash ref to getDeviceCapsXML()!\n";
my $xml_code = '';
$xml_code .= getMethodResponseHeaderXML();
$xml_code .= "\n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= encodeStruct($params_ref, 4);
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= "\n";
$xml_code .= getMethodResponseFooterXML();
return($xml_code);
} # end of getDeviceCapsXML($)
#=========================================================
# G E T D E V I C E C A P S H A S H
#
# Arg1: Scalar containing information as XML/RPC.
# Returns: Hash ref
#=========================================================
sub getDeviceCapsHash($$)
{
my $xml_code = shift or
die "Must supply XML/RPC code to getDeviceCapsHash()!\n";
my $caps_ref = shift or
die "Must supply hash ref to getDeviceCapsHash()!\n";
my @lines = split('\n', $xml_code);
my $key = '';
my $value = '';
#===== Process each line
foreach my $line (@lines)
{
if ($line =~ m/\(.+)\<\/name\>/)
{
$key = $1;
}
elsif ($line =~ m/\\(.+)\<\/string\>\<\/value\>/)
{
$value = $1;
$caps_ref->{$key}{$value} = 1;
}
}
return;
} # end of getDeviceCapsHash()
#=========================================================
# W R I T E M E T H O D R E S P O N S E X M L
#
# Arg1: Scalar containing response
# Returns: Formatted XML code as a scalar.
#=========================================================
sub writeMethodResponseXML(;$)
{
my $response = shift;
my $xml_code = '';
$xml_code .= getMethodResponseHeaderXML();
$xml_code .= "\n";
$xml_code .= " \n";
$xml_code .= " $response\n";
$xml_code .= " \n";
$xml_code .= "\n";
$xml_code .= getMethodResponseFooterXML();
return($xml_code);
} # end of writeMethodResponseXML()
#=========================================================
# W R I T E F A U L T X M L
#
# Arg1: Scalar containing numeric fault code.
# Arg2: Scalar containing fault string.
# Returns: Formatted XML code as a scalar.
#=========================================================
sub writeFaultXML(;$;$)
{
my $fault_code = shift;
my $fault_string = shift;
my $xml_code = '';
$xml_code .= getMethodResponseHeaderXML();
$xml_code .= "\n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " faultCode\n";
$xml_code .= " " . encodeInt($fault_code) . "\n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " faultString\n";
$xml_code .= " " . encodeString($fault_string) . "\n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= " \n";
$xml_code .= "\n";
$xml_code .= getMethodResponseFooterXML();
return($xml_code);
} # end of writeFaultXML()
#=============================================================================
# C H E C K F O R F A U L T
# Arg1: The XML-RPC code to parse
# Returns: (faultCode, faultString) if there was a fault.
# undef, undef otherwise
#=============================================================================
sub checkForFault($)
{
my $xml_code = shift or
die "Must supply XML code to checkForFault()!\n";
my $fault_code = undef;
my $fault_string = undef;
#===== Parse the XML-RPC code to a hash
my $hr = XMLin($xml_code, forcearray => 0, keyattr =>['name']);
if (ref($hr->{fault}))
{
$fault_string = "ERROR: ";
foreach my $param_name (keys %{$hr->{fault}{value}{struct}{member}})
{
if ($param_name eq 'faultCode')
{
$fault_code = $hr->{fault}{value}{struct}{member}{$param_name}{value}{string};
}
elsif ($param_name eq 'faultString')
{
$fault_string .= $hr->{fault}{value}{struct}{member}{$param_name}{value}{string};
}
} # for each param
} # if it's a fault
return($fault_code, $fault_string);
} # end of checkForFault()
#=========================================================
# E N C O D E S T R U C T
#
# Arg1: Hash ref containing the data to be encoded.
# Arg2: Level of indentation to start at (optional).
# Returns: Formatted XML code as a scalar.
#=========================================================
sub encodeStruct($;$)
{
my $hash_ref = shift or
die "Must supply hash ref to encodeStruct()!\n";
my $level = shift;
my $xml_code = '';
my $pad = '';
#===== Create padding
$level = 0 unless $level;
foreach (my $i = 0; $i < $level; $i++){$pad .= ' ';}
my $pad2 = "$pad ";
my $pad4 = "$pad2 ";
#===== Start struct
$xml_code .= "$pad\n";
#===== Handle each element of the hash
while (my ($key, $value) = each %{$hash_ref})
{
$xml_code .= "$pad2\n";
$xml_code .= "$pad4$key\n";
if (ref($value) eq 'HASH')
{
$xml_code .= "$pad4\n";
$xml_code .= encodeStruct($value, $level+3);
$xml_code .= "$pad4\n";
}
elsif (ref($value) eq 'ARRAY')
{
$xml_code .= "$pad4\n";
$xml_code .= encodeArray($value, $level+3);
$xml_code .= "$pad4\n";
}
elsif (ref($value) eq 'SCALAR')
{
$xml_code .= "$pad4";
$xml_code .= encodeElement($value, $level+1);
$xml_code .= "\n";
}
elsif (!ref($value) and $value)
{
$xml_code .= "$pad4";
$xml_code .= encodeElement($value, $level+1);
$xml_code .= "\n";
}
else
{
#===== Blank
$xml_code .= "$pad4\n";
}
$xml_code .= "$pad2\n";
} # for each key
$xml_code .= "$pad\n";
return($xml_code);
} # end of encodeStruct()
#=========================================================
# E N C O D E A R R A Y
#
# Arg1: Hash ref containing info to be encoded.
# Arg2: Level of indentation to start at (optional).
# Returns: Formatted XML code as a scalar.
#=========================================================
sub encodeArray($;$)
{
my $array_ref = shift or
die "Must array ref to encodeArray()!\n";
my $level = shift;
my $xml_code = '';
my $pad = '';
#===== Create padding
$level = 0 unless $level;
foreach (my $i = 0; $i < $level; $i++){$pad .= ' ';}
my $pad2 = "$pad ";
$xml_code .= "$pad\n";
#===== Go through each element
foreach my $element (@$array_ref)
{
$xml_code .= "$pad2";
$xml_code .= encodeElement($element, $level+1);
$xml_code .= "\n";
}
$xml_code .= "$pad\n";
return($xml_code);
} # end of encodeArray()
#=========================================================
# E N C O D E E L E M E N T
#
# Examines the element and decides if it's an int,
# double or string. Then calls the appropriate
# sub to process it.
#
# Arg1: Element (int, double, string) to be encoded.
# Arg2: Level of indentation to start at (optional).
# Returns: Formatted XML code as a scalar.
#=========================================================
sub encodeElement(;$;$)
{
my $element = shift;
my $level = shift;
my $xml_code = '';
if ($element =~ m/^\-*\d+$/) # number
{
$xml_code .= encodeInt($element, $level);
}
elsif ($element =~ m/^\-*\d*\.{1}\d*$/) # double
{
$xml_code .= encodeDouble($element, $level);
}
else # string
{
$xml_code .= encodeString($element, $level);
}
return($xml_code);
} # end of encodeElement()
#=========================================================
# E N C O D E S T R I N G
#
# Arg1: String to be encoded.
# Arg2: Level of indentation to start at (optional).
# Returns: Formatted XML code as a scalar.
#=========================================================
sub encodeString(;$;$)
{
my $str = shift;
my $level = shift;
my $xml_code = '';
my $pad = '';
#===== Create padding
$level = 0 unless $level;
foreach (my $i = 0; $i < $level; $i++){$pad .= ' ';}
$xml_code .= "$str";
return($xml_code);
} # end of encodeString()
#=========================================================
# E N C O D E I N T
#
# Arg1: Int to be encoded.
# Arg2: Level of indentation to start at (optional).
# Returns: Formatted XML code as a scalar.
#=========================================================
sub encodeInt(;$;$)
{
my $int = shift;
my $level = shift;
my $xml_code = '';
my $pad = '';
#===== Create padding
$level = 0 unless $level;
foreach (my $i = 0; $i < $level; $i++){$pad .= ' ';}
$xml_code .= "$int";
return($xml_code);
} # end of encodeInt()
#=========================================================
# E N C O D E D O U B L E
#
# Arg1: Double (float) to be encoded.
# Arg2: Level of indentation to start at (optional).
# Returns: Formatted XML code as a scalar.
#=========================================================
sub encodeDouble(;$;$)
{
my $double = shift;
my $level = shift;
my $xml_code = '';
my $pad = '';
#===== Create padding
$level = 0 unless $level;
foreach (my $i = 0; $i < $level; $i++){$pad .= ' ';}
$xml_code .= "$double";
return($xml_code);
} # end of encodeDouble()
#=========================================================
# E N C O D E B O O L E A N
#
# Arg1: Boolean [0|1] to be encoded.
# Arg2: Level of indentation to start at (optional).
# Returns: Formatted XML code as a scalar.
#=========================================================
sub encodeBoolean(;$;$)
{
my $bool = shift;
my $level = shift;
my $xml_code = '';
my $pad = '';
#===== Create padding
$level = 0 unless $level;
foreach (my $i = 0; $i < $level; $i++){$pad .= ' ';}
$xml_code .= "$bool";
return($xml_code);
} # end of encodeBoolean()
#=========================================================
# G E T M E T H O D C A L L H E A D E R X M L
#
# Arg1: Method name
# Returns: Formatted XML code as a scalar.
#=========================================================
sub getMethodCallHeaderXML($)
{
my $method_name = shift or
die "Must supply method name to getMethodCallHeaderXML()!\n";
my $xml_code = '';
$xml_code .= qq~$xml_version_str\n~;
$xml_code .= qq~\n~;
$xml_code .= qq~$method_name\n~;
return($xml_code);
} # end of getMethodCallHeaderXML()
#=============================================================
# G E T M E T H O D R E S P O N S E H E A D E R X M L
#
# Returns: Formatted XML code as a scalar.
#==============================================================
sub getMethodResponseHeaderXML()
{
my $xml_code = '';
$xml_code .= qq~$xml_version_str\n~;
$xml_code .= qq~\n~;
return($xml_code);
} # end of getMethodResponseHeaderXML()
#=========================================================
# G E T M E T H O D C A L L F O O T E R X M L
#
# Returns: Formatted XML code as a scalar.
#=========================================================
sub getMethodCallFooterXML()
{
my $xml_code = '';
$xml_code .= qq~\n~;
return($xml_code);
} # end of getMethodCallFooterXML()
#=============================================================
# G E T M E T H O D R E S P O N S E F O O T E R X M L
#
# Returns: Formatted XML code as a scalar.
#=============================================================
sub getMethodResponseFooterXML()
{
my $xml_code = '';
$xml_code .= qq~\n~;
return($xml_code);
} # end of getMethodResponseFooterXML()
#=============================================================
# G E T V A L U E F R O M H A S H
#
# Arg1: Reference to the hash to be searched.
# Arg2: The key we're looking for.
# Returns: The value if the key was found, undef otherwise.
#=============================================================
sub getValueFromHash($$)
{
my $info_ref = shift or
die "Must supply hash ref to getValueFromHash()!\n";
my $search_key = shift or
die "Must supply key to getValueFromHash()!\n";
my $value = undef;
#===== Make sure it's a ref
die "Not a hash ref at getValueFromHash()!\n" unless ref($info_ref);
foreach my $key (keys %{$info_ref})
{
if ($key eq $search_key)
{
#===== We found our key, get the XML value
$value = $info_ref->{$key}{value}{string};
last;
}
elsif (ref($info_ref->{$key}) eq 'HASH')
{
$value = getValueFromHash($info_ref->{$key}, $search_key);
last if $value;
} # if the key is a ref itself
} # foreach key
return($value);
} # end of getValueFromHash()
#=============================================================
# G E T F O R M A T T E D T E X T F R O M X M L
#
# Arg1: The XML/RPC code to be transformed.
# Returns: Formatted text.
#=============================================================
sub getFormattedTextFromXML($)
{
my $xml = shift or
die "Must supply XML code to getFormattedTextFromXML()!\n";
my $text = '';
#==== Use XML::Simple to turn the XML code into a hash
my $hr = XMLin($xml, forcearray => 0, keyattr => []);
#===== Get key/value pairs
$text = getKeyValuePairs($hr);
return($text);
} # end of getFormattedTextFromXML()
sub getKeyValuePairs($)
{
my $info_ref = shift or
die "Must supply ref to getKeyValuePairs()!\n";
my $str = '';
my @keys = ();
my $type = '';
#===== Make sure it's a ref
die "Not a hash ref at getKeyValuePairs()!\n" unless ref($info_ref);
if (ref($info_ref) eq 'HASH')
{
@keys = keys %{$info_ref};
$type = 'hash';
}
elsif (ref($info_ref) eq 'ARRAY')
{
@keys = @$info_ref;
$type = 'array';
}
#===== Now walk through the keys
for (my $i = 0; $i < scalar(@keys); $i++)
{
my $key = $keys[$i];
my $value = '';
if ($type eq 'hash')
{
$value = $info_ref->{$key};
}
elsif ($type eq 'array')
{
$value = ${$info_ref}[$i];
}
if (!ref($value))
{
$str .= "$key => $value\n";
} # if $value is not a reference
elsif (ref($value) eq 'SCALAR')
{
$str .= "$key => $$value\n";
} # $value is a scalar ref
elsif (ref($value) eq 'ARRAY')
{
$str .= getKeyValuePairs($value);
} # if $value is an array ref
elsif (ref($value) eq 'HASH')
{
if (defined($value->{value}{string}))
{
my $new_value = $value->{value}{string};
if (defined($value->{name}))
{
my $name = $value->{name};
$str .= "$name => $new_value\n";
delete($value->{name});
}
else
{
$str .= "$key => $new_value\n";
}
delete($value->{value}{string});
}
elsif (defined($value->{value}{double}))
{
my $new_value = $value->{value}{double};
if (defined($value->{name}))
{
my $name = $value->{name};
$str .= "$name => $new_value\n";
delete($value->{name});
}
else
{
$str .= "$key => $new_value\n";
}
delete($value->{value}{double});
}
elsif (defined($value->{value}{int}))
{
my $new_value = $value->{value}{int};
if (defined($value->{name}))
{
my $name = $value->{name};
$str .= "$name => $new_value\n";
delete($value->{name});
}
else
{
$str .= "$key => $new_value\n";
}
delete($value->{value}{int});
}
elsif (defined($value->{name}))
{
my $name = $value->{name};
$str .= "<$name>\n";
delete($value->{name});
$str .= getKeyValuePairs($value->{value});
delete($value->{value});
$str .= "$name>\n";
}
elsif (defined($value->{value}{struct}{member}))
{
$str .= getKeyValuePairs($value->{value}{struct}{member});
delete ($value->{value}{struct}{member});
}
elsif (defined($value->{value}))
{
delete($value->{value});
}
$str .= getKeyValuePairs($value);
} # if $value is a hash ref
} # foreach key
return($str);
} # end of getKeyValuePairs()
#===========================================================
# G E T E X P E R I M E N T I D
#
# Parses XML-RPC call looking for the experiment ID
#
# Arg1: Raw XML-RPC data
# Returns: ExperimentID or undef if none found
#===========================================================
sub getExperimentID($)
{
my $xml = shift or
die("Must supply XML code to getExperimentID()!\n");
my $exp_id = undef;
#==== Use XML::Simple to turn the XML code into a hash
my $hr = XMLin($xml, forcearray => 0, keyattr => ['name']);
#===== Debug
#$Data::Dumper::Indent = 1;
#my $dump = Dumper($hr);
#print "$dump\n";
#===== Check extended syntax
if (!ref($hr->{params}{param}{value}{struct}{member}{'ExperimentID'}{value}{string}) and
$hr->{params}{param}{value}{struct}{member}{'ExperimentID'}{value}{string})
{
$exp_id = $hr->{params}{param}{value}{struct}{member}{'ExperimentID'}{value}{string};
}
#===== Check the simple command syntax
elsif (!ref($hr->{params}{param}{value}{struct}{member}{value}{string}) and
$hr->{params}{param}{value}{struct}{member}{value}{string})
{
$exp_id = $hr->{params}{param}{value}{struct}{member}{value}{string};
}
return($exp_id);
} # end of getExperimentID()
#===========================================================
# G E T C O M M A N D
#
# Arg1: The XML text to be parsed
#===========================================================
sub getCommand($)
{
my $xml = shift or
die("Must supply XML code to getCommand()!\n");
my $result = '';
my $param_name = '';
my $param_value = '';
#===== Use XML::Simple to turn the XML code into a hash
my $hr = XMLin($xml);
#===== Start Capture
if ($hr->{methodName} =~ m/StartExperiment/)
{
$result = "StartExperiment";
} # start_capture
#===== Pause Capture
if ($hr->{methodName} =~ m/PauseExperiment/)
{
$result = "PauseExperiment";
} # pause_capture
#===== Stop Capture
elsif ($hr->{methodName} =~ m/StopExperiment/)
{
$result = "StopExperiment";
} # stop_capture
#===== Set Capture Params
elsif ($hr->{methodName} =~ m/ConfigureExperiment/)
{
$result = "ConfigureExperiment";
} # set_capture_params
#===== Get Experiment Status
elsif ($hr->{methodName} =~ m/GetExperimentStatus/)
{
$result = "GetExperimentStatus";
} # GetExperimentStatus
#===== Get Experiment Settings
elsif ($hr->{methodName} =~ m/GetExperimentSettings/)
{
$result = "GetExperimentSettings";
} # GetExperimentSettings
#===== Get device capabilities
elsif ($hr->{methodName} =~ m/GetDeviceCapabilities/)
{
$result = "GetDeviceCapabilities";
} # GetDeviceCapabilities
#===== Get experiment results
elsif ($hr->{methodName} =~ m/GetExperimentResults/)
{
$result = "GetExperimentResults";
} # GetDeviceCapabilities
#===== Chomp result
chomp($result);
return($result);
} # end of getCommand()
#===========================================================
# G E T L O C A T I O N A N D D E V I C E N A M E
#
# Parses XML-RPC call looking for the location name
# for which we'll request device capabilities.
#
# Arg1: Raw XML-RPC data
# Returns: Location name
#===========================================================
sub getLocationAndDeviceName($)
{
my $xml = shift or
informAndDie("Must supply XML code to getLocationAndDeviceName()!\n");
my $location_name = '';
my $device_name = '';
#===== Use XML::Simple to turn the XML code into a hash
my $hr = XMLin($xml, forcearray => 0, keyattr => ['name']);
# Debug
#$Data::Dumper::Indent = 1;
#my $dump = Dumper($hr);
#print "$dump\n";
#===== Grab the location name
if (defined($hr->{params}{param}{value}{struct}{member}{'SiteLocation'}{value}{string}))
{
$location_name = $hr->{params}{param}{value}{struct}{member}{'SiteLocation'}{value}{string};
}
if (defined($hr->{params}{param}{value}{struct}{member}{'DeviceName'}{value}{string}))
{
$device_name = $hr->{params}{param}{value}{struct}{member}{'DeviceName'}{value}{string};
}
return($location_name, $device_name);
} # end of getLocationAndDeviceName()
#==========================================================
# G E T R E S P O N S E S T R I N G
#
# Arg1: The XML/RPC code as a scalar.
# Returns: The response string or '' if unable to parse.
#==========================================================
sub getResponseString($)
{
my $xml = shift or
informAndDie("Must supply XML code to getResponseString()!\n");
my $result = '';
#===== Filter out http header stuff
$xml =~ /(..xml\sversio.*)$/s;
$xml = $1;
#===== Check for faults
my ($fault_code, $fault_string) = checkForFault($xml);
#===== Handle faults
if ($fault_string)
{
$result = $fault_string;
} # if we have a fault
else
{
#===== Use XML::Simple to turn the XML code into a hash
my $xml_ref = XMLin($xml, forcearray => 0, keyattr => ['name']);
# Debug
#$Data::Dumper::Indent = 1;
#return(Dumper($xml_ref));
my $response = $xml_ref->{'params'}{'param'}{'value'}{'string'};
$result = "$response";
}
return($result);
} # end of getResponseString()
#===========================================================
# G E T H T T P H E A D E R
#
# Arg1: Length of the content in bytes (zero if not sent)
# Returns: The standard HTTP Header
#===========================================================
sub getHttpHeader(;$)
{
my $content_length = shift;
my $header = '';
$content_length = '0' unless $content_length;
$header .= "POST /RPC2 HTTP/1.0\n";
$header .= "Content-Type: text/xml\n";
$header .= sprintf("Content-length: %i\n\n", $content_length);
return($header);
} # end of getHttpHeader()
1
db_diagram.png 000664 002315 013577 00000014056 11361130222 014103 0 ustar 00cthomas GIMS 000000 000000 PNG
IHDR PLTE _ U IDATx]i(Y"hN[@wG
! ussP|<1/z1x_3]W^~:hP__:KA)7oQ(iTn5$|N_ON!?㥋~n~?1`agk?j)7hWjP`?H
G&Ax&>r6w({anQ|+T0\z*i?Pd!q}FMC}G!zB_}|YR׃uXO`A(+jWLF
ӟzg/Ue/'ٯ/Ի{SU$}暴CWW,\?knFڗ_^ݨ?UN݉S7>@یuꂮVR_U~/AWeSz9@_Aך
#!3Ϡo|
n
Ąfnrp