GeniEmulabUtil.pm.in 13.1 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1 2
#!/usr/bin/perl -w
#
3
# Copyright (c) 2008-2011 University of Utah and the Flux Group.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
# 
# {{{GENIPUBLIC-LICENSE
# 
# GENI Public License
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and/or hardware specification (the "Work") to
# deal in the Work without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Work, and to permit persons to whom the Work
# is furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Work.
# 
# THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE WORK OR THE USE OR OTHER DEALINGS
# IN THE WORK.
# 
# }}}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29
#
Leigh B Stoller's avatar
Leigh B Stoller committed
30
package GeniEmulabUtil;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48

#
# Stuff to interface between Emulab core and Geni nodes.
#
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA    = "Exporter";
@EXPORT = qw ( );

# Must come after package declaration!
use GeniDB;
use Genixmlrpc;
use GeniResponse;
use GeniTicket;
use GeniCredential;
use GeniCertificate;
49 50 51
use GeniComponent;
use GeniAuthority;
use GeniRegistry;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
52 53 54
use GeniSlice;
use GeniSliver;
use GeniUser;
55
use GeniHRN;
56
use GeniXML;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
57 58 59 60
use libtestbed;
use User;
use Node;
use Interface;
61
use Lan;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
62
use English;
63
use XML::Simple;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
64 65
use Data::Dumper;
use Experiment;
66
use libdb qw(TBDB_IFACEROLE_CONTROL TBDB_IFACEROLE_EXPERIMENT);
67 68
use POSIX qw(strftime);
use Carp;
69
use Socket;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70 71 72 73 74 75 76 77

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
78
my $SACERT         = "$TB/etc/genisa.pem";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
79 80

#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
81
# Initialize for using geni resources.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
82
#
83
sub RegisterExperiment($$)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
84
{
85 86 87
    my ($experiment, $user) = @_;

    my $slice = GeniSlice->LookupByExperiment($experiment);
88 89 90 91 92 93 94 95 96 97 98 99 100

    #
    # If we have a slice for it, check to see if its expired. We just
    # go ahead and renew it.
    #
    if (defined($slice)) {
	if ($slice->IsExpired() &&
	    $slice->SetExpiration(time() + (24 * 3600 * 30))) {
	    print STDERR "Could not reset slice expiration\n";
	    return -1;
	}
	return 0;
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
101

Leigh B. Stoller's avatar
Leigh B. Stoller committed
102
    #
103
    # Load the SA cert to act as caller context.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
104
    #
105 106 107 108 109 110 111 112 113
    my $certificate = GeniCertificate->LoadFromFile($SACERT);
    if (!defined($certificate)) {
	print STDERR "Could not load certificate from $SACERT\n";
	return -1;
    }
    my $context = Genixmlrpc->Context($certificate);
    if (!defined($context)) {
	print STDERR "Could not create context to talk to clearinghouse\n";
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
114
    #
115
    # Set the default RPC context. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
116
    #
117
    Genixmlrpc->SetContext($context);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
118

Leigh B. Stoller's avatar
Leigh B. Stoller committed
119
    #
120
    # Create a Geni user from the supplied Emulab user.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
121
    #
122
    my $geniuser = GeniUser->CreateFromLocal($user);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
123
    if (!defined($geniuser)) {
124
	print STDERR "Could not create a geni user from current user $user\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
125 126 127
	return -1;
    }
    # Register user at the ClearingHouse.
128
    print STDERR "Registering $geniuser at the ClearingHouse.\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
129 130 131 132 133 134
    if ($geniuser->Register() != 0) {
	print STDERR "Could not register $geniuser at the ClearingHouse.\n";
	return -1;
    }

    #
135
    # Create and register the slice. Slice is returned locked
Leigh B. Stoller's avatar
Leigh B. Stoller committed
136
    #
137
    print STDERR "Creating new slice for $experiment\n";
138
    $slice = GeniSlice->CreateFromLocal($experiment, $geniuser);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
139
    if (!defined($slice)) {
140 141 142
	print STDERR "Could not create local slice from $experiment\n";
	return -1;
    }
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
    #
    # We want this slice to have a long expiration and let Emulab
    # deal with aging it out.
    #
    my $expires = time() + (3600 * 24 * 90);
    if ($slice->SetExpiration($expires)) {
	print STDERR "Could not set expiration for $slice\n";

	if ($slice->UnRegister() != 0) {
	    print STDERR "Could not unregister $slice for $experiment\n";
	    return -1;
	}
	$slice->Delete();
	return -1;
    }
158 159 160
    print STDERR "Registering $slice at the ClearingHouse.\n";
    if ($slice->Register() != 0) {
	$slice->Delete();
161
	print STDERR "Could not register slice $slice\n";
162
	return -1;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
163
    }
164
    $slice->UnLock();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
165 166 167 168
    return 0;
}

#
169
# Delete the slice record from the ClearingHouse and then locally.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
170
#
171
sub UnRegisterExperiment($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
172
{
173
    my ($experiment) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
174 175

    my $slice = GeniSlice->LookupByExperiment($experiment);
176 177
    return 0
	if (!defined($slice));
178 179

    #
180
    # Load the SA cert to act as caller context.
181
    #
182 183 184
    my $certificate = GeniCertificate->LoadFromFile($SACERT);
    if (!defined($certificate)) {
	print STDERR "Could not load certificate from $SACERT\n";
185 186
	return -1;
    }
187 188 189
    my $context = Genixmlrpc->Context($certificate);
    if (!defined($context)) {
	print STDERR "Could not create context to talk to clearinghouse\n";
190
	return -1;
191 192
    }
    #
193
    # Set the default RPC context. 
194
    #
195
    Genixmlrpc->SetContext($context);
196

197 198 199 200 201 202 203
    #
    # Its possible the sa_daemon has the slice locked.
    #
    if ($slice->Lock() != 0) {
	print STDERR "Could not lock slice\n";
	return -1;
    }
204 205 206 207
    print STDERR "Unregistering $slice at the ClearingHouse.\n";
    if ($slice->UnRegister() != 0) {
	print STDERR "Could not unregister $slice for $experiment\n";
	return -1;
208
    }
209
    # Needs to move.
210
    GeniSlice::ClientSliver->SliceDelete($slice);
211
    
212 213 214
    if ($slice->Delete()) {
	print STDERR "Could not delete $slice for $experiment\n";
	return -1;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
215 216 217 218 219
    }
    return 0;
}

#
220
# Create a physical node on the fly. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
221
#
222
sub CreatePhysNode($$)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
223
{
224
    my ($manager_urn, $node_urn) = @_;
225 226
    my @ifaces;
    my $ctrliface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
227

228 229 230 231
    if (!defined($node_urn) || ! GeniHRN::IsValid($node_urn)) {
	carp("Not a proper node urn: $node_urn\n");
	return -1;
    }
232 233 234 235 236
    if (!defined($manager_urn) || ! GeniHRN::IsValid($manager_urn)) {
	carp("Not a proper manager urn: $manager_urn\n");
	return -1;
    }
    print STDERR "$node_urn, $manager_urn\n";
237

238
    my ($auth,$type,$node_id) = GeniHRN::Parse($node_urn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
239 240

    #
241
    # Load the SA cert to act as caller context.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
242
    #
243 244 245 246
    my $certificate = GeniCertificate->LoadFromFile($SACERT);
    if (!defined($certificate)) {
	print STDERR "Could not load certificate from $SACERT\n";
	return undef;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
247
    }
248 249 250
    my $context = Genixmlrpc->Context($certificate);
    if (!defined($context)) {
	print STDERR "Could not create context to talk to clearinghouse\n";
251
	return undef;
252
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
253
    #
254
    # Set the default RPC context. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
255
    #
256
    Genixmlrpc->SetContext($context);
257

258
    my $authority = GeniAuthority->CreateFromRegistry("CM", $manager_urn);
259
    if (!defined($authority)) {
260 261
	print STDERR "Could not lookup $manager_urn at ClearingHouse\n";
	return undef;
262
    }
263 264 265
    my $manager_version = $authority->Version();
    return undef
	if (!defined($manager_version));
266

267 268
    my $component = GeniComponent->CreateFromRegistry($node_urn);
    if (!defined($component)) {
269
	print STDERR "Could not lookup $node_urn at its registry\n";
270
	return undef;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
271
    }
272
    my $node = Node->LookupWideArea($node_urn);
273 274
    return $node
	if (defined($node));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
275

Leigh B. Stoller's avatar
Leigh B. Stoller committed
276 277
    print STDERR "Creating local node for $node_urn\n";

278 279 280
    my $blob     = $component->Resolve();
    return undef
	if (!defined($blob));
281 282 283

    my $IP       = $blob->{'physctrl'};
    my $hostname = $blob->{'hostname'};
284
    if (! defined($hostname)) {
285
	print STDERR "Missing stuff in blob from CM for $node_urn\n";
286
	goto bad;
287 288 289 290
    }
    if (! ($hostname =~ /^[-\w\.]*$/)) {
	print STDERR
	    "Invalid hostname '$hostname' in blob from CM for $node_urn\n";
291
	goto bad;
292
    }
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
    if ($authority->IsSFA()) {
	#
	# Generate a suitable node_id.
	#
	my $site = $blob->{'site'};
	if (! defined($site)) {
	    print STDERR "Missing site in blob from CM for $node_urn\n";
	    goto bad;
	}
	if (! ($site =~ /^[-\w\.]*$/)) {
	    print STDERR "Invalid site '$site' in blob from CM for $node_urn\n";
	    goto bad;
	}
	my @tmp  = split(/\./, $hostname);
	$node_id = $site . "-" . $tmp[0];
    }
    else {
	my $hrn = $blob->{'hrn'};
	if (! defined($hrn)) {
	    print STDERR "Missing hrn in blob from CM for $node_urn\n";
	    goto bad;
	}
	if (! ($hrn =~ /^[-\w\.]*$/)) {
	    print STDERR "Invalid hrn '$hrn' in blob from CM for $node_urn\n";
	    goto bad;
	}
	$node_id = $hrn;
    }
321 322 323
    $node_id =~ s/\./\-/g;
    if (length($node_id) > 32) {
	print STDERR "Nodeid '$node_id' too long for $node_urn\n";
324
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
325 326 327
    }

    #
328
    # Find control network.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
329
    #
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351
    if ($authority->IsSFA()) {
	#
	# Find the IP from the hostname and generate a stub iface entry.
	#
	my ($name,undef,undef,undef,@ipaddrs) = gethostbyname($hostname);
	if (!defined($name)) {
	    print STDERR "Cannot resolve $hostname for $node_urn:\n";
	    goto bad;
	}
	$IP = inet_ntoa($ipaddrs[0]);

	my $ifaceargs = {
	    "card"      => 0,
	    "role"      => TBDB_IFACEROLE_CONTROL(),
	    "MAC"       => '000000000000',
	    "IP"        => $IP,
	    "type"      => "generic",
	};
	push(@ifaces, $ifaceargs);
	$ctrliface = $ifaceargs;
    }
    elsif (exists($blob->{'interfaces'})) {
352
	foreach my $ref (@{ $blob->{'interfaces'} }) {
353 354 355 356 357 358 359 360 361 362 363 364 365 366 367
	    my $role = $ref->{'role'};
	    
	    if ($role eq "ctrl" || $role eq "control") {
		$IP = $ref->{'IP'};

		#
		# This turns out to be a problem; if the node is actually
		# on the local cluster (we treat all protogeni nodes same),
		# we end up with two nodes in the interfaces table with the
		# same IP; not allowed since stuff breaks (bootinfo, tmcd).
		#
		next;
	    }
	    if ($role eq TBDB_IFACEROLE_CONTROL() ||
		$role eq TBDB_IFACEROLE_EXPERIMENT()) {
368 369 370
		my $MAC = $ref->{'MAC'};
		if (!defined($MAC) || !($MAC =~ /^[:\w]*$/)) {
		    print STDERR "Bad mac in blob for $node_urn:\n";
371 372 373 374 375 376 377 378 379 380 381
		    goto bad;
		}
		my $IIP = $ref->{'IP'};
		if (!defined($IIP) || !($IIP =~ /^[-\w\.]*$/)) {
		    print STDERR "Bad IP in blob for $node_urn:\n";
		    goto bad;
		}
		my ($card) = ($ref->{'iface'} =~ /^\D*(\d*)$/);
		if (!defined($card)) {
		    print STDERR "Bad iface in blob for $node_urn:\n";
		    goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
382
		}
383 384 385 386
		
		my $ifaceargs = {
		    "card"      => $card,
		    "role"      => $ref->{'role'},
387
		    "MAC"       => $MAC,
388
		    "IP"        => $IIP,
389
		    "type"      => "generic",
390
		};
391 392 393 394
		push(@ifaces, $ifaceargs);

		$ctrliface = $ifaceargs
		    if ($ref->{'role'} eq TBDB_IFACEROLE_CONTROL());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
395 396
	    }
	}
397 398
    }
    elsif (exists($blob->{'rspec'})) {
399 400 401 402
	my $rspec = GeniXML::Parse($blob->{'rspec'});
	if (!defined($rspec)) {
	    goto bad;
	}
403
	foreach my $noderef (GeniXML::FindNodes("n:node",
404
						$rspec)->get_nodelist()) {
405
	    next
406
		if (GeniXML::GetNodeId($noderef) ne $node_urn);
407
	    next
408
		if (! defined(GeniXML::FindFirst("n:interface", $noderef)));
409 410 411

	    my $count = 0;
	    
412
	    foreach my $ref (GeniXML::FindNodes("n:interface",
413
						$noderef)->get_nodelist()) {
414 415
		my $component_id = GeniXML::GetText("component_id", $ref);
		my $role = GeniXML::GetText("role", $ref);
416 417 418 419 420 421
		if (!defined($role) ||
		    $role eq "experimental" || $role eq "expt") {
		    $role = TBDB_IFACEROLE_EXPERIMENT();
		}
		elsif ($role eq "ctrl" || $role eq "control") {
		    $role = TBDB_IFACEROLE_CONTROL();
422 423 424 425 426 427 428 429 430 431 432

		    my $ipv4 = GeniXML::GetText("public_ipv4", $ref);
		    $IP = $ipv4;

		    #
		    # This turns out to be a problem; if the node is actually
		    # on the local cluster (we treat all protogeni nodes same),
		    # we end up with two nodes in the interfaces table with the
		    # same IP; not allowed since stuff breaks (bootinfo, tmcd).
		    #
		    next;
433 434 435 436
		}
		else {
		    print STDERR "Unknown role $role for $node_urn!\n";
		    goto bad;
437
		}
438 439 440 441 442 443 444 445 446 447
		my $MAC  = "00000000000" . $count;

		my ($auth,$id,$iface) = GeniHRN::ParseInterface($component_id);

		my $ifaceargs = {
		    "card"      => $count,
		    "iface"     => $iface,
		    "role"      => $role,
		    "MAC"       => $MAC,
		    "IP"        => '',
448
		    "type"      => "generic",
449 450 451
		};
		push(@ifaces, $ifaceargs);

452 453
		if ($role eq TBDB_IFACEROLE_CONTROL()) {
		    my $ipv4 = GeniXML::GetText("public_ipv4", $ref);
454
		    $ctrliface = $ifaceargs;
455
		    $ifaceargs->{'IP'}   = $ipv4;
456 457
		}
		$count++;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
458
		#print Dumper($ifaceargs);
459
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
460 461
	}
    }
462 463 464 465
    if (! @ifaces) {
	print STDERR "No interfaces in blob for $node_urn!\n";
	goto bad;
    }
466
    if (!defined($IP)) {
467 468 469
	print STDERR "No control interface in blob for $node_urn!\n";
	goto bad;
    }		   
470 471 472 473
    if (! ($IP =~ /^[-\w\.]*$/)) {
	print STDERR "Invalid IP '$IP' in blob from CM for $node_urn\n";
	goto bad;
    }
474 475 476 477 478 479 480 481
    my $newnode = Node->Create($node_id, undef,
			       {"role"      => "testnode",
				"type"      => "pcfedphys",
				"hostname"  => $hostname,
				"external_node_id" => $node_urn,
				"IP"        => $IP});
    if (!defined($newnode)) {
	print STDERR "Could not create new node from blob for $node_urn\n";
482
	goto bad;
483
    }
484 485 486 487 488 489 490 491 492
    foreach my $ifaceargs (@ifaces) {
	my $interface = Interface->Create($newnode, $ifaceargs);
	if (!defined($interface)) {
	    $newnode->Delete();
	    print STDERR
		"Could not create interface from blob for $node_urn\n";
	    print STDERR Dumper($ifaceargs);
	    goto bad;
	}
493
    }
494
    return $newnode;
495 496 497
  bad:
    print STDERR Dumper($blob);
    return undef;
498 499
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
500 501 502
# _Always_ make sure that this 1 is at the end of the file...
1;