gentopofile.in 16.9 KB
Newer Older
1
2
3
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
4
# Copyright (c) 2000-2011 University of Utah and the Flux Group.
5
6
7
8
9
10
11
12
# All rights reserved.
#
use English;
use Getopt::Std;

#
# usage: gentopofile <pid> <eid>
#
Timothy Stack's avatar
   
Timothy Stack committed
13
14
15
16
# This little program generates two topology files that are given to the
# physical nodes in an experiment.  The first one is used to generate the
# /etc/hosts files and their routes.  The second one is used by linktest to
# figure out what tests to run.
17
18
19
#
sub usage()
{
20
    print("Usage: gentopofile [-n] <pid> <eid>\n".
Timothy Stack's avatar
   
Timothy Stack committed
21
	  "  Use -n to print to stdout/stderr, but leave the file alone.\n");
22
23
    exit(-1);
}
Timothy Stack's avatar
   
Timothy Stack committed
24
my $optlist  = "n";
25
26
my $impotent = 0;
my $toponame = "topomap";
Timothy Stack's avatar
   
Timothy Stack committed
27
my $ltname   = "ltmap";
28
my $ltpname  = "ltpmap";
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

#
# Configure variables
#
my $TB		= "@prefix@";

#
# Testbed Support libraries
#
use lib "@prefix@/lib";
use libdb;
use libtestbed;

# un-taint path
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

#
# Turn off line buffering on output
#
$| = 1; 

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
if (defined($options{"n"})) {
    $impotent = 1;
}
if (@ARGV != 2) {
    usage();
}
my $pid = $ARGV[0];
my $eid = $ARGV[1];

#
# Untaint args.
#
if ($pid =~ /^([-\@\w]+)$/) {
    $pid = $1;
}
else {
    die("Bad data in pid: $pid.");
}
if ($eid =~ /^([-\@\w]+)$/) {
    $eid = $1;
}
else {
    die("Bad data in eid: $eid.");
}

84
85
86
87
88
89
90
# Do this in case we are not called from tbprerun.
my $workdir = TBExptWorkDir($pid, $eid);

chdir("$workdir") or
    die("*** $0:\n".
	"    Could not chdir to $workdir: $!");

91
92
93
94
95
# The output stream.
my $OUT;

if ($impotent) {
    $OUT = *STDOUT;
Timothy Stack's avatar
   
Timothy Stack committed
96
    $LTOUT = *STDERR;
97
98
}
else {
99
100
101
    unlink("${toponame}.new")
	if (-e "${toponame}.new");
    
102
103
    open(MAP, "> ${toponame}.new") or
	die("Could not create ${toponame}.new: $!\n");
104
105

    $OUT = *MAP;
Timothy Stack's avatar
   
Timothy Stack committed
106

107
108
109
    unlink("${ltname}.new")
	if (-e "${ltname}.new");
    
Timothy Stack's avatar
   
Timothy Stack committed
110
111
112
113
    open(LTMAP, "> ${ltname}.new") or
	die("Could not create ${ltname}.new: $!\n");

    $LTOUT = *LTMAP;
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
}

my %nodes = ();
my %ips   = ();
my %lans  = ();

#
# Grab the node table and save the ips for each node:port. We are going to use
# this info to convert the DB representation of:
#
# nodeA, 0:1.1.1.1 1:2.2.2.2 2:3.3.3.3
# to
# nodeA, lan0:1.1.1.1 lan1:2.2.2.2 lan2:3.3.3.3
#
# Since the port numbers are totally pointless outside of assign_wrapper.
#
my $query_result =
131
    DBQueryFatal("select v.vname from virt_nodes as v " .
132
133
134
		 "where v.pid='$pid' and v.eid='$eid' " .
		 "      order by v.vname");

135
while (my ($vname) = $query_result->fetchrow_array()) {
136
137
    $nodes{$vname} = {};
    
Timothy Stack's avatar
   
Timothy Stack committed
138
    print $LTOUT "h $vname\n";
139
140
141
142
143
144
145
}
$query_result =
    DBQueryFatal("select vnode,vport,ip from virt_lans " .
		 "where pid='$pid' and eid='$eid'");

