grabron.in 6.61 KB
Newer Older
Robert Ricci's avatar
Robert Ricci committed
1
#!/usr/bin/perl -w
Leigh B. Stoller's avatar
Leigh B. Stoller committed
2 3 4

#
# EMULAB-COPYRIGHT
5
# Copyright (c) 2000-2003 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
6 7
# All rights reserved.
#
Robert Ricci's avatar
Robert Ricci committed
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
#
# grabron - Grab data from Dave Andersen's DBSYNC program, and upload it into
# the testbed database
#

use strict;

use IO::Socket;
use Net::hostent;

use lib '@prefix@/lib';
use libdb;
use libtestbed;

my $TB = '@prefix@';

Robert Ricci's avatar
Robert Ricci committed
24 25 26 27 28 29 30 31
#
# This is the magic node which is equivalent to the TBDB_WIDEAREA_LOCALNODE .
# This could be moved to a configure variable, but I'm not going to do so
# until there's a need to go to that trouble. It's hacky, no matter where
# you put it.
#
my $MAGICNODE = "ron2";

Robert Ricci's avatar
Robert Ricci committed
32 33
my $logfile = "$TB/log/grabron";

34 35
my $debug = 0;

36 37
if (@ARGV != 1) {
    die "Usage: $0 <url>\n";
Robert Ricci's avatar
Robert Ricci committed
38
}
39 40 41 42 43 44
my ($url) = @ARGV;
if (! ($url =~ /^http:\/\/([\w-.]+)\/(.*)$/) ) {
    die "URL must be in the form http://host/path\n";
}
my ($host,$path) = ($1,$2);
print "Host is $host, path is $path\n";
Robert Ricci's avatar
Robert Ricci committed
45 46 47 48 49 50

$| = 1;

#
# Time in beteen polls
#
51
my $interval = 25 * 60 *60; # 24 hours
Robert Ricci's avatar
Robert Ricci committed
52

Robert Ricci's avatar
Robert Ricci committed
53 54 55 56 57 58 59 60 61
#
# Find out the interface to use for the TBDB_WIDEAREA_LOCALNODE, since I don't
# want to hardcode it anywhere.
# XXX: What if it has more than one interface?
#
my $result = DBQueryFatal("select iface from interfaces where node_id='" .
	TBDB_WIDEAREA_LOCALNODE . "'");
if ($result->num_rows() != 1){
    die "Unable to determine iface for " . TBDB_WIDEAREA_LOCALNODE . "\n";
Robert Ricci's avatar
Robert Ricci committed
62
}
Robert Ricci's avatar
Robert Ricci committed
63 64
my ($localIface) = ($result->fetchrow());

65 66 67 68
if (!$debug) {
    if (TBBackGround($logfile)) {
	exit(0);
    }
69
}
Robert Ricci's avatar
Robert Ricci committed
70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88

#
# Start out with the the last $interval seconds
#
my $last_time = time - $interval;

while (1) {
    my @times = get_times($last_time);
    $last_time = time;
    if (@times) {
    	my %ipmap = get_ipmap();
    	my %bandwidths = get_bandwidths();
    	upload_times(\@times,\%ipmap,\%bandwidths);
    }

    sleep($interval);
}

sub get_ipmap() {
89
    my $result = DBQueryFatal("select node_id,iface, IP from interfaces");
Robert Ricci's avatar
Robert Ricci committed
90 91 92 93 94 95 96 97
    my %map = ();
    while (my ($node_id,$iface,$IP) = $result->fetchrow()) {
	$map{$IP} = [$node_id, $iface];
    }
    return %map;
}

sub get_bandwidths() {
98 99
    my $result = DBQueryFatal("select node_id1,iface1,node_id2,iface2, ".
	    "bandwidth from widearea_delays");
Robert Ricci's avatar
Robert Ricci committed
100
    my %map = ();
101 102
    while (my ($node1,$if1,$node2,$if2,$bandwidth) = $result->fetchrow()) {
	$map{"$node1:$if1 $node2:$if2"} = $bandwidth;
Robert Ricci's avatar
Robert Ricci committed
103 104 105 106 107 108 109 110 111 112 113 114
    }
    return %map;
}

