libsetup.pm 35.8 KB
Newer Older
1
2
#!/usr/bin/perl -wT

Leigh B. Stoller's avatar
Leigh B. Stoller committed
3
4
#
# EMULAB-COPYRIGHT
5
# Copyright (c) 2000-2005 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
6
7
# All rights reserved.
#
8
# TODO: Signal handlers for protecting db files.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
9

10
11
12
13
14
15
16
#
# Common routines and constants for the client bootime setup stuff.
#
package libsetup;
use Exporter;
@ISA = "Exporter";
@EXPORT =
17
    qw ( libsetup_init libsetup_setvnodeid libsetup_settimeout cleanup_node 
18
19
	 getifconfig getrouterconfig gettrafgenconfig gettunnelconfig
	 check_nickname	bootsetup startcmdstatus whatsmynickname 
20
	 TBBackGround TBForkCmd vnodejailsetup plabsetup vnodeplabsetup
21
	 jailsetup dojailconfig findiface libsetup_getvnodeid 
Timothy Stack's avatar
   
Timothy Stack committed
22
	 ixpsetup libsetup_refresh gettopomap getfwconfig gettiptunnelconfig
23
	 gettraceconfig
24

25
26
	 TBDebugTimeStamp TBDebugTimeStampsOn

27
	 MFS REMOTE CONTROL WINDOWS JAILED PLAB LOCALROOTFS IXP USESFS 
28
	 SIMTRAFGEN SIMHOST ISDELAYNODEPATH JAILHOST DELAYHOST STARGATE
29

30
31
	 CONFDIR TMDELAY TMJAILNAME TMSIMRC TMCC
	 TMNICKNAME TMSTARTUPCMD FINDIF
Timothy Stack's avatar
   
Timothy Stack committed
32
	 TMROUTECONFIG TMLINKDELAY TMDELMAP TMTOPOMAP TMLTMAP
33
	 TMGATEDCONFIG TMSYNCSERVER TMKEYHASH TMNODEID TMEVENTKEY 
34
	 TMCREATOR TMSWAPPER 
35
36
37
38
39
       );

# Must come after package declaration!
use English;

40
41
42
43
44
45
46
47
48
# The tmcc library.
use libtmcc;

#
# This is the VERSION. We send it through to tmcd so it knows what version
# responses this file is expecting.
#
# BE SURE TO BUMP THIS AS INCOMPATIBILE CHANGES TO TMCD ARE MADE!
#
Timothy Stack's avatar
   
Timothy Stack committed
49
sub TMCD_VERSION()	{ 24; };
50
51
52
53
54
libtmcc::configtmcc("version", TMCD_VERSION());

# Control tmcc timeout.
sub libsetup_settimeout($) { libtmcc::configtmcc("timeout", $_[0]); };

55
# Refresh tmcc cache.
56
57
sub libsetup_refresh()	   { libtmcc::tmccgetconfig(); };

58
#
59
60
# For virtual (multiplexed nodes). If defined, tack onto tmcc command.
# and use in pathnames. Used in conjunction with jailed virtual nodes.
61
# I am also using this for subnodes; eventually everything will be subnodes.
62
#
63
my $vnodeid;
64
65
sub libsetup_setvnodeid($)
{
66
67
68
69
70
71
72
73
74
75
76
    my ($vid) = @_;

    if ($vid =~ /^([-\w]+)$/) {
	$vid = $1;
    }
    else {
	die("Bad data in vnodeid: $vid");
    }

    $vnodeid = $vid;
    libtmcc::configtmcc("subnode", $vnodeid);
77
78
79
80
81
}
sub libsetup_getvnodeid()
{
    return $vnodeid;
}
82

83
#
84
# True if running inside a jail. Set just below. 
85
86
87
# 
my $injail;

88
89
90
91
92
#
# True if running in a Plab vserver.
#
my $inplab;

93
94
95
96
97
98
#
# Ditto for IXP, although currently there is no "in" IXP setup; it
# is all done from outside.
#
my $inixp;

99
100
101
#
# The role of this pnode
#
102
my $role;
103