while (my ($vnode,$vport,$ip) = $query_result->fetchrow_array()) {
    $ips{"$vnode:$vport"} = $ip;
146
147
}

Timothy Stack's avatar
   
Timothy Stack committed
148
149
150
#
# Generate the linktest config for links, which looks like:
#
151
152
153
154
155
156
157
158
#   l node0 node1 bw delay loss lname dropstyle
#
# where node0 and node1 are the user-given names of the end points,
# bw is the bandwidth in bits/sec,
# delay is the latency in (fractional) seconds,
# loss is the packet loss rate as a fraction,
# lname is the user-given name of the link,
# dropstyle is "droptail" or "gred".
Timothy Stack's avatar
   
Timothy Stack committed
159
#
160
161
my %virt_lans = ();

Timothy Stack's avatar
   
Timothy Stack committed
162
$query_result =
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
    DBQueryFatal("select * from virt_lans ".
		 "where pid='$pid' and eid='$eid' ".
		 "order by vname,member");

while (my $rowref = $query_result->fetchrow_hashref()) {
    my $vname  = $rowref->{"vname"};
    my $member = $rowref->{"member"};

    #
    # Create a row for this lan, if we have not seen it already.
    #
    if (!exists($virt_lans{$vname})) {
	my $rec = {};
	$rec->{"MEMBERLIST"} = [];
	$rec->{"MEMBERS"}    = {};
	$virt_lans{$vname}   = $rec;
    }
    $virt_lans{$vname}->{"MEMBERS"}->{$member} = $rowref;
    push(@{$virt_lans{$vname}->{"MEMBERLIST"}}, $member);
}