sub upload_times($$$) {
    my ($rTimes,$rIPmap,$rBandwidths) = @_;
    my @times = @$rTimes;
    my %ipmap = %$rIPmap;
    my %bandwidths = %$rBandwidths;
    my $suceeded = 0;
    my $failed = 0;
    foreach my $time (@times) {
115
	my ($src,$dst,$latency,$stddev,$lossrate) = @$time;
Robert Ricci's avatar
Robert Ricci committed
116 117 118 119 120 121 122 123 124 125 126 127
	if (!$ipmap{$src}) {
	    warn "Got an IP ($src) that's not in the interfaces table\n";
	    $failed++;
	    next;
	}
	my ($node_id1, $iface1) = @{$ipmap{$src}};
	if (!$ipmap{$dst}) {
	    warn "Got an IP ($dst) that's not in the interfaces table\n";
	    $failed++;
	    next;
	}
	my ($node_id2, $iface2) = @{$ipmap{$dst}};
128 129
	my $bandwidth = $bandwidths{"$node_id1:$iface1 $node_id2:$iface2"};
	if (!defined $bandwidth) {
130 131
	    warn "Got a pair ($node_id1:$iface1 $node_id2:$iface2) that has ".
		    "no bandwidth\n";
132
	    $bandwidth = -1;
Robert Ricci's avatar
Robert Ricci committed
133 134 135 136 137 138 139 140 141 142
	}
	if (!defined($latency)) {
	    #
	    # If no latency, that means we can't get there from here, so
	    # we provide -1s in bandwidth and latency, to specify that
	    #
	    $latency = -1;
	    $bandwidth = -1;
	}
	$suceeded++;
Robert Ricci's avatar
Robert Ricci committed
143 144 145
	DBQueryFatal("replace into widearea_recent set time=$latency, " .
		"node_id1='$node_id1', iface1='$iface1', ".
		"node_id2='$node_id2', iface2='$iface2', " .
146
		" bandwidth=$bandwidth, time_stddev='$stddev', " .
147 148
		" lossrate='$lossrate', start_time=$::last_time, " .
		" end_time=$::end_time");
Robert Ricci's avatar
Robert Ricci committed
149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
	#
	# If either (or both) endpoints are the magic node, we update
	# the database again, with the WIDEAREA_LOCALNODE instead.
	#
	if (($node_id1 eq $MAGICNODE) || ($node_id2 eq $MAGICNODE)) {
	    if ($node_id1 eq $MAGICNODE) {
		$node_id1 = TBDB_WIDEAREA_LOCALNODE;
		$iface1 = $localIface;
	    }
	    if ($node_id2 eq $MAGICNODE) {
		$node_id2 = TBDB_WIDEAREA_LOCALNODE;
		$iface2 = $localIface;
	    }
	    DBQueryFatal("replace into widearea_recent set time=$latency, ".
		" node_id1='$node_id1', iface1='$iface1', ".
		" node_id2='$node_id2', iface2='$iface2', " .
		" bandwidth=$bandwidth, time_stddev='$stddev', " .
		" lossrate='$lossrate', start_time=$::last_time, " .
		" end_time=$::end_time");
	}
Robert Ricci's avatar
Robert Ricci committed
169 170 171 172 173 174 175 176

    }

    print "Database upload done: $suceeded suceeded, $failed failed\n";
}