104
105
106
# Load up the paths. Its conditionalized to be compatabile with older images.
# Note this file has probably already been loaded by the caller.
BEGIN
107
{
108
109
110
111
112
    if (! -e "/etc/emulab/paths.pm") {
	die("Yikes! Could not require /etc/emulab/paths.pm!\n");
    }
    require "/etc/emulab/paths.pm";
    import emulabpaths;
113

114
    # Make sure these exist! They will not exist on a PLAB vserver initially.
115
116
117
118
119
120
    mkdir("$VARDIR", 0775);
    mkdir("$VARDIR/jails", 0775);
    mkdir("$VARDIR/db", 0755);
    mkdir("$VARDIR/logs", 0775);
    mkdir("$VARDIR/boot", 0775);
    mkdir("$VARDIR/lock", 0775);
121

122
123
124
125
126
    #
    # Determine if running inside a jail. This affects the paths below.
    #
    if (-e "$BOOTDIR/jailname") {
	open(VN, "$BOOTDIR/jailname");
127
	my $vid = <VN>;
128
129
	close(VN);

130
	libsetup_setvnodeid($vid);
131
132
133
	$injail = 1;
    }

134
135
136
    # Determine if running inside a Plab vserver.
    if (-e "$BOOTDIR/plabname") {
	open(VN, "$BOOTDIR/plabname");
137
	my $vid = <VN>;
138
139
	close(VN);

140
	libsetup_setvnodeid($vid);
141
142
143
	$inplab = 1;
    }

144
    $role = "";
145
146
147
148
149
    # Get our role. 
    if (-e "$BOOTDIR/role") {
	open(VN, "$BOOTDIR/role");
	$role = <VN>;
	close(VN);
150
	chomp($role);
151
    }
152
153
}

154
#
155
# This "local" library provides the OS dependent part. 
156
#
157
use liblocsetup;
158

159
160
161
162
#
# These are the paths of various files and scripts that are part of the
# setup library.
#
163
164
sub TMCC()		{ "$BINDIR/tmcc"; }
sub FINDIF()		{ "$BINDIR/findif"; }
165
sub TMUSESFS()		{ "$BOOTDIR/usesfs"; }
166
167
sub ISSIMTRAFGENPATH()	{ "$BOOTDIR/simtrafgen"; }
sub ISDELAYNODEPATH()	{ "$BOOTDIR/isdelaynode"; }
168
sub TMTOPOMAP()		{ "$BOOTDIR/topomap";}
Timothy Stack's avatar
   
Timothy Stack committed
169
sub TMLTMAP()		{ "$BOOTDIR/ltmap";}
170

171
#
172
# This path is valid only *outside* the jail when its setup.
173
# 
174
175
sub JAILDIR()		{ "$VARDIR/jails/$vnodeid"; }

176
177
178
179
180
#
# Also valid outside the jail, this is where we put local project storage.
#
sub LOCALROOTFS()	{ (REMOTE() ? "/users/local" : "$VARDIR/jails/local");}

181
182
183
#
# Okay, here is the path mess. There are three environments.
# 1. A local node where everything goes in one place ($VARDIR/boot).
184
# 2. A virtual node inside a jail or a Plab vserver ($VARDIR/boot).
185
# 3. A virtual (or sub) node, from the outside. 
186
187
188
189
190
#
# As for #3, whether setting up a old-style virtual node or a new style
# jailed node, the code that sets it up needs a different per-vnode path.
#
sub CONFDIR() {
191
    if ($injail || $inplab) {
192
193
194
195
196
197
	return $BOOTDIR;
    }
    if ($vnodeid) {
	return JAILDIR();
    }
    return $BOOTDIR;
198
}
199

200
201
202
203
204
205
206
207
#
# The rest of these depend on the environment running in (inside/outside jail).
# 
sub TMNICKNAME()	{ CONFDIR() . "/nickname";}
sub TMJAILNAME()	{ CONFDIR() . "/jailname";}
sub TMJAILCONFIG()	{ CONFDIR() . "/jailconfig";}
sub TMSTARTUPCMD()	{ CONFDIR() . "/startupcmd";}
sub TMROUTECONFIG()     { CONFDIR() . "/rc.route";}
208
sub TMGATEDCONFIG()     { CONFDIR() . "/gated.conf";}
209
210
sub TMDELAY()		{ CONFDIR() . "/rc.delay";}
sub TMLINKDELAY()	{ CONFDIR() . "/rc.linkdelay";}
211
sub TMDELMAP()		{ CONFDIR() . "/delay_mapping";}
212
sub TMSYNCSERVER()	{ CONFDIR() . "/syncserver";}
213
sub TMKEYHASH()		{ CONFDIR() . "/keyhash";}
214
sub TMEVENTKEY()	{ CONFDIR() . "/eventkey";}
215
sub TMNODEID()		{ CONFDIR() . "/nodeid";}
216
217
sub TMROLE()		{ CONFDIR() . "/role";}
sub TMSIMRC()		{ CONFDIR() . "/rc.simulator";}
218
sub TMCREATOR()		{ CONFDIR() . "/creator";}
219
sub TMSWAPPER()		{ CONFDIR() . "/swapper";}
220
221
222

#
# This is a debugging thing for my home network.
223
224
225
226
227
228
229
230
231
232
#
my $NODE = "";
if (defined($ENV{'TMCCARGS'})) {
    if ($ENV{'TMCCARGS'} =~ /^([-\w\s]*)$/) {
	$NODE .= " $1";
    }
    else {
	die("Tainted TMCCARGS from environment: $ENV{'TMCCARGS'}!\n");
    }
}
233
234