foreach my $lan (keys(%virt_lans)) {
    my @members = @{$virt_lans{$lan}->{"MEMBERLIST"}};

    if (@members == 2) {
	my $member0 = $virt_lans{$lan}->{"MEMBERS"}->{$members[0]};
	my $member1 = $virt_lans{$lan}->{"MEMBERS"}->{$members[1]};

191
192
193
194
195
196
197
198
199
	my $node0      = $member0->{"vnode"};
	my $delay0     = $member0->{"delay"};
	my $loss0      = $member0->{"lossrate"};
	my $bw0        = $member0->{"bandwidth"};
	my $backfill0  = $member0->{"backfill"};
	my $rdelay0    = $member0->{"rdelay"};
	my $rloss0     = $member0->{"rlossrate"};
	my $rbw0       = $member0->{"rbandwidth"};
	my $rbackfill0 = $member0->{"rbackfill"};
200
201
202
203
	my $qtype0  = "droptail";
	if ($member0->{"q_red"}) {
	    $qtype0 = ($member0->{"q_gentle"} ? "gred" : "red");
	}
204

205
206
207
208
209
210
211
212
213
214
	my $node1      = $member1->{"vnode"};
	my $delay1     = $member1->{"delay"};
	my $loss1      = $member1->{"lossrate"};
	my $bw1        = $member1->{"bandwidth"};
	my $backfill1  = $member1->{"backfill"};
	my $rdelay1    = $member1->{"rdelay"};
	my $rloss1     = $member1->{"rlossrate"};
	my $rbw1       = $member1->{"rbandwidth"};
	my $rbackfill1 = $member1->{"rbackfill"};
	my $qtype1     = "droptail";
215
216
217
	if ($member1->{"q_red"}) {
	    $qtype1 = ($member1->{"q_gentle"} ? "gred" : "red");
	}
218
	
219
	# ebw stands for effective bandwith, it is bw - backfill
220
221
222
	my $delay = ($delay0+$rdelay1) / 1000.0 ;
	my $loss = 1-(1-$loss0)*(1-$rloss1);
	my $bw = &min($bw0,$rbw1) * 1000;
223
224
	my $backfill = &max($backfill0,$rbackfill1) * 1000;
	my $ebw = $bw - $backfill;
225
226
227
	my $rdelay = ($rdelay0+$delay1) / 1000.0;
	my $rloss = 1-(1-$rloss0)*(1-$loss1);
	my $rbw = &min($rbw0,$bw1) * 1000;
228
229
	my $rbackfill = &max($rbackfill0,$backfill1) * 1000;
	my $rebw = $rbw - $rbackfill;
230
231

	printf $LTOUT
232
	    "l $node0 $node1 $ebw %.4f %.6f $lan $qtype0\n", $delay, $loss;
233
	printf $LTOUT
234
	    "l $node1 $node0 $rebw %.4f %.6f $lan $qtype1\n", $rdelay, $rloss;
235
236
237
238
239
    }
    else {
	foreach my $memb0 (@members) {
	    my $member0 = $virt_lans{$lan}->{"MEMBERS"}->{$memb0};
	    
240
241
242
243
244
	    my $node0     = $member0->{"vnode"};
	    my $delay0    = $member0->{"delay"};
	    my $loss0     = $member0->{"lossrate"};
	    my $bw0       = $member0->{"bandwidth"};
	    my $backfill0 = $member0->{"backfill"};
245
246
247
248
249
	    
	    foreach my $memb1 (@members) {
		next
		    if ($memb0 eq $memb1);

250
251
252
253
254
255
		my $member1    = $virt_lans{$lan}->{"MEMBERS"}->{$memb1};
		my $node1      = $member1->{"vnode"};
		my $rdelay1    = $member1->{"rdelay"};
		my $rloss1     = $member1->{"rlossrate"};
		my $rbw1       = $member1->{"rbandwidth"};
		my $rbackfill1 = $member1->{"rbackfill"};
256
257
258
259
		my $qtype1  = "droptail";
		if ($member1->{"q_red"}) {
		    $qtype1 = ($member1->{"q_gentle"} ? "gred" : "red");
		}
260

261
		# ebw stands for effective bandwith, it is bw - backfill
262
263
264
		my $delay = ($delay0+$rdelay1) / 1000.0;
		my $loss = 1-(1-$loss0)*(1-$rloss1);
		my $bw = &min($bw0,$rbw1) * 1000;
265
266
		my $backfill = &max($backfill0,$rbackfill1) * 1000;
		my $ebw = $bw - $backfill;
267
268

		printf $LTOUT
269
		    "l $node0 $node1 $ebw %.4f %.6f $lan $qtype1\n",
270
		    $delay, $loss;
271
272
273
	    }
	}
    }
Timothy Stack's avatar
   
Timothy Stack committed
274
275
276
277
278
}

#
# Generate the linktest config for the routing type.
#
279
280
281
282
# XXX Linktest only supports one type of routing per-experiment at the moment,
# not per-node.  We also have to prune out the firewall since it always has
# routertype == "none".
#
Timothy Stack's avatar
   
Timothy Stack committed
283
$query_result =
284
285
286
287
288
289
    DBQueryFatal("select vn.routertype from virt_nodes as vn ".
		 "left join virt_firewalls as vf on (vf.pid=vn.pid and ".
		 "  vf.eid=vn.eid and vf.fwname=vn.vname) ".
		 "where vn.pid='$pid' and vn.eid='$eid' ".
		 "  and vf.fwname is null ".
		 "group by routertype");
Timothy Stack's avatar
   
Timothy Stack committed
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305

while (my ($rt) = $query_result->fetchrow_array) {
    print $LTOUT "r $rt\n";
}

#
# Generate the linktest config for the simulator agent's name.
#
$query_result =
    DBQueryFatal("select distinct vname from virt_agents ".
		 "where pid='$pid' and eid='$eid' and objecttype=6");

while (my ($sim) = $query_result->fetchrow_array) {
    print $LTOUT "s $sim\n";
}

