Add support for stitching Emulab as a transit network.

db/Lan.pm.in

@@ -3956,7 +3956,7 @@ sub VlanTagOkay($$)
 {
     my ($self, $tag) = @_;
 
-    return ($tag >= $self->min_vlan() && $tag < $self->max_vlan() ? 1 : 0);
+    return ($tag >= $self->min_vlan() && $tag <= $self->max_vlan() ? 1 : 0);
 }
 
 # _Always_ make sure that this 1 is at the end of the file...

protogeni/lib/GNUmakefile.in

@@ -41,7 +41,7 @@ LIB_SCRIPTS     = GeniDB.pm GeniUser.pm  \
 		  GeniAuthority.pm GeniCertificate.pm GeniAggregate.pm \
 		  GeniUtil.pm GeniRegistry.pm GeniUsage.pm GeniHRN.pm \
 		  GeniSES.pm GeniResource.pm GeniXML.pm GeniAM.pm \
-		  GeniEmulab.pm GeniFoam.pm
+		  GeniEmulab.pm GeniFoam.pm GeniStitch.pm
 SBIN_SCRIPTS	= plabnodewrapper plabslicewrapper
 
 SCRIPTS		= genischemacheck.pl

protogeni/lib/GeniCMV2.pm.in

@@ -54,6 +54,7 @@ use GeniUtil;
 use GeniCM;
 use GeniHRN;
 use GeniXML;
+use GeniStitch;
 use emutil;
 use English;
 use Data::Dumper;
@@ -1964,39 +1965,14 @@ sub ReserveVlanTags($)
 	goto done;
     }
 
-    #
-    # Need to dig inside the stitching section to find the path.
-    #
-    my $stitching_path;
-    
-    foreach my $ref (GeniXML::FindNodesNS("n:stitching",
-					  $rspec,
-					  $GeniXML::STITCH_NS)->get_nodelist()){
-	foreach my $path (GeniXML::FindNodes("n:path",
-					     $ref)->get_nodelist()) {
-	    my $path_id = GeniXML::GetText("id", $path);
-
-	    if ($path_id eq $linkname) {
-		$stitching_path = $path;
-		last;
-	    }
-	}
-    }
-    if (!defined($stitching_path)) {
-	$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
-					 "Could not find path in rspec");
+    my $stitchpath = GeniStitch->Lookup($linkname, $rspec);
+    if (defined($stitchpath->error())) {
+	$response = $stitchpath->error();
 	goto done;
     }
-	    
-    #
-    # Look at the hop list to find the edge point.
-    #
-    my @hoplist = GeniXML::FindNodes("n:hop", $stitching_path)->get_nodelist();
-    my (undef, $network, undef, $edgeresponse)
-	= GeniCM::findStitchPoint($linkname, @hoplist);
-    if (defined($edgeresponse)) {
-	$response = $edgeresponse;
-	goto done;
+    if (!defined($stitchpath)) {
+	$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
+					 "Could not find stitchpath in rspec");
     }
 
     #