# Locals
235
236
237
my $pid		= "";
my $eid		= "";
my $vname	= "";
238
239
240
241
242
243
my $TIMESTAMPS  = 0;

# Allow override from the environment;
if (defined($ENV{'TIMESTAMPS'})) {
    $TIMESTAMPS = $ENV{'TIMESTAMPS'};
}
244
245
246
247

# When on the MFS, we do a much smaller set of stuff.
# Cause of the way the packages are loaded (which I do not understand),
# this is computed on the fly instead of once.
248
sub MFS()	{ if (-e "$ETCDIR/ismfs") { return 1; } else { return 0; } }
249

250
251
252
#
# Same for a remote node.
#
253
254
sub REMOTE()	{ if (-e "$ETCDIR/isrem") { return 1; } else { return 0; } }

255
256
257
258
259
#
# Same for a control node.
#
sub CONTROL()	{ if (-e "$ETCDIR/isctrl") { return 1; } else { return 0; } }

260
261
262
#
# Same for a Windows (CygWinXP) node.
#
263
# XXX  If you change this, look in libtmcc::tmccgetconfig() as well.
264
265
sub WINDOWS()	{ if (-e "$ETCDIR/iscygwin") { return 1; } else { return 0; } }

Kirk Webb's avatar
   
Kirk Webb committed
266
267
268
269
270
#
# Same for a stargate/garcia node.
#
sub STARGATE()  { if (-e "$ETCDIR/isstargate") { return 1; } else { return 0; } }

271
272
273
274
#
# Are we jailed? See above.
#
sub JAILED()	{ if ($injail) { return $vnodeid; } else { return 0; } }
275

276
277
278
279
280
#
# Are we on plab?
#
sub PLAB()	{ if ($inplab) { return $vnodeid; } else { return 0; } }

281
282
283
284
285
#
# Are we on an IXP
#
sub IXP()	{ if ($inixp) { return $vnodeid; } else { return 0; } }

286
#
287
# Are we hosting a simulator or maybe just a NSE based trafgen.
288
289
#
sub SIMHOST()   { if ($role eq "simhost") { return 1; } else { return 0; } }
290
sub SIMTRAFGEN(){ if (-e ISSIMTRAFGENPATH())  { return 1; } else { return 0; } }
291

292
293
294
# A jail host?
sub JAILHOST()  { if ($role eq "virthost") { return 1; } else { return 0; } }

295
296
297
# A delay host?  Either a delay node or a node using linkdelays
sub DELAYHOST()	{ if (-e ISDELAYNODEPATH()) { return 1; } else { return 0; } }

298
#
299
# Is this node using SFS. Several scripts need to know this.
300
#
301
sub USESFS()	{ if (-e TMUSESFS()) { return 1; } else { return 0; } }
302

303
304
305
#
# Reset to a moderately clean state.
#
306
307
308
sub cleanup_node ($) {
    my ($scrub) = @_;
    
309
    print STDOUT "Cleaning node; removing configuration files\n";
310
    unlink TMUSESFS, TMROLE, ISSIMTRAFGENPATH, ISDELAYNODEPATH;
311

312
    #
313
314
    # If scrubbing, also remove the password/group files and DBs so
    # that we revert to base set.
315
316
    # 
    if ($scrub) {
317
	unlink TMNICKNAME;
318
319
320
321
    }
}

#
322
323
# Check node allocation. If the nickname file has been created, use
# that to avoid load on tmcd.
324
325
326
327
328
#
# Returns 0 if node is free. Returns list (pid/eid/vname) if allocated.
#
sub check_status ()
{
329
330
331
    my @tmccresults;

    if (tmcc(TMCCCMD_STATUS, undef, \@tmccresults) < 0) {
332
333
	warn("*** WARNING: Could not get status from server!\n");
	return -1;
334
    }
335
336
337
338
339
340
341
342
343
344
    #
    # This is possible if the boss node does not now about us yet.
    # We want to appear free. Specifically, it could happen on the
    # MFS when trying to bring in brand new nodes. tmcd will not know
    # anything about us, and return no info. 
    #
    return 0
	if (! @tmccresults);

    my $status = $tmccresults[0];
345

346
    if ($status =~ /^FREE/) {
347
	unlink TMNICKNAME;
348
349
350
	return 0;
    }
    
351
    if ($status =~ /ALLOCATED=([-\@\w]*)\/([-\@\w]*) NICKNAME=([-\@\w]*)/) {
352
353
354
355
356
357
	$pid   = $1;
	$eid   = $2;
	$vname = $3;
    }
    else {
	warn "*** WARNING: Error getting reservation status\n";
358
	return -1;
359
    }
360
361
362
    
    #
    # Stick our nickname in a file in case someone wants it.
363
364
    # Do not overwrite; we want to save the original info until later.
    # See bootsetup; indicates project change!
365
    #
366
    if (! -e TMNICKNAME()) {
367
368
	system("echo '$vname.$eid.$pid' > " . TMNICKNAME());
    }
369
    
370
371
372
373
    return ($pid, $eid, $vname);
}

#
374
375
376
377
# Check cached nickname. Its okay if we have been deallocated and the info
# is stale. The node will notice that later.
# 
sub check_nickname()
378
{
379
380
381
    if (-e TMNICKNAME) {
	my $nickfile = TMNICKNAME;
	my $nickinfo = `cat $nickfile`;
382

383
384
385
386
387
388
389
390
391
	if ($nickinfo =~ /([-\@\w]*)\.([-\@\w]*)\.([-\@\w]*)/) {
	    $vname = $1;
	    $eid   = $2;
	    $pid   = $3;

	    return ($pid, $eid, $vname);
	}
    }
    return check_status();
392
393
394
}

#
395
396
# Do SFS hostid setup. If we have an SFS host key and we can get a hostid
# from the SFS daemon, then send it to TMCD.
Austin Clements's avatar
Austin Clements committed
397
#
398
sub initsfs()
Austin Clements's avatar
Austin Clements committed
399
400
401
{
    my $myhostid;

402
403
404
405
406
    # Default to no SFS unless we can determine we have it running.
    unlink TMUSESFS()
	if (-e TMUSESFS());
    
    # Do I have a host key?
Austin Clements's avatar
Austin Clements committed
407
    if (! -e "/etc/sfs/sfs_host_key") {
408
	return;
Austin Clements's avatar
Austin Clements committed
409
410
411
    }

    # Give hostid to TMCD
412
413
414
415
416
417
    if (-d "/usr/local/lib/sfs-0.6") {
	$myhostid = `sfskey hostid - 2>/dev/null`;
    }
    else {
	$myhostid = `sfskey hostid -s authserv - 2>/dev/null`;
    }
418
    if (! $?) {
Austin Clements's avatar
Austin Clements committed
419
420
421
	if ( $myhostid =~ /^([-\.\w_]*:[a-z0-9]*)$/ ) {
	    $myhostid = $1;
	    print STDOUT "  Hostid: $myhostid\n";
422
	    tmcc(TMCCCMD_SFSHOSTID, "$myhostid");
Austin Clements's avatar
Austin Clements committed
423
	}
424
425
426
	elsif ( $myhostid =~ /^(@[-\.\w_]*,[a-z0-9]*)$/ ) {
	    $myhostid = $1;
	    print STDOUT "  Hostid: $myhostid\n";
427
	    tmcc(TMCCCMD_SFSHOSTID, "$myhostid");
428
	}
Austin Clements's avatar
Austin Clements committed
429
430
	else {
	    warn "*** WARNING: Invalid hostid\n";
431
	    return;
Austin Clements's avatar
Austin Clements committed
432
	}
433
	system("touch " . TMUSESFS());
Austin Clements's avatar
Austin Clements committed
434
435
    }
    else {
436
	warn "*** WARNING: Could not retrieve this node's SFShostid!\n";
Austin Clements's avatar
Austin Clements committed
437
    }
438
439
440
441
442
443
444
445
}

#
# Get the role of the node and stash it for future libsetup load. 
# 
sub dorole()
{
    my @tmccresults;
Austin Clements's avatar
Austin Clements committed
446

447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
    if (tmcc(TMCCCMD_ROLE, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get role from server!\n");
	return -1;
    }
    return 0
	if (! @tmccresults);
    
    #
    # There should be just one string. Ignore anything else.
    #
    if ($tmccresults[0] =~ /([\w]*)/) {
	# Storing the value into the global variable
	$role = $1;
    }
    else {
	warn "*** WARNING: Bad role line: $tmccresults[0]";
	return -1;
    }
    system("echo '$role' > " . TMROLE());
    if ($?) {
	warn "*** WARNING: Could not write role to " . TMROLE() . "\n";
    }
Austin Clements's avatar
Austin Clements committed
469
470
471
    return 0;
}

472
#
473
474
475
476
# Parse the router config and return a hash. This leaves the ugly pattern
# matching stuff here, but lets the caller do whatever with it (as is the
# case for the IXP configuration stuff). This is inconsistent with many
# other config scripts, but at some point that will change. 
477
#
478
sub getifconfig($)
479
{
480
    my ($rptr)       = @_;	# Return list to caller (reference).
481
    my @tmccresults  = ();
482
    my @ifacelist    = ();	# To be returned to caller.
483
    my %ifacehash    = ();
484

485
486
    if (tmcc(TMCCCMD_IFC, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get interface config from server!\n");
487
	@$rptr = ();
488
489
	return -1;
    }
490
    
491
492
    my $ethpat  = q(INTERFACE IFACETYPE=(\w*) INET=([0-9.]*) MASK=([0-9.]*) );
    $ethpat    .= q(MAC=(\w*) SPEED=(\w*) DUPLEX=(\w*) IPALIASES="(.*)" );
493
    $ethpat    .= q(IFACE=(\w*) RTABID=(\d*) LAN=([-\w\(\)]*));
494

495
496
    my $vethpat = q(INTERFACE IFACETYPE=(\w*) INET=([0-9.]*) MASK=([0-9.]*) );
    $vethpat   .= q(ID=(\d*) VMAC=(\w*) PMAC=(\w*) RTABID=(\d*) );
497
    $vethpat   .= q(ENCAPSULATE=(\d*) LAN=([-\w\(\)]*) VTAG=(\d*));
498
499
500

    my $setpat  = q(INTERFACE_SETTING MAC=(\w*) );
    $setpat    .= q(KEY='([-\w\.\:]*)' VAL='([-\w\.\:]*)');
501

502
503
    foreach my $str (@tmccresults) {
	my $ifconfig = {};
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

	if ($str =~ /^$setpat/) {
	    my $mac     = $1;
	    my $capkey  = $2;
	    my $capval  = $3;
	    
	    #
	    # Stash the setting into the setting list, but must find the 
	    #
	    if (!exists($ifacehash{$mac})) {
		warn("*** WARNING: ".
		     "Could not map $mac for its interface settings!\n");
		next;
	    }
	    $ifacehash{$mac}->{"SETTINGS"}->{$capkey} = $capval;
	}
	elsif ($str =~ /$ethpat/) {
	    my $ifacetype= $1;
522
523
524
525
526
	    my $inet     = $2;
	    my $mask     = $3;
	    my $mac      = $4;
	    my $speed    = $5; 
	    my $duplex   = $6;
527
	    my $aliases  = $7;
528
	    my $iface    = $8;
529
	    my $rtabid   = $9;
530
	    my $lan      = $10;
531

532
533
534
535
536
	    # The server can specify an iface.
	    if ($iface eq "" &&
		(! ($iface = findiface($mac)))) {
		warn("*** WARNING: Could not map $mac to an interface!\n");
		next;
537
	    }
538
539

	    $ifconfig->{"ISVETH"}   = 0;
540
	    $ifconfig->{"TYPE"}     = $ifacetype;
541
542
543
544
545
546
547
548
	    $ifconfig->{"IPADDR"}   = $inet;
	    $ifconfig->{"IPMASK"}   = $mask;
	    $ifconfig->{"MAC"}      = $mac;
	    $ifconfig->{"SPEED"}    = $speed;
	    $ifconfig->{"DUPLEX"}   = $duplex;
	    $ifconfig->{"ALIASES"}  = $aliases;
	    $ifconfig->{"IFACE"}    = $iface;
	    $ifconfig->{"RTABID"}   = $rtabid;
549
	    $ifconfig->{"LAN"}      = $lan;
550
	    $ifconfig->{"SETTINGS"} = {};
551
	    push(@ifacelist, $ifconfig);
552
	    $ifacehash{$mac}        = $ifconfig;
553
554
	}
	elsif ($str =~ /$vethpat/) {
555
556
557
558
	    my $inet     = $2;
	    my $mask     = $3;
	    my $id       = $4;
	    my $vmac     = $5;
559
560
561
	    my $pmac     = $6;
	    my $iface    = undef;
	    my $rtabid   = $7;
562
	    my $encap    = $8;
563
	    my $lan      = $9;
564
	    my $vtag	 = $10;
565

566
567
568
569
570
571
	    #
	    # Inside a jail, the vmac is really the pmac. That is, when the
	    # veth was created, it was given vmac as its ethernet address.
	    # The pmac refers to the underlying physical interface the veth
	    # is attached to, which we do not see from inside the jail.
	    #
572
	    if (JAILED()) {
573
574
575
		if (! ($iface = findiface($vmac))) {
		    warn("*** WARNING: Could not map $vmac to a veth!\n");
		    next;
576
		}
577
578
579
580
581
582
583
584
585
586
587
588
589
	    } else {

		#
		# A veth might not have any underlying physical interface if the
		# link or lan is completely contained on the node. tmcd tells us
		# that by setting the pmac to "none". Note that this obviously is
		# relevant on the physnode, not when called from inside a vnode.
		#
		if ($pmac ne "none") {
		    if (! ($iface = findiface($pmac))) {
			warn("*** WARNING: Could not map $pmac to an iface!\n");
			next;
		    }
590
		}
591
	    }
592

593
594
595
596
597
	    $ifconfig->{"ISVETH"}   = 1;
	    $ifconfig->{"IPADDR"}   = $inet;
	    $ifconfig->{"IPMASK"}   = $mask;
	    $ifconfig->{"ID"}       = $id;
	    $ifconfig->{"VMAC"}     = $vmac;
598
	    $ifconfig->{"MAC"}      = $vmac; # XXX
599
600
601
602
	    $ifconfig->{"PMAC"}     = $pmac;
	    $ifconfig->{"IFACE"}    = $iface;
	    $ifconfig->{"RTABID"}   = $rtabid;
	    $ifconfig->{"ENCAP"}    = $encap;
603
	    $ifconfig->{"LAN"}      = $lan;
604
	    $ifconfig->{"VTAG"}     = $vtag;
605
	    push(@ifacelist, $ifconfig);
606
607
	}
	else {
608
	    warn "*** WARNING: Bad ifconfig line: $str\n";
609
610
	}
    }
611
612
  
    @$rptr = @ifacelist;
613
614
615
    return 0;
}

616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
#
# Read the topomap and return something.
#
sub gettopomap($)
{
    my ($rptr)       = @_;	# Return array to caller (reference).
    my $topomap	     = {};
    my $section;
    my @slots;

    if (! -e TMTOPOMAP()) {
	$rptr = {};
	return -1;
    }

    if (!open(TOPO, TMTOPOMAP())) {
	warn("*** WARNING: ".
	     "gettopomap: Could not open " . TMTOPOMAP() . "!\n");
	@$rptr = ();
	return -1;
    }

    #
    # First line of topo map describes the nodes.
    #
    while (<TOPO>) {
	if ($_ =~ /^\#\s*([-\w]*): ([-\w,]*)$/) {
	    $section = $1;
	    @slots = split(",", $2);

	    $topomap->{$section} = [];
	    next;
	}
	chomp($_);
	my @values = split(",", $_);
	my $rowref = {};
    
653
654
	for (my $i = 0; $i < scalar(@slots); $i++) {
	    $rowref->{$slots[$i]} = (defined($values[$i]) ? $values[$i] : undef);
655
656
657
658
659
660
661
662
	}
	push(@{ $topomap->{$section} }, $rowref);
    }
    close(TOPO);
    $$rptr = $topomap;
    return 0;
}

663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
#
# Convert from MAC to iface name (eth0/fxp0/etc) using little helper program.
# 
sub findiface($)
{
    my($mac) = @_;
    my($iface);

    open(FIF, FINDIF . " $mac |")
	or die "Cannot start " . FINDIF . ": $!";

    $iface = <FIF>;
    
    if (! close(FIF)) {
	return 0;
    }
    
    $iface =~ s/\n//g;
    return $iface;
}

684
#
685
686
687
688
# Return the router configuration. We parse tmcd output here and return
# a list of hash entries to the caller.
#
sub getrouterconfig($$)
689
{
690
691
692
693
    my ($rptr, $ptype) = @_;		# Return list and type to caller.
    my @tmccresults = ();
    my @routes      = ();
    my $type;
694

695
696
697
698
    if (tmcc(TMCCCMD_ROUTING, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get routes from server!\n");
	@$rptr  = ();
	$$ptype = undef;
699
700
701
702
	return -1;
    }

    #
703
    # Scan for router type. If "none" we are done.
704
    #
705
706
707
708
709
    foreach my $line (@tmccresults) {
	if ($line =~ /ROUTERTYPE=(.+)/) {
	    $type = $1;
	    last;
	}
710
    }
711
712
713
714
    if (!defined($type) || $type eq "none") {
	@$rptr  = ();
	$$ptype = "none";
	return 0;
715
    }
716

717
718
719
720
    #
    # ROUTERTYPE=manual
    # ROUTE DEST=192.168.2.3 DESTTYPE=host DESTMASK=255.255.255.0 \
    #	NEXTHOP=192.168.1.3 COST=0 SRC=192.168.4.5
721
    #
722
723
    # The SRC ip is used to determine which interface the routes are
    # associated with, since nexthop alone is not enough cause of the 
724
    #
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
    my $pat = q(ROUTE DEST=([0-9\.]*) DESTTYPE=(\w*) DESTMASK=([0-9\.]*) );
    $pat   .= q(NEXTHOP=([0-9\.]*) COST=([0-9]*) SRC=([0-9\.]*));

    foreach my $line (@tmccresults) {
	if ($line =~ /ROUTERTYPE=(.+)/) {
	    next;
	}
	elsif ($line =~ /$pat/) {
	    my $dip   = $1;
	    my $rtype = $2;
	    my $dmask = $3;
	    my $gate  = $4;
	    my $cost  = $5;
	    my $sip   = $6;

	    #
	    # For IXP.
	    #
	    my $rconfig = {};
		    
	    $rconfig->{"IPADDR"}   = $dip;
	    $rconfig->{"TYPE"}     = $rtype;
	    $rconfig->{"IPMASK"}   = $dmask;
	    $rconfig->{"GATEWAY"}  = $gate;
	    $rconfig->{"COST"}     = $cost;
	    $rconfig->{"SRCIPADDR"}= $sip;
	    push(@routes, $rconfig);
	}
	else {
	    warn("*** WARNING: Bad route config line: $line\n");
	}
756
    }
757
758
    @$rptr  = @routes;
    $$ptype = $type;
759
760
761
    return 0;
}

762
#
763
764
765
# Get trafgen configuration.
#
sub gettrafgenconfig($)
766
{
767
768
    my ($rptr)   = @_;
    my @trafgens = ();
769

770
771
    if (tmcc(TMCCCMD_TRAFFIC, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get trafgen config from server!\n");
772
	return -1;
773
    }
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796

    my $pat  = q(TRAFGEN=([-\w.]+) MYNAME=([-\w.]+) MYPORT=(\d+) );
    $pat    .= q(PEERNAME=([-\w.]+) PEERPORT=(\d+) );
    $pat    .= q(PROTO=(\w+) ROLE=(\w+) GENERATOR=(\w+));

    foreach my $str (@tmccresults) {
	if ($str =~ /$pat/) {
	    my $trafgen = {};
	    
	    $trafgen->{"NAME"}       = $1;
	    $trafgen->{"SRCHOST"}    = $2;
	    $trafgen->{"SRCPORT"}    = $3;
	    $trafgen->{"PEERHOST"}   = $4;
	    $trafgen->{"PEERPORT"}   = $5;
	    $trafgen->{"PROTO"}      = $6;
	    $trafgen->{"ROLE"}       = $7;
	    $trafgen->{"GENERATOR"}  = $8;
	    push(@trafgens, $trafgen);

	    #
	    # Flag node as doing NSE trafgens for other scripts.
	    #
	    if ($trafgen->{"GENERATOR"} eq "NSE") {
797
		system("touch " . ISSIMTRAFGENPATH);
798
799
800
801
802
803
		next;
	    }
	}
	else {
	    warn("*** WARNING: Bad traffic line: $str\n");
	}
804
    }
805
    @$rptr = @trafgens;
806
807
808
    return 0;
}

809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
#
# Get trace configuration.
#
sub gettraceconfig($)
{
    my ($rptr)    = @_;
    my @traceinfo = ();

    if (tmcc(TMCCCMD_TRACEINFO, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get trace config from server!\n");
	return -1;
    }
    
    my $pat = q(TRACE LINKNAME=([-\d\w]+) IDX=(\d*) MAC0=(\w*) MAC1=(\w*) );
    $pat   .= q(VNODE=([-\d\w]+) VNODE_MAC=(\w*) );
    $pat   .= q(TRACE_TYPE=([-\d\w]+) );
    $pat   .= q(TRACE_EXPR='(.*)' );
    $pat   .= q(TRACE_SNAPLEN=(\d*));

    foreach my $str (@tmccresults) {
	if ($str =~ /$pat/) {
	    my $trace = {};
	    
	    $trace->{"LINKNAME"}      = $1;
	    $trace->{"IDX"}           = $2;
	    $trace->{"MAC0"}          = $3;
	    $trace->{"MAC1"}          = $4;
	    $trace->{"VNODE"}         = $5;
	    $trace->{"VNODE_MAC"}     = $6;
	    $trace->{"TRACE_TYPE"}    = $7;
	    $trace->{"TRACE_EXPR"}    = $8;
	    $trace->{"TRACE_SNAPLEN"} = $9;
	    push(@traceinfo, $trace);
	}
	else {
	    warn("*** WARNING: Bad traceinfo line: $str\n");
	}
    }
    @$rptr = @traceinfo;
    return 0;
}

851
#
852
853
854
# Get tunnels configuration.
#
sub gettunnelconfig($)
855
{
856
857
    my ($rptr)   = @_;
    my @tunnels = ();
858

859
860
    if (tmcc(TMCCCMD_TUNNEL, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get tunnel config from server!\n");
861
	return -1;
862
863
    }

864
865
866
867
    my $pat  = q(TUNNEL=([-\w.]+) ISSERVER=(\d) PEERIP=([-\w.]+) );
    $pat    .= q(PEERPORT=(\d+) PASSWORD=([-\w.]+) );
    $pat    .= q(ENCRYPT=(\d) COMPRESS=(\d) INET=([-\w.]+) );
    $pat    .= q(MASK=([-\w.]+) PROTO=([-\w.]+));
868

869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
    foreach my $str (@tmccresults) {
	if ($str =~ /$pat/) {
	    my $tunnel = {};

	    #
	    # The following is rather specific to vtund!
	    #
	    $tunnel->{"NAME"}       = $1;
	    $tunnel->{"ISSERVER"}   = $2;
	    $tunnel->{"PEERIPADDR"} = $3;
	    $tunnel->{"PEERPORT"}   = $4;
	    $tunnel->{"PASSWORD"}   = $5;
	    $tunnel->{"ENCRYPT"}    = $6;
	    $tunnel->{"COMPRESS"}   = $7;
	    $tunnel->{"IPADDR"}     = $9;
	    $tunnel->{"IPMASK"}     = $10;
	    $tunnel->{"PROTO"}      = $11;
	    push(@tunnels, $tunnel);
	}
	else {
	    warn("*** WARNING: Bad tunnels line: $str\n");
	}
    }
    @$rptr = @tunnels;
893
894
895
    return 0;
}

Timothy Stack's avatar
   
Timothy Stack committed
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
#
# Get tiptunnels configuration.
#
sub gettiptunnelconfig($)
{
    my ($rptr)   = @_;
    my @tiptunnels = ();

    if (tmcc(TMCCCMD_TIPTUNNELS, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get tiptunnel config from server!\n");
	return -1;
    }

    my $pat  = q(VNODE=([-\w.]+) SERVER=([-\w.]+) PORT=(\d+) );
    $pat    .= q(KEYLEN=(\d+) KEY=([-\w.]+));

    my $ACLDIR = "/var/log/tiplogs";

    mkdir("$ACLDIR", 0755);
    foreach my $str (@tmccresults) {
	if ($str =~ /$pat/) {
	    if (!open(ACL, "> $ACLDIR/$1.acl")) {
		warn("*** WARNING: ".
		     "gettiptunnelconfig: Could not open $ACLDIR/$1.acl\n");
		return -1;
	    }

	    print ACL "host: $2\n";
	    print ACL "port: $3\n";
	    print ACL "keylen: $4\n";
	    print ACL "key: $5\n";
	    close(ACL);

	    push(@tiptunnels, $1);
	}
	else {
	    warn("*** WARNING: Bad tiptunnels line: $str\n");
	}
    }
    @$rptr = @tiptunnels;
    return 0;
}

939
940
941
942
943
944
945
946
947
948
949
my %fwvars = ();

#
# Substitute values of variables in a firewall rule.
#
sub expandfwvars($)
{
    my ($rule) = @_;

    if ($rule->{RULE} =~ /EMULAB_\w+/) {
	foreach my $key (keys %fwvars) {
950
	    $rule->{RULE} =~ s/$key/$fwvars{$key}/g
951
952
953
954
955
956
957
958
959
960
961
		if (defined($fwvars{$key}));
	}
	if ($rule->{RULE} =~ /EMULAB_\w+/) {
	    warn("*** WARNING: Unexpanded firewall variable in: \n".
		 "    $rule->{RULE}\n");
	    return 1;
	}
    }
    return 0;
}

962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
#
# Return the firewall configuration. We parse tmcd output here and return
# a list of hash entries to the caller.
#
sub getfwconfig($$)
{
    my ($infoptr, $rptr) = @_;		# Return info and rule list to caller.
    my @tmccresults = ();
    my $fwinfo      = {};
    my @fwrules     = ();

    $$infoptr = undef;
    @$rptr = ();
    if (tmcc(TMCCCMD_FIREWALLINFO, undef, \@tmccresults) < 0) {
	warn("*** WARNING: Could not get firewall info from server!\n");
	return -1;
    }

    my $rempat = q(TYPE=remote FWIP=([0-9\.]*));
981
    my $fwpat  = q(TYPE=([\w-]+) STYLE=(\w+) IN_IF=(\w*) OUT_IF=(\w*) IN_VLAN=(\d+) OUT_VLAN=(\d+));
982
    my $rpat   = q(RULENO=(\d*) RULE="(.*)");
983
    my $vpat   = q(VAR=(EMULAB_\w+) VALUE="(.*)");
984

985
    $fwinfo->{"TYPE"} = "none";
986
    foreach my $line (@tmccresults) {
987
	if ($line =~ /TYPE=([\w-]+)/) {
988
989
990
991
992
993
994
995
996
997
998
999
1000
	    my $type = $1;
	    if ($type eq "none") {
		$fwinfo->{"TYPE"} = $type;
		$$infoptr = $fwinfo;
		return 0;
	    }
	    if ($line =~ /$rempat/) {
		my $fwip = $1;

		$fwinfo->{"TYPE"} = "remote"
		    if (!defined($fwinfo->{"TYPE"}));
		$fwinfo->{"FWIP"} = $fwip;
	    } elsif ($line =~ /$fwpat/) {
For faster browsing, not all history is shown. View entire blame