306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
#
# Grab the lans table. We are going to spit out one entry per lan, but
# we need to convert port:ip above to lan:ip.
# 
$query_result =
    DBQueryFatal("select vname,member,mask,cost from virt_lans as v ".
		 "where v.pid='$pid' and v.eid='$eid' ");

while (my ($vname,$member,$mask,$cost) = $query_result->fetchrow_array) {
    # One entry per lan.
    if (! defined($lans{$vname})) {
	$lans{$vname} = {};
	$lans{$vname}->{"mask"} = $mask;
	$lans{$vname}->{"cost"} = $cost;
    }
    # Store lan:ip into the portlist for the node.
    my ($node,$port) = split(":", $member);
    my $ip = $ips{$member};
    $nodes{$node}->{$port} = "$vname:$ip";
}

#
# First spit out the nodes.
#
# ALWAYS print this header; rather then a version number, it serves
# to describe the format of the data that follows. 
#
print $OUT "# nodes: vname,links\n";

335
foreach my $node (sort keys(%nodes)) {
336
337
338
339
340
341
342
343
344
345
    print $OUT "$node,";
    print $OUT join(" ", values(%{ $nodes{$node} }));
    print $OUT "\n";
}

#
# Then spit out the lans. As above, ALWAYS print the header.
#
print $OUT "# lans: vname,mask,cost\n";

346
foreach my $lan (sort keys(%lans)) {
347
348
349
350
351
    my $cost = $lans{$lan}->{"cost"};
    my $mask = $lans{$lan}->{"mask"};
    print $OUT "$lan,$mask,$cost\n";
}

352
353
#
# Finally generate a "physical resource" map for linktest if the
354
355
356
357
358
359
360
361
362
363
# experiment is swapped in.  It is a dual of the virtual ltmap,
# containing "instantiation" information about nodes and links.
# First we have a version number:
#
# V number
#
# What a forward-thinking concept!
#
# A node info line looks like:
#
364
#   H vname pname phost ptype OSID OS-name OS-version OS-features
365
#
366
367
368
369
370
# where vname is the experimenter given name like in the ltmap,
# pname is the physical node name (e.g., "pc10", "pcvm10-2"),
# phost is the "hosting" physical node for vnodes (or pname for regular nodes),
# OSID is the emulab OS identifier for the OS running (e.g., "FBSD410-STD"),
# OS-name is OS (e.g., "FreeBSD", "Linux"),
371
372
373
# OS-version is the version of that OS (e.g., "4.10", "9.0"),
# OS-features is a comma separated list of features supported by the OS
#  (including "linktest").
374
375
376
377
378
379
380
381
382
383
384
385
386
#
# A link info line looks like:
#
#   L node0 node1 lname node0-mac mpx-style shaping-method
#
# where node0 and node1 are the user-specified node names,
# lname is the user-specified link/lan name,
# node0-mac is the MAC address of node0's interface
# (can be mapped to interface name with findif),
# mpx-style is the multiplexing style: "none" for physical links,
# "veth" for encapsulated veth, or "veth-ne" for non-encapsulated veth,
# shaping-method is either "dnode" for delay node shaping or "linkdelay"
# for end node shaping.
387
388
389
390
391
392
393
394
395
396
#

#
# Note the regular joins here, not left joins, so that we do not
# get lines for delay nodes and virtnode hosts that are in reserved
# but not in virt_nodes.
#
my $havepmap = 0;
$query_result =
    DBQueryFatal("select v.vname,n.node_id,n.phys_nodeid,n.type,".
397
		 " o.osid,o.OS,o.version,o.osfeatures,r.erole".
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
		 " from virt_nodes as v,reserved as r,nodes as n,os_info as o".
		 " where v.pid=r.pid and v.eid=r.eid and v.vname=r.vname".
		 " and r.node_id=n.node_id and n.def_boot_osid=o.osid and".
		 " v.pid='$pid' and v.eid='$eid'");