sub get_times($) {
    my ($last_time) = (@_);
177 178 179
    my $end_time = time();
    
    print "Connecting to $host\n";
Robert Ricci's avatar
Robert Ricci committed
180 181 182

    my $remote = IO::Socket::INET->new ( Proto => "tcp",
    					 PeerAddr => $host,
183
					 PeerPort => 80 );
Robert Ricci's avatar
Robert Ricci committed
184
    if (!$remote) {
185
	warn "Unable to connect to to $host\n";
Robert Ricci's avatar
Robert Ricci committed
186 187 188 189
	return ();
    }

    $remote->autoflush(1); # Equivalent of $| = 1
190 191
	
    print "Giving times $last_time $end_time\n";
Robert Ricci's avatar
Robert Ricci committed
192

193 194 195 196
    my $args = "start=$last_time&end=$end_time&format=avgTxt";
    print $remote "GET http://$host/$path?$args HTTP/1.0\n";
    print $remote "User-Agent: grabron\n";
    print $remote "\n";
Robert Ricci's avatar
Robert Ricci committed
197

198 199 200 201 202
    #
    # Set some gloabls, so that other functions see these times
    #
    $::last_time = $last_time;
    $::end_time = $end_time;
Robert Ricci's avatar
Robert Ricci committed
203

204 205 206 207 208
    $/ = "\r\n"; # Use CRLF instead of just LF to delimit lines
    my @data = <$remote>;
    chomp @data;
    if (!@data) {
	warn "No data returned\n";
Robert Ricci's avatar
Robert Ricci committed
209 210 211 212 213
	undef $remote;
	return ();
    }

    #
214
    # Check HTTP header, make sure we got back a 200
Robert Ricci's avatar
Robert Ricci committed
215
    #
216 217 218
    my $firstline = shift @data;
    if (! ($firstline =~ /^HTTP\/\d\.\d (\d+) (.*)$/)) {
	warn "Unexpected header: $firstline\n";
Robert Ricci's avatar
Robert Ricci committed
219 220 221
	undef $remote;
	return ();
    }
222 223 224
    my ($status,$stext) = ($1,$2);
    if ($status != 200) {
	warn "Unexpected status: $status $stext\n";
Robert Ricci's avatar
Robert Ricci committed
225 226 227 228
	undef $remote;
	return ();
    }

229
    #
230
    # Eat the rest of the headers
231
    #
232
    while (shift @data) { }
Robert Ricci's avatar
Robert Ricci committed
233 234

    #
235 236
    # XXX - hack to work around oddity in fetchAll's output - it uses CRLF for
    # headers (the standard), but newlines for the body
Robert Ricci's avatar
Robert Ricci committed
237
    #
238 239 240
    if (@data == 1) {
	@data = split /\n/,$data[0];
    }
Robert Ricci's avatar
Robert Ricci committed
241 242 243 244

    my @return;
    foreach my $line (@data) {
	chomp $line;
245 246 247
	if ($debug) {
	    print "got line $line\n";
	}
248
	if (! ($line =~ /(\d+\.\d+.\d+\.\d+)\s+(\d+\.\d+.\d+\.\d+)\s+(\d+\.\d+)\s+(\d+\.\d+)\s+(\d+)\s+(\d+)/) ) {
Robert Ricci's avatar
Robert Ricci committed
249 250 251 252
	    warn "Bad data line: $line\n";
	    next;
	}

253 254
	my ($src,$dst,$avg,$stddev,$successful,$unsuccessful)
	    = ($1,$2,$3,$4,$5,$6);
Robert Ricci's avatar
Robert Ricci committed
255
	if ($successful > 0) {
256 257
	    my $lossrate = ($unsuccessful*1.0)/($successful + $unsuccessful);
	    push @return, [$src,$dst,$avg,$stddev,$lossrate];
Robert Ricci's avatar
Robert Ricci committed
258
	} elsif ($unsuccessful > 0) {
259
	    push @return, [$src,$dst,undef,$stddev,1];
Robert Ricci's avatar
Robert Ricci committed
260 261 262 263 264 265 266 267 268 269
	}
    }

    print "Got " . scalar(@return) . " lines of new data\n";

    undef $remote;

    return @return;

}