@@ -2056,15 +2032,15 @@ sub ReserveVlanTags($)
 	my @tags = ();
 	foreach my $tag (@{ $taglist }) {
 	    push(@tags, $tag)
-		if ($network->VlanTagOkay($tag));
+		if ($stitchpath->vlan_ok($tag));
 	}
 	if (!@tags) {
 	    #
 	    # Return a list of okay tags. 
 	    #
 	    my @okaytags = ();
-	    for (my $i = $network->min_vlan();
-		 $i < $network->max_vlan(); $i++) {
+	    for (my $i = $stitchpath->min_vlan();
+		 $i < $stitchpath->max_vlan(); $i++) {
 		push(@okaytags, $i);
 	    }
 	    $response = GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,

protogeni/lib/GeniStitch.pm.in

+#!/usr/bin/perl -wT
+#
+# Copyright (c) 2013 University of Utah and the Flux Group.
+# 
+# {{{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.
+# 
+# }}}
+#
+package GeniStitch;
+
+use strict;
+use Exporter;
+use vars qw(@ISA);
+@ISA = "Exporter";
+
+# Must come after package declaration!
+use GeniDB;
+use English;
+use libEmulab;
+use GeniResponse;
+use overload ('""' => 'Stringify');
+our $TB             = "@prefix@";
+our $OURDOMAIN      = "@OURDOMAIN@";
+our %stitchpoints = ();
+
+
+sub Lookup($$$)
+{
+    my ($class, $linkname, $rspec) = @_;
+    my $result;
+    if (! exists($stitchpoints{$linkname})) {
+	LookupAll($class, $rspec);
+    }
+    if (exists($stitchpoints{$linkname})) {
+	$result = $stitchpoints{$linkname};
+    }
+    return $result;
+}
+
+sub LookupAll($$)
+{
+    my ($class, $rspec) = @_;
+    my @hops = GeniXML::FindNodesNS("n:stitching", $rspec,
+				    $GeniXML::STITCH_NS)->get_nodelist();
+    foreach my $ref (@hops) {
+	foreach my $path (GeniXML::FindNodes("n:path",
+					     $ref)->get_nodelist()) {
+	    my $current = CreatePath($class, $path);
+	    $stitchpoints{$current->linkname()} = $current;
+	}
+    }
+}
+
+sub CreatePath($$)
+{
+    my ($class, $rspec) = @_;
+    my $self = {};
+    $self->{'linkname'} = GeniXML::GetText("id", $rspec);
+    $self->{'rspec'} = $rspec;
+    
+    my @hoplist = GeniXML::FindNodes("n:hop",
+				     $rspec)->get_nodelist();
+    my %hophash = ();
+    foreach my $hop (@hoplist) {
+	my $hop_id = GeniXML::GetText("id", $hop);
+	$hophash{$hop_id} = $hop;
+    }
+    $self->{'hophash'} = \%hophash;
+    $self->{'hoplist'} = \@hoplist;
+    $self->{'points'} = [];
+    $self->{'error'} = undef;
+
+    bless ($self, $class);
+    $self->findStitchPoint();
+    return $self;
+}
+
+# accessors
+sub field($$)           { return ($_[0]->{$_[1]}); }
+sub linkname($)         { return field($_[0], 'linkname'); }
+sub rspec($)            { return field($_[0], 'rspec'); }
+sub hophash($)          { return field($_[0], 'hophash'); }
+sub hoplist($)          { return field($_[0], 'hoplist'); }
+sub points($)           { return field($_[0], 'points'); }
+sub error($)            { return field($_[0], 'error'); }
+
+sub min_vlan($)
+{
+    my ($self) = @_;
+    my $result = undef;
+    foreach my $point (@{ $self->points() }) {
+	my $network = $point->{'network'};
+	if (! defined($result) || $network->min_vlan() > $result) {
+	    $result = $network->min_vlan();
+	}
+    }
+    return $result;
+}
+
+sub max_vlan($)
+{
+    my ($self) = @_;
+    my $result = undef;
+    foreach my $point (@{ $self->points() }) {
+	my $network = $point->{'network'};
+	if (! defined($result) || $network->max_vlan() < $result) {
+	    $result = $network->max_vlan();
+	}
+    }
+    return $result;
+}
+
+sub vlan_ok($$)
+{
+    my ($self, $vlan) = @_;
+    my $ok = 1;
+    foreach my $point (@{ $self->points() }) {
+	my $network = $point->{'network'};
+	$ok = $ok && $network->VlanTagOkay($vlan);
+    }
+    return $ok;
+}
+
+sub mode($)
+{
+    my ($self) = @_;
+    my $mode = "chain";
+    foreach my $point (@{ $self->points() }) {
+	my $network = $point->{'network'};
+	if ($network->mode() eq "tree") {
+	    $mode = "tree";
+	}
+    }
+    return $mode;
+}
+
+sub suggested_vlan($)
+{
+    my ($self) = @_;
+    my $result = 0;
+    foreach my $point (@{ $self->points() }) {
+	my $hop = $point->{'internal_hop'};
+	my $vlan = GeniXML::GetSuggestedVlanFromHop($hop);
+	if (defined($vlan) && ! $result) {
+	    $result = $vlan;
+	}
+	# All the suggested vlans bordering this AM must agree.
+	if (defined($vlan) && $result != $vlan) {
+	    $result = 0;
+	    last;
+	}
+    }
+    return $result;
+}
+
+sub edge_iface($$)
+{
+    my ($self, $count) = @_;
+    my $result = undef;
+    my @points = @{ $self->points() };
+    if (scalar(@points) > $count) {
+	$result = $points[$count]->{'edgeiface'};
+    }
+    return $result;
+}
+
+
+sub network($$)
+{
+    my ($self, $count) = @_;
+    my $result = undef;
+    my @points = @{ $self->points() };
+    if (scalar(@points) > $count) {
+	$result = $points[$count]->{'network'};
+    }
+    return $result;
+}
+
+sub network_id($)
+{
+    my ($self) = @_;
+    my @points = @{ $self->points() };
+    return $points[0]->{'network'}->network_id();
+}
+
+sub findStitchPoint($)
+{
+    my ($self) = @_;
+    my @hoplist = @{ $self->hoplist() };
+    if (! @hoplist) {
+	my $lanname = $self->linkname();
+	$self->{'error'} = 
+	    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
+				 "$lanname: No hops in the stitching path");
+	return;
+    }
+    $self->addStitchPoint(@hoplist);
+    $self->addStitchPoint(reverse(@hoplist));
+}
+
+sub addStitchPoint($@)
+{
+    my $self = shift(@_);
+    my @hoplist = @_;
+    my ($external, $internal) = WalkHops(@hoplist);
+    my $lanname = $self->linkname();
+    
+    if (!defined($external) || !defined($internal)) {
+	$self->{'error'} =
+	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				 "$lanname: no edge hop");
+	return;
+    }
+
+    my $internalurn = GeniXML::GetHopLinkID($internal);
+    if (!defined($internalurn)) {
+	$self->{'error'} =
+	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				 "$lanname: missing urn on path");
+	return;
+    }
+    foreach my $point ($self->points()) {
+	if (GeniXML::GetHopLinkID($point->{'internal'} eq $internalurn)) {
+	    # If there is just one stitch point, this may be a duplicate
+	    return;
+	}
+    }
+
+    #
+    # Look inside the external hop urn; it tells the local iface/node
+    # which corresponds to our "fake" nodes.
+    #
+    my $edgeurn = GeniXML::GetHopLinkID($external);
+    my $edgewire = Interface::Wire->Lookup($edgeurn);
+    my $network;
+    my $edgenodeid;
+    my $edgecard;
+    my $edgeport;
+
+    #
+    # The external network may contain the edge URN directly.
+    #
+
+    $network = ExternalNetwork->Lookup($edgeurn);
+    if (defined($network)) {
+	$edgenodeid = $network->node_id();
+	my @networkIfs = ();
+	Interface->LookupAll($edgenodeid, \@networkIfs);
+	if (scalar(@networkIfs) == 1) {
+	    $edgecard = $networkIfs[0]->card();
+	    $edgeport = $networkIfs[0]->port();
+	} else {
+	    $self->{'error'} =
+		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				     "Internal Error. Ambiguous stitchpoint ".
+				     "for external_interface " . $edgeurn);
+	    return;
+	}
+    }
+    
+    #
+    # The external network may be attached to node_id1
+    #
+    if (! defined($network) && defined($edgewire)) {
+	$edgenodeid = $edgewire->node_id1();
+	$edgecard = $edgewire->card1();
+	$edgeport = $edgewire->port1();
+	$network = ExternalNetwork->Lookup($edgenodeid);
+    }
+    
+    # The external network may be attached to node_id2
+    if (! defined($network)) {
+	$edgenodeid = $edgewire->node_id2();
+	$edgecard = $edgewire->card2();
+	$edgeport = $edgewire->port2();
+	$network = ExternalNetwork->Lookup($edgenodeid);
+    }
+    if (!defined($network)) {
+	$self->{'error'} =
+	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				 "$lanname: unknown network for ".
+				 "external_interface " . $edgeurn);
+	return;
+    }
+    
+    #
+    # The edge interface must exist.
+    #
+    my $edgeiface = Interface->Lookup($edgenodeid, $edgecard,
+				      $edgeport);
+    if (!defined($edgeiface)) {
+	$self->{'error'} =
+	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				 "$lanname: unknown iface for ".
+				 "$edgenodeid:$edgecard.$edgeport");
+	return;
+    }
+    my $stitch = {};
+    $stitch->{'internal_hop'} = $internal;
+    $stitch->{'external_hop'} = $external;
+    $stitch->{'network'} = $network;
+    $stitch->{'edgeiface'} = $edgeiface;
+    push(@{ $self->{'points'} }, $stitch);
+}
+
+sub WalkHops(@)
+{
+    my @hoplist = @_;
+    my $external;
+    my $internal;
+    my $lasthop;
+    my $is_inside;
+
+    #
+    # Go through the hop list to find the edge point. This will be
+    # either the first hop not in our domain or the first hop inside
+    # of our domain
+    #
+    foreach my $hop (@hoplist) {
+	my $hopurn = GeniXML::GetHopLinkID($hop);
+	next
+	    if (! GeniHRN::IsValid($hopurn));
+	
+	my ($auth,undef,undef) = GeniHRN::Parse($hopurn);
+	next
+	    if (!defined($auth));
+
+	if (! defined($is_inside) && $auth ne $OURDOMAIN) {
+	    $is_inside = 0;
+	} elsif (! defined($is_inside) && $auth eq $OURDOMAIN) {
+	    $is_inside = 1;
+	} elsif ($is_inside && $auth ne $OURDOMAIN) {
+	    $external = $hop;
+	    $internal = $lasthop;
+	    last;
+	} elsif (! $is_inside && $auth eq $OURDOMAIN) {
+	    $external = $lasthop;
+	    $internal = $hop;
+	    last;
+	}
+	$lasthop = $hop;
+    }
+    return ($external, $internal);
+}
+
+1;

protogeni/lib/GeniXML.pm.in

@@ -42,7 +42,8 @@ GetManagerId GetColocate GetSubnodeOf GetStartupCommand GetTarball
 GetVirtualizationType SetVirtualizationSubtype GetVirtualizationSubtype
 GetExclusive SetExclusive GetLinkManager SetText GetText Serialize
 CreateDocument AddElement RemoveChild PolicyExists GetMask
-GetDiskImage IsUntaggedLan IsTaggedLan);
+GetDiskImage IsUntaggedLan IsTaggedLan GetHopLinkID GetCapabilitySection
+GetSuggestedVlanFromHop SetVlanTagInHop);
 
 use English;
 use XML::LibXML;
@@ -913,5 +914,63 @@ sub PolicyExists($$)
     return $exists;
 }
 
+sub GetHopLinkID($)
+{
+    my ($ref)  = @_;
+    my $result = "";
+			
+    my $link = FindFirst("n:link", $ref);
+    if (defined($link)) {
+	$result = GetText("id", $link);
+    }
+    return $result;
+}
+
+sub GetHopCapabilitySection($)
+{
+    my ($hopref) = @_;
+    
+    #
+    # Dig out the section we need from the hop.
+    #
+    my $tmp = FindFirst("n:link", $hopref);
+    $tmp = (FindFirst("n:switchingCapabilityDescriptor", $tmp) ||
+	    FindFirst("n:switchingCapabilityDescriptors", $tmp))
+	if (defined($tmp));
+    $tmp = FindFirst("n:switchingCapabilitySpecificInfo", $tmp)
+	if (defined($tmp));
+    if (defined($tmp) &&
+	FindFirst("n:switchingCapabilitySpecificInfo_L2sc", $tmp)) {
+	$tmp = FindFirst("n:switchingCapabilitySpecificInfo_L2sc", $tmp)
+    }
+    return $tmp;
+}
+
+sub GetSuggestedVlanFromHop($)
+{
+    my ($hopref) = @_;
+    my $capref   = GetHopCapabilitySection($hopref);
+    return undef
+	if (!defined($capref));
+
+    my $tag = GeniXML::GetText("suggestedVLANRange", $capref);
+    $tag = undef
+	if (defined($tag) && ! looks_like_number($tag));
+    return $tag;
+}
+
+sub SetVlanTagInHop($$)
+{
+    my ($hopref, $tag) = @_;
+
+    my $capref = GetHopCapabilitySection($hopref);
+    return undef
+	if (!defined($capref));
+
+    GeniXML::SetText("vlanRangeAvailability", $capref, "$tag");
+    GeniXML::SetText("suggestedVLANRange", $capref, "$tag");
+    return 0;
+}
+
 # _Always_ make sure that this 1 is at the end of the file...
 1;