if ($query_result->numrows) {
    $havepmap = 1;
    if ($impotent) {
	$LTPOUT = *STDERR;
    } else {
	unlink("${ltpname}.new")
	    if (-e "${ltpname}.new");
    
	open(LTPMAP, "> ${ltpname}.new") or
	    die("Could not create ${ltpname}.new: $!\n");

	$LTPOUT = *LTPMAP;
    }
415
416
417
418
    #
    # Version 2 added osfeatures field
    #
    print $LTPOUT "V 2\n";
419
420
    while (my ($vname,$node,$pnode,$ptype,$osid,$os,$osvers,$osfeatures,$role)
	   = $query_result->fetchrow_array) {
421
422
	$os = "UNKNOWN" if (!$os);
	$osvers = "0" if (!$osvers);
423
	$osfeatures = "UNKNOWN" if (!$osfeatures);
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
	#
	# Ugh. Nodes with role "virthost" can now be part of the explicit
	# topology. Nothing wrong with that except that those nodes will
	# not run linktest! To ensure that such a node does not get nominated
	# as the coordinator for a linktest run, we remove the "linktest"
	# attribute from osfeatures. This will tell the linktest script not
	# to consider the node for that honor.
	#
	# One would think that we should just pass the node's role to linktest
	# and let it decide for itself, but that would create another level
	# of backward incompatibility.
	#
	if ($role eq "virthost" && $osfeatures =~ /linktest/) {
	    $osfeatures = join(',',
			       grep($_ ne "linktest",
				    split(',', $osfeatures)));
	}
441
442
	print $LTPOUT
	    "H $vname $node $pnode $ptype $osid $os $osvers $osfeatures\n";
443
444
445
446
    }

    #
    # The MAC address is either in interfaces (for physical interfaces)
447
    # or vinterfaces (for virtual interfaces).
448
449
    #
    # The multiplexing style is either "veth" if there is a row in the
450
    # vinterfaces table or "none" otherwise.  This is reflected in
451
452
453
454
455
    # the following query as: style is "veth" if vmac!=NULL.
    #
    # Linkdelays are in use if the link has a row in the linkdelays table.
    # This is reflected in the following query as: linkdelays if iface!=NULL.
    # We could look in the delays table to further distinguish unshaped
456
457
    # links, but at the moment, we don't need that info.  We do look at the
    # virt_lans nobwshaping field to see if the link is being shaped.
458
    #
459
460
461
462
    # Argh...further complicated by the reserved table node_id being either
    # a pnode or a vnode name while vinterfaces identifies a pnode with
    # node_id if vnode_id==NULL and a vnode with vnode_id if vnode_id!=NULL.
    #
463
    $query_result =
464
	DBQueryFatal("select v.member,v.vname,i.mac,vi.mac,vi.type,l.iface,v.nobwshaping".
465
		     " from reserved as r join virt_lans as v".
466
467
468
469
470
		     " left join interfaces as i".
		     "  on v.ip=i.IP and r.node_id=i.node_id".
		     " left join linkdelays as l".
		     "  on r.pid=l.pid and r.eid=l.eid and".
		     "   v.vname=l.vlan and v.vnode=l.vnode and v.ip=l.ip".
471
472
473
474
475
		     " left join vinterfaces as vi".
		     "  on v.ip=vi.IP and".
		     "    (vi.vnode_id is NULL and r.node_id=vi.node_id".
		     "      or".
		     "    vi.vnode_id is not NULL and r.node_id=vi.vnode_id)".
476
477
478
479
		     " where".
		     "  r.pid=v.pid and r.eid=v.eid and r.vname=v.vnode and".
		     "  r.pid='$pid' and r.eid='$eid'");
    if ($query_result->numrows) {
480
	while (my ($memb,$vlan,$imac,$vmac,$vtype,$iface,$noshape) =
481
482
483
484
485
	       $query_result->fetchrow_array) {
	    if (exists($virt_lans{$vlan}->{"MEMBERS"}->{$memb})) {
		my $member = $virt_lans{$vlan}->{"MEMBERS"}->{$memb};
		if (defined($vmac)) {
		    $member->{"mac"} = $vmac;
486
487
488
489
490
		    if ($vtype eq "veth") {
			$member->{"encap"} = "veth";
		    } else {
			$member->{"encap"} = "none";
		    }
491
492
493
494
		} else {
		    $member->{"mac"} = $imac;
		    $member->{"encap"} = "none";
		}
495
496
497
498
499
500
501
502
503
504
505
506
507
508
		if ($noshape) {
		    #
		    # XXX "noshaping" means just no BW shaping,
		    # other shaping still happens.  So we identify it
		    # as such here.  We continue to distinguish linkdelays
		    # as the presence of on-node shaping has other
		    # implications for linktest.
		    #
		    if (defined($iface)) {
			$member->{"dstyle"} = "linkdelay-nobw";
		    } else {
			$member->{"dstyle"} = "dnode-nobw";
		    }
		} elsif (defined($iface)) {
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
		    $member->{"dstyle"} = "linkdelay";
		} else {
		    $member->{"dstyle"} = "dnode";
		}
	    } else {
		print $LTPOUT "E Bogus lan/member $vlan/$memb\n";
	    }
	}
    }
}

#
# Now dump the link info
#
if ($havepmap) {
    foreach my $vlan (keys(%virt_lans)) {
	my @members = @{$virt_lans{$vlan}->{"MEMBERLIST"}};
	foreach my $memb0 (@members) {
	    my $member0 = $virt_lans{$vlan}->{"MEMBERS"}->{$memb0};
	    my $node0 = $member0->{"vnode"};

	    my $mac0 = $member0->{"mac"};
	    if (!defined($mac0)) {
		print $LTPOUT "E No link info found for $vlan/$memb0\n";
		next;
	    }
	    my $encap0 = $member0->{"encap"};
	    my $dstyle0 = $member0->{"dstyle"};
	    
	    foreach my $memb1 (@members) {
		next
		    if ($memb0 eq $memb1);
		my $member1 = $virt_lans{$vlan}->{"MEMBERS"}->{$memb1};
		my $node1 = $member1->{"vnode"};

		print $LTPOUT
		    "L $node0 $node1 $vlan $mac0 $encap0 $dstyle0\n";
	    }
	}
548
549
550
551
552
    }
    close(LTPMAP)
	if (!$impotent);
}

553
554
if (! $impotent) {
    close(MAP);
Timothy Stack's avatar
   
Timothy Stack committed
555
    close(LTMAP);
556

557
    system("mv -f ${toponame}.new $toponame");
Timothy Stack's avatar
   
Timothy Stack committed
558
    system("mv -f ${ltname}.new $ltname");
559
560
    system("mv -f ${ltpname}.new $ltpname")
	if ($havepmap);
561

562
563
564
565
    #
    # Create a compressed copy of the file. The experiment nodes will look
    # for this first, so as to reduce the amount of data served up via NFS.
    #
566
    system("rm -f ${toponame}.gz ; cat $toponame | gzip > ${toponame}.gz");
Timothy Stack's avatar
   
Timothy Stack committed
567
    system("rm -f ${ltname}.gz ; cat $ltname | gzip > ${ltname}.gz");
568
569
    system("rm -f ${ltpname}.gz ; cat $ltpname | gzip > ${ltpname}.gz")
	if ($havepmap);
570
571
572
573
574
575
576
577
578
579

    #
    # Now copy over to the user exp directory since in a normal create/modify
    # files are not copied over from boss to ops until later, which is too
    # late cause the nodes have already booted, and the topomap will not be
    # where it supposed to be (or it is stale).
    #
    my $userdir = TBExptUserDir($pid, $eid);

    system("cp -fp $toponame ${toponame}.gz $userdir/tbdata");
Timothy Stack's avatar
   
Timothy Stack committed
580
    system("cp -fp $ltname ${ltname}.gz $userdir/tbdata");
581
582
    system("cp -fp $ltpname ${ltpname}.gz $userdir/tbdata")
	if ($havepmap);
583
584
}
exit(0);