#!/usr/bin/perl -w
#
# EMULAB-COPYRIGHT
# Copyright (c) 2000-2009 University of Utah and the Flux Group.
# All rights reserved.
#
use English;
use Getopt::Std;
use Math::BigInt;
use lib "@prefix@/lib";
use libdb qw(TBGetSiteVar);
my $PGENISUPPORT = @PROTOGENI_SUPPORT@;
if ($PGENISUPPORT) {
require GeniHRN;
}
use GeniHRN;
sub usage()
{
print("Usage: ptopgen [-v] [-s switch] [-p pid [-e eid]] [-m factor] " .
"[-n c/e] [-x] [-g] [-c component-name]\n".
" -p include nodes the project has permission to use\n".
" -e include given experiments resources\n" .
" in the ptopfile (as if they were free)\n" .
" -v Include stuff for topologies with virtual nodes\n".
" -r Include stuff for topologies with widearea nodes\n".
# " -s Include stuff for topologies with simulated nodes\n".
" -h Include stuff for topologies with shared nodes\n".
" -a Include even reserved nodes\n".
" -m Override multiplex_factor\n".
" -u Prune unused interfaces of allocated nodes (-e)\n".
" -c Delay capacity override\n".
" -n Add in modelnet core and edge node features\n".
" -x Output into the new xml ptop format.\n".
" -g With -x, geni version\n".
" -1 Print an rspec containing only the node component-name");
exit(-1);
}
my $optlist = "s:e:m:vp:rSan:c:uxgh1:";
my $mfactor;
my $virtstuff = 0;
my $widearea = 0;
my $simstuff = 0;
my $allnodes = 0;
my $mnetcores = 0;
my $mnetedges = 0;
my $prune = 0;
my $do_xml = 0;
my $genimode = 0;
my $useshared = 0;
my $component_name = undef;
my $OURDOMAIN = "@OURDOMAIN@";
my $MAINSITE = @TBMAINSITE@;
my $cmuuid = TBGetSiteVar('protogeni/cm_uuid');
my $cmurn = "";
if ($PGENISUPPORT) {
$cmurn = GeniHRN::Generate($OURDOMAIN, "authority", "cm");
}
my $delaycap_override;
#
# Turn off line buffering on output
#
$| = 1;
# Settings - Change these to your particular network.
#
# Also bogus. The interfaces table does not hold entries for the switch
# side of each link. It will have to at some point, when we have something
# other than 100Mbs ports (say, gbit ports).
#
# Speed in in Kbs!
#
my $default_switchport_speed = 100000;
#
# Yet more bogosity - we hardcode this weight, which is given to wide-area
# (primarily plab) nodes to prefer spreading across sites
#
my $site_weight = 0.99;
######################################################################
my $TBROOT = "@prefix@";
use lib '@prefix@/lib';
require exitonwarn;
use libdb;
use libtblog;
use Experiment;
use NodeType;
use Lan;
tblog_stop_capture('stdout');
my $TRACK_INTERSWITCH_BANDWIDTH = "@TRACK_INTERSWITCH_BANDWIDTH@";
my %switches = ();
my %used_switches = ();
my %permissions = ();
my %typemap = ();
my %auxtypemap = ();
my %areamap = ();
my %globalcounts = ();
my %interfacestate= ();
my %vinterfaces = ();
my %rusagedata = ();
my $DEADPID = NODEDEAD_PID();
my $DEADEID = NODEDEAD_EID();
my $pid;
my $exempt_eid;
my $switchtouse;
my $experiment;
#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
usage();
}
if (@ARGV) {
usage();
}
if (defined($options{"s"})) {
$switchtouse = $options{"s"};
}
if (defined($options{"m"})) {
$mfactor = $options{"m"};
}
if (defined($options{"h"})) {
$useshared = 1;
}
if (defined($options{"v"})) {
$virtstuff = 1;
}
if (defined($options{"r"})) {
$widearea = 1;
}
if (defined($options{"S"})) {
$simstuff = 1;
}
if (defined($options{"p"})) {
$pid = $options{"p"};
}
if (defined($options{"a"})) {
$allnodes = 1;
}
if (defined($options{"u"})) {
$prune = 1;
}
if (defined($options{"c"})) {
$delaycap_override = $options{"c"};
}
if (defined($options{"n"})) {
if ($options{"n"} =~ /(\d*),(\d*)/) {
$mnetcores = $1;
$mnetedges = $2;
}
else {
usage();
}
}
if (defined($options{"e"})) {
$exempt_eid = $options{"e"};
usage()
if (!defined($pid));
$experiment = Experiment->Lookup($pid, $exempt_eid);
die("Could not look up experiment $pid,$exempt_eid\n")
if (!defined($experiment));
}
if (defined($options{"x"})) {
$genimode = $useshared = $virtstuff = 1
if (defined($options{"g"}) && $PGENISUPPORT);
$do_xml = 1;
}
if (defined($options{"1"})) {
$component_name = $options{"1"};
}
usage()
if ($prune && !defined($exempt_eid));
print_header();
my %nodetointerface;
# Read interfaces
my $result =
DBQueryFatal("SELECT node_id,card,port,iface,interface_type" .
" from interfaces " .
($genimode ? "where role!='gw'" : ""));
while (($node,$card,$port,$iface,$type) = $result->fetchrow_array) {
push @{ $nodetointerface{"$node"} }, $iface;
$interfacemap{"$node:$card:$port"} = $iface;
if ((defined $type) && ($type ne "")) {
$interfacetypes{"$node:$card:$port"} = $type;
}
}
my %nodetouuid;
my %nodetoavailable;
$result = DBQueryFatal("SELECT n.node_id, n.eventstate, n.role, n.uuid, " .
"nt.isremotenode, " .
"dedicated_wa_types.attrvalue, b.sharing_mode, " .
"n.reserved_pid, b.eid " .
"from nodes as n " .
"left join reserved as b on n.node_id=b.node_id " .
"left join node_types as nt on nt.type=n.type " .
"left outer join " .
" (select type, attrvalue " .
" from node_type_attributes " .
" where attrkey='dedicated_widearea' " .
" group by type) as dedicated_wa_types " .
" on nt.type=dedicated_wa_types.type " .
"where nt.isvirtnode = 0 or nt.isvirtnode is null;");
while (($node,$eventstate, $role, $uuid, $isremotenode,
$wa_attrvalue, $sharing_mode,
$reserved_pid, $reserved_eid) = $result->fetchrow_array) {
if (defined($uuid) && $uuid ne "")
{
$nodetouuid{$node} = $uuid;
}
my $islocal = $role eq 'testnode'
&& ((! defined($isremotenode) || $isremotenode == 0)
|| (defined($wa_attrvalue) && $wa_attrvalue == 1));
my $isup = defined($eventstate)
&& ($eventstate eq TBDB_NODESTATE_ISUP
|| $eventstate eq TBDB_NODESTATE_PXEWAIT
|| $eventstate eq TBDB_NODESTATE_POWEROFF
|| $eventstate eq TBDB_NODESTATE_ALWAYSUP);
my $isshared = (defined($sharing_mode)
&& $sharing_mode eq "shared_local"
&& $useshared
&& $isup);
my $isreserved = (defined($reserved_eid)
|| (defined($reserved_pid)
&& (! defined($pid) || $pid ne $reserved_pid)));
my $isfree = (!$islocal
|| (! $isreserved && $isup)
|| $isshared);
$nodetoavailable{$node} = $isfree;
}
# Read class/type maps
$result =
DBQueryFatal("select class,type,isvirtnode from node_types");
while (my ($class,$type,$isvirt) = $result->fetchrow_array) {
$map = {};
$map->{'CLASS'} = $class;
$map->{'ISVIRT'} = $isvirt;
my $typeinfo = NodeType->Lookup($type);
$map->{'DELAYCAP'} = $typeinfo->delay_capacity();
$map->{'VIRTCAP'} = $typeinfo->virtnode_capacity();
$map->{'SIMCAP'} = $typeinfo->simnode_capacity();
$map->{'SPEED'} = $typeinfo->frequency();
$map->{'RAM'} = $typeinfo->memory();
$map->{'OSID'} = $typeinfo->default_osid();
$map->{'IMAGEABLE'}= $typeinfo->imageable();
$map->{'TRIVSPEED'}= $typeinfo->trivlink_maxspeed();
$map->{'SHARED'} = $typeinfo->shared();
$map->{'TYPEINFO'} = $typeinfo;
$map->{'FEATURES'} = [];
$map->{'AUXTYPES'} = {};
$typemap{$type} = $map;
# Default is permission to use all types,classes.
$permissions{$class} = 1;
$permissions{$type} = 1;
}
# Read node_startloc
$result = DBQueryFatal("select node_id,building from node_startloc");
while (($node,$building) = $result->fetchrow_array) {
# TODO: This screws up the meaning of the @features list. Now it
# is not just a list of feature strings, but a list of strings
# which might themselves be space-delimited lists of feature
# strings. Fix this.
$areamap{$node} .= " area-$building:0";
}
#
# Read the features table for each type.
#
$result = DBQueryFatal("select type, feature, weight from node_type_features");
while (my ($type, $feature, $weight) = $result->fetchrow()) {
push(@{$typemap{$type}->{'FEATURES'}}, "$feature:$weight");
}
#
# Read the auxtypes for each type.
#
$result = DBQueryFatal("select auxtype,type from node_types_auxtypes");
while (my ($auxtype,$type) = $result->fetchrow()) {
$typemap{$type}->{'AUXTYPES'}->{$auxtype} = 1;
$auxtypemap{$auxtype} = $type;
}
#
# Read the features table for each individual node
#
$result = DBQueryFatal("select node_id, feature, weight from node_features");
while (my ($node_id, $feature, $weight) = $result->fetchrow()) {
if (! defined($features{$node_id})) {
$features{$node_id} = ["$feature:$weight"];
next;
} else {
push @{$features{$node_id}}, "$feature:$weight";
}
}
#
# Read in the node_auxtypes table for each node.
#
$result = DBQueryFatal("select node_id, type, count from node_auxtypes");
while (my ($node_id, $type, $count) = $result->fetchrow()) {
if (! defined($auxtypes{$node_id})) {
$auxtypes{$node_id} = ["$type:$count"];
next;
}
push @{$auxtypes{$node_id}}, "$type:$count";
}
#
# Read the permission table if given a pid. If there is an entry in
# the table for a type/class, then permission is granted only if there
# is a record with the pid. If not, remove the permission granted above.
#
if (defined($pid)) {
$result =
DBQueryFatal("select type from nodetypeXpid_permissions");
while (my ($type) = $result->fetchrow_array) {
$permissions{$type} = 0;
}
$result =
DBQueryFatal("select type from nodetypeXpid_permissions ".
"where pid='$pid'");
while (my ($type) = $result->fetchrow_array) {
$permissions{$type} = 1;
}
}
#
# Read the table of which image types are supported on which hardware - we
# limit this to global images and ones that match the PID (if given) We do this
# limiting for two reasons:
# 1) To avoid an explosion in the number of features for nodes
# 2) To avoid information leaks, allowing projects to see each other's images
#
my $osidquery = "select distinct o.osid, oi.type from os_info as o " .
"left join osidtoimageid as oi on o.osid = oi.osid " .
"left join images as i on oi.imageid = i.imageid ".
"where i.global = 1";
if ($pid) {
$osidquery .= " or i.pid='$pid'";
}
my %node_type_osids;
my %osid_node_types;
my %node_countries;
my %node_latitudes;
my %node_longitudes;
$result = DBQueryFatal($osidquery);
while (my ($osid,$type) = $result->fetchrow()) {
if ($node_type_osids{$type}) {
push @{$node_type_osids{$type}}, $osid;
} else {
$node_type_osids{$type} = [$osid];
}
#
# We have to maintain a data structure telling us which types an OSID could
# be on for use below with generic OSIDs
#
if ($osid_node_types{$osid}) {
push @{$osid_node_types{$osid}}, $type;
} else {
$osid_node_types{$osid} = [$type];
}
}
#
# We also have to resolve the 'generic' OSIDs, which use the nextosid field to
# redirect to another OSID
#
$result = DBQueryFatal("select osid from os_info where " .
"nextosid is not null");
while (my ($osid) = $result->fetchrow()) {
#
# Check to see if they were allowed to use the real OSID
#
my $realosid = TBResolveNextOSID($osid, $pid, $exempt_eid);
if ($osid_node_types{$realosid}) {
foreach my $type (@{$osid_node_types{$realosid}}) {
push @{$node_type_osids{$type}}, $osid;
}
}
}
# Print switches
if (defined($switchtouse) && ! defined($component_name)) {
# Should probably get the last four args out of the database, but I don't
# think we ever actually use this case...
print_switch($switchtouse,undef,undef,undef,undef);
$switches{$switchtouse} = 1;
}
elsif (! defined($component_name)) {
$result =
DBQueryFatal("select n.node_id, n.uuid, country, latitude, longitude " .
"from nodes as n left join widearea_nodeinfo as wn ".
" on n.node_id=wn.node_id " .
"where role='testswitch' or role='widearea_switch'");
while (($switch, $uuid, $country, $latitude, $longitude) =
$result->fetchrow_array) {
print_switch($switch, $uuid, $country, $latitude, $longitude);
$switches{$switch} = 1;
}
}
#
# Get the global counts.
#
$result =
DBQueryFatal("select phys_nodeid,count(phys_nodeid) from reserved as r ".
"left join nodes as n on n.node_id=r.node_id ".
"where n.node_id!=n.phys_nodeid ".
(defined($exempt_eid) ?
"and not (pid='$pid' and eid='$exempt_eid') " : " ") .
"group by phys_nodeid");
while (my ($node_id,$count) = $result->fetchrow_array) {
$globalcounts{$node_id} = $count;
}
# Find available nodes.
#
# This first query deals with just local nodes. Local nodes can host
# virtnodes, according to the delay_capacity in the types table.
#
# the ordinary free condition for a local node.
my $free_condition = "(b.node_id is null and ".
" (np.eventstate='" . TBDB_NODESTATE_ISUP . "' or ".
" np.eventstate='" . TBDB_NODESTATE_PXEWAIT . "' or ".
" np.eventstate='" . TBDB_NODESTATE_POWEROFF . "' or ".
" np.eventstate='" . TBDB_NODESTATE_ALWAYSUP . "')) ";
if (defined($pid)) {
$free_condition = "($free_condition and ".
"(np.reserved_pid is null or np.reserved_pid='$pid'))";
}
# if the user has specified an exempt pid/eid,
# then view any node which is reserved to that experiment as available.
if (defined($exempt_eid)) {
$free_condition = "($free_condition or ".
"(b.pid='$pid' and b.eid='$exempt_eid'))";
}
# In shared mode, allow allocated nodes whose sharing_mode is set.
if ($useshared) {
$free_condition = "($free_condition or ".
"(b.node_id is not null && b.sharing_mode='shared_local' && ".
" np.eventstate='" . TBDB_NODESTATE_ISUP . "'))";
}
# If the user wants all nodes, we consider everything to be free (this
# overrides the other possible free conditions
if ($allnodes) {
$free_condition = "1";
}
# In genimode exclude nodes with exclusion attribute.
if ($genimode) {
$free_condition = "($free_condition and ".
"(nat1.attrvalue is null or nat1.attrvalue=0))";
}
if (defined($component_name)) {
$free_condition = "(a.node_id = \"$component_name\")";
}
$result =
DBQueryFatal("select a.node_id,a.type,a.phys_nodeid,t.class,t.issubnode," .
"a.def_boot_osid,(b.pid is not null and b.eid is not null), ".
" np.reserved_pid is not null,np.eventstate, ".
" np.battery_percentage,np.uuid,b.sharing_mode, ".
" ru.load_1min, ru.load_5min, ru.status_timestamp, ".
" a.def_boot_osid, nat2.attrvalue, wn.country, " .
" wn.latitude, wn.longitude ".
"from nodes as a ".
"left join reserved as b on a.node_id=b.node_id ".
"left join reserved as m on a.phys_nodeid=m.node_id ".
"left join nodes as np on a.phys_nodeid=np.node_id ".
"left join node_types as t on t.type=a.type ".
"left join node_attributes as nat1 on ".
" nat1.node_id=a.node_id and ".
" nat1.attrkey='protogeni_exclude' ".
"left join node_attributes as nat2 on ".
" nat2.node_id=a.node_id and ".
" nat2.attrkey='shared_weight' ".
"left join node_rusage as ru on ru.node_id=a.node_id ".
"left outer join ".
" (select type,attrvalue ".
" from node_type_attributes ".
" where attrkey='dedicated_widearea' ".
" group by type) as dedicated_wa_types ".
" on t.type=dedicated_wa_types.type ".
"left join widearea_nodeinfo as wn on a.node_id=wn.node_id ".
"where $free_condition and ".
" (a.role='testnode' and (t.isremotenode=0 or ".
" dedicated_wa_types.attrvalue=1))");
#
# Scan the results, checking permissions and adding to the list
# You get to use a node type if no pid was specified (that is, you get
# to use all nodes), or if there is no entry in the perms table for
# the type/class of node.
#
while (($node,$type,$physnode,$class,$issubnode,$def_boot_osid,$reserved,
$prereserved,$eventstate,$battery_perc,$uuid,$sharing_mode,
$load_1min,$load_5min,$load_tstamp,$osid,$weight,$country,$latitude,
$longitude) = $result->fetchrow_array) {
$nodes{$node} = $type
if (!defined($pid) ||
($permissions{$type} && $permissions{$class}));
if ($issubnode) {
$subnode_of{$node} = $physnode;
}
$node_def_boot_osid{$node} = $def_boot_osid;
if ($reserved) {
$is_reserved{$node} = 1;
} else {
$is_reserved{$node} = 0;
}
if ($useshared && $sharing_mode) {
$sharing_mode{$node} = { "load_1min" => $load_1min,
"load_5min" => $load_5min,
"load_tstamp" => $load_tstamp,
"osid" => $osid,
"weight" => $weight};
}
else {
$sharing_mode{$node} = 0;
}
$is_prereserved{$node} = $prereserved;
$curr_state{$node} = $eventstate;
$curr_batt{$node} = $battery_perc;
$node_countries{$node} = $country;
$node_latitudes{$node} = $latitude;
$node_longitudes{$node} = $longitude;
}
#
# Find out which nodes are connected to which, so that we can add some special
# features
#
$result = DBQueryFatal("SELECT DISTINCT node_id1, node_id2 " .
" FROM wires");
my %connections = ();
while (my ($node_id1, $node_id2) = $result->fetchrow()) {
foreach my $nodes ([$node_id1, $node_id2], [$node_id2, $node_id1]) {
my ($node1, $node2) = @$nodes;
if ($connections{$node1}) {
# Check to see if we've already added this one (possible if the
# nodes appeared in node1,node2 order, then node2,node1
if (!grep(/^$node2$/, @{$connections{$node1}})) {
push @{$connections{$node1}}, $node2;
}
} else {
$connections{$node1} = [$node2];
}
}
}
#
# Loop through and print out all nodes
#
foreach $node (keys(%nodes)) {
my $type = $nodes{$node};
my $class = $typemap{$type}->{'CLASS'};
my $delay_capacity = $typemap{$type}->{'DELAYCAP'};
my $simnode_capacity = $typemap{$type}->{'SIMCAP'};
my $cpu_speed = $typemap{$type}->{'SPEED'};
my $ram = $typemap{$type}->{'RAM'};
my $trivspeed = $typemap{$type}->{'TRIVSPEED'};
my $uuid = $nodetouuid{$node};
my @types = ("$type:1");
my @features;
my @flags;
my $needvirtgoo = 0;
my ($latitude, $longitude, $country);
# XXX temporary hack until node reboot avoidance
# is available. Nodes running the FBSD-NSE image
# will have a feature def-osid-fbsd-nse 0.0
# This is used by assign to prefer these pnodes
# first before using others.
if($node_def_boot_osid{$node} && ($node_def_boot_osid{$node} eq
TBOSID(TB_OPSPID, "FBSD-NSE"))) {
push(@features, "FBSD-NSE:0.0");
}
# Might be equal, which assign would sum as two, not one!
if ($type ne $class) {
push(@types, "$class:1");
}
if (defined($delay_capacity) && $delay_capacity > 0) {
# Comes from the NS file;
$delay_capacity = $delaycap_override
if (defined($delaycap_override) &&
$delaycap_override > 0 &&
$delaycap_override < $delay_capacity);
push @types, "delay:$delay_capacity";
push @types, "delay-${type}:$delay_capacity";
}
#
# Prototype shared mode.
#
if ($sharing_mode{$node}) {
#
# Add a feature that says this node should not be picked
# unless the cooresponding desire is in the vtop. This
# allows the node to be picked, subject to other type constraints.
#
push(@features, "pcshared:1.0");
#
# The pool daemon may override the share weight.
#
if (defined($sharing_mode{$node}->{"weight"})) {
my $weight = $sharing_mode{$node}->{"weight"};
push(@features, "shareweight:$weight");
}
else {
#
# The point of this feature is to have assign favor shared nodes
# that already have nodes on them, so that they are well packed.
# Shared nodes with just a few vnodes on them are avoided so that
# they will free up eventually.
#
my $maxvnodes = 10;
my $weight = 0.5;
my $gcount = $globalcounts{$node} || 0.0;
foreach my $auxinfo (@{$auxtypes{$node}}) {
my ($auxtype,$count) = split(":", $auxinfo);
if ($auxtype eq "pcvm") {
$maxvnodes = $count;
last;
}
}
#
# No point in the feature if no room left.
#
if ($maxvnodes > $gcount) {
my $factor = ($gcount / $maxvnodes);
if ($factor < 0.25) {
$weight = 0.8;
}
elsif ($factor > 0.75) {
$weight = 0.1;
}
else {
$weight = 0.3;
}
#push(@features, "shareweight:$weight");
}
}
}
#
# Add any auxiliary types
#
foreach my $auxinfo (@{$auxtypes{$node}}) {
my ($auxtype,$count) = split(":", $auxinfo);
my $realtype;
# Map an auxtype back to its real type, unless it is a real type.
if (defined($auxtypemap{$auxtype})) {
$realtype = $auxtypemap{$auxtype};
}
else {
$realtype = $auxtype;
}
if ($typemap{$realtype}->{'ISVIRT'} && $count > 0) {
next
if (! $virtstuff);
if (defined($mfactor) && $mfactor <= $count) {
$auxinfo = "$auxtype:$mfactor";
}
else {
$auxinfo = "$auxtype:$count";
}
$needvirtgoo = 1;
}
push(@types, $auxinfo);
}
if (defined($areamap{$node})) {
push @features, $areamap{$node};
}
my $cpu_ram_features_present = 0;
#
# This stuff is extra goo for local virtual nodes.
#
if ($needvirtgoo) {
push @types, "*lan:*";
# Add trivial bw spec., but only if the node type has it
if ($trivspeed) {
push @flags, "trivial_bw:$trivspeed";
}
# Add CPU and RAM information
$cpu_ram_features_present++;
# This number can be use for fine-tuning packing
push @features, "?+virtpercent:100";
# Put this silly feature in so that we can try to keep vnodes
# on the same pnode they were before - but only if updating
if ($exempt_eid) {
push @features, "${node}:0.0";
}
}
if ($simstuff && defined($simnode_capacity) && $simnode_capacity > 0) {
#
# Use user specified multiplex factor
#
if (defined($mfactor) && $mfactor <= $simnode_capacity) {
push @types, "sim:$mfactor";
}
else {
push @types, "sim:$simnode_capacity";
}
# Add CPU and RAM information
$cpu_ram_features_present++;
push @types, "*lan:*";
# Add trivial bw spec.
push @flags, "trivial_bw:100000";
}
if ($cpu_ram_features_present) {
# Add CPU and RAM information
push @features, "?+cpu:$cpu_speed";
push @features, "?+ram:$ram";
push @features, "?+cpupercent:92"; # XXX Hack
push @features, "?+rampercent:80"; # XXX Hack
}
# Add features
push(@features, @{$typemap{$type}->{'FEATURES'}});
if (defined($features{$node})) {
push @features, @{$features{$node}};
}
#
# Add in OS features.
#
if ($sharing_mode{$node}) {
#
# A shared node is running just one OS, and we put that in
# so that the user can specify which of the current VM types
# is wanted.
#
my $osid = $sharing_mode{$node}->{'osid'};
push(@features, "OS-$osid:0.5");
}
elsif ($node_type_osids{$type}) {
#
# Add in features for all of the OSes that this node (as
# evidenced by its type) can support
#
push @features, map "OS-$_:0", @{$node_type_osids{$type}};
}
elsif (! $typemap{$type}->{'IMAGEABLE'} &&
defined($typemap{$type}->{'OSID'})) {
#
# If node is not imageable (and thus no entries in osidtoimageid,
# then assume it always has its default OSID loaded and ready to
# go, so that assign will agree to the allocation (assign_wrapper
# adds a desire that says it has to be running the OSID the user
# has selected, or the default OSID from the node_types table).
#
push @features, map "OS-$_:0", $typemap{$type}->{'OSID'};
}
# Add features indicating what this node has connections to
if ($connections{$node}) {
my @connected_to = @{$connections{$node}};
foreach my $other_end (@connected_to) {
push(@features,"connected-to-$other_end:0.0");
}
}
# This is for the case that we are modifying an existing experiment - tell
# assign to prefer nodes the user has already allocated
if ($exempt_eid && !$allnodes && $is_reserved{$node}) {
push(@features,"already_reserved:0");
}
if ($is_prereserved{$node}) {
push(@features,"prereserved:0.9");
}
# For robots, prefer ones that are already powered on and/or won't need to
# be recharged soon.
if (defined($curr_state{$node}) && ($curr_state{$node} eq TBDB_NODESTATE_POWEROFF)) {
push(@features,"poweroff:0.9");
}
if (defined($curr_batt{$node})) {
push(@features,"powerneeded:" . (1.0 - $curr_batt{$node} / 100.0));
}
# Add in modelnet stuff.
if ($mnetcores) {
push(@types, "modelnet-core:$mnetcores");
}
if ($mnetedges) {
push(@types, "modelnet-edge:$mnetedges");
}
#
# Handle subnodes
#
if ($subnode_of{$node}) {
# We don't want to include subnodes unless their parent node is going
# to be in the ptop file too
if (!$nodes{$subnode_of{$node}} ||
$sharing_mode{$subnode_of{$node}}) {
# In fact, nuke it from %nodes so that we don't include its links,
# either
delete $nodes{$node};
next;
}
# Push the subnode's information into its flags
push @flags, "subnode_of:$subnode_of{$node}";
}
#
# Handle node locations
#
$country = $node_countries{$node};
$latitude = $node_latitudes{$node};
$longitude = $node_longitudes{$node};
my @parse_features = split(" ", join(" ", @features));
print_node($node, \@types, \@parse_features, \@flags, $uuid,
$nodetointerface{$node}, $country, $latitude, $longitude);
}
#
# Widearea Nodes. Includes plab nodes. Note that widearea nodes are never
# allocated directly (they are in a holding experiment), but assign deals
# with it by allocating multiple vnodes on a pnode.
#
# The underlying physnode has to be "up", as determined by the
# autostatus stuff; this will prevent us from allocating a dead
# virtual node to an experiment. This is especially hacky. We need
# another mechanism for this. We only add virtnodes when assign says
# we need them. This reduces the problem size for assign.
#
# The types we lay out are only those in the auxtypes table for the node,
# since that is where we define what vtypes are hosted on a particular
# physnode.
#
if ($widearea && ! defined($component_name)) {
#
# Set up 'the Internet' as a fake switch that all widearea nodes can
# talk to.
# Some day, it may make sense to connect control net ports to this
# switch.
#
my $fake_inet_switch = "internet";
my @inet_protos = ("ipv4");
my @types = map("*$_:*", @inet_protos);
print_node($fake_inet_switch, \@types, [], [], undef, [], undef, undef,
undef);
#
# Note - there is currently an assumption in this query that widearea nodes
# have only one control interface.
#
$result =
DBQueryFatal("select n.node_id,nt.type,ns.status,r.pid,r.eid,wn.site,".
"wn.country,wn.latitude,wn.longitude, ".
"i.iface,wn.bwlimit,n.uuid ".
"from nodes as n ".
"left join node_types as nt on nt.type=n.type ".
"left join reserved as r on r.node_id=n.node_id ".
"left join node_status as ns on ns.node_id=n.node_id ".
"left join widearea_nodeinfo as wn on ".
" wn.node_id=n.node_id ".
"left join interfaces as i on ".
" n.node_id=i.node_id and ".
" i.role='" . TBDB_IFACEROLE_CONTROL() . "' ".
"left outer join ".
" (select type,attrvalue ".
" from node_type_attributes ".
" where attrkey='dedicated_widearea' ".
" group by type) as dedicated_wa_types ".
" on nt.type=dedicated_wa_types.type ".
"where (n.role='testnode' and nt.isremotenode=1 and ".
" nt.isvirtnode=0 and nt.type!='pcfedphys' and ".
" dedicated_wa_types.attrvalue is NULL)");
while (($physnode,$ptype,$status,$mpid,$meid,$site,$country,$latitude,
$longitude,$iface,$bwlimit,$uuid)
= $result->fetchrow_array) {
my $class = $typemap{$ptype}->{'CLASS'};
my @types;
my @features;
my @flags;
my $maxvnodes;
#
# Grab the global allocation count of vnodes on this pnode (if there
# is one). This modifies the counts below. If the count has already
# been reached, then do not put this node into the ptop file.
#
$maxvnodes =
$typemap{$ptype}->{'TYPEINFO'}->GetAttribute("global_capacity");
if (defined($maxvnodes) && exists($globalcounts{$physnode})) {
$maxvnodes -= $globalcounts{$physnode};
next
if ($maxvnodes <= 0);
}
#
# Mark any nodes that are not up with a feature, so that they won't
# normally get assigned. We want to include them, though, because we
# allow people to do fix-node to down nodes
#
if (($status && ($status ne 'up')) ||
($mpid eq $DEADPID && $meid eq $DEADEID)) {
# But not in genimode.
next
if ($genimode);
push @features, "down:1";
}
#
# Mark which site this node belongs to
#
if ($site) {
push @features, "*&$site:$site_weight";
}
#
# Add any auxiliary types.
#
foreach my $auxinfo (@{$auxtypes{$physnode}}) {
my ($auxtype,$count) = split(":", $auxinfo);
$count = $maxvnodes
if (defined($maxvnodes) && $maxvnodes < $count);
if (defined($mfactor) && $mfactor <= $count) {
$auxinfo = "$auxtype:$mfactor";
}
else {
$auxinfo = "$auxtype:$count";
}
push(@types, $auxinfo);
}
# Add trivial bw spec.
push @flags, "trivial_bw:400000";
# Indicate that these nodes are beautiful and unique snowflakes
push @flags, "unique";
# Add features
push(@features, @{$typemap{$ptype}->{'FEATURES'}});
if (defined($features{$physnode})) {
push @features, @{$features{$physnode}};
}
#
# Add in features for all of the OSes that this node (as evidenced by
# its type) can support
#
if ($node_type_osids{$ptype}) {
push @features, map "OS-$_:0", @{$node_type_osids{$ptype}};
}
#
# Put in a feature indicating whether or not this node has a bandwidth
# cap
#
if (!defined($bwlimit) || $bwlimit eq "-1") {
push @features, "nobwlimit:0";
} else {
push @features, "bwlimit:0";
}
print_node($physnode, \@types, \@features, \@flags, $uuid,
$nodetointerface{$physnode},$country,$latitude,$longitude);
#
# Print out a link to the 'internet'.
# Note - we make up a fake bandwidth. In the future, maybe we
# could put something real in there.
#
if ($iface) {
print_simple_link($physnode, $iface,
$fake_inet_switch, "(null)",
100000, 0, 0, @inet_protos);
}
# Insert into nodes array in case there are wires entries.
$nodes{$physnode} = $ptype;
}
}
# Read interface types. First need to find the protocols an interface supports
# and then then the speed for each of those protocols.
# Note that we are going to assume anything attached to a switch is ethernet.
$result = DBQueryFatal("SELECT type,capkey,capval from interface_capabilities ".
"where capkey='protocols' or capkey like '%_defspeed'");
while (($type,$capkey,$capval) = $result->fetchrow_array) {
if ($capkey eq "protocols") {
$interfaceprotocols{$type} = [ split(",", $capval) ];
}
elsif ($capkey =~ /^([-\w]+)_defspeed$/) {
$interfacespeeds{$type}{$1} = $capval;
}
else {
die("Improper defspeed $capval for $type!\n");
}
}
# Read interface switches
$result = DBQueryFatal("SELECT node_id1, iface, node_id2 FROM wires AS w " .
"LEFT JOIN interfaces as i ON w.node_id1=i.node_id AND w.card1=i.card");
while (($node,$iface,$switch) = $result->fetchrow_array) {
if ($node && $iface) {
$interfaceswitches{"$node:$iface"} = $switch;
}
}
# Read interface cards and ports
$result = DBQueryFatal("SELECT node_id, iface, card, port, IP ".
"FROM interfaces");
while (($node,$iface,$card,$port,$IP) = $result->fetchrow_array) {
next
if ($prune && $is_reserved{$node} && !$sharing_mode{$node} &&
(!defined($IP) || $IP eq ""));
$interfacecardports{"$node:$iface"} = [$card,$port];
}
# Read interface_state
$result = DBQueryFatal("select * from interface_state");
while (my $ref = $result->fetchrow_hashref()) {
my $node = $ref->{'node_id'};
my $iface = $ref->{'iface'};
$interfacestate{"$node:$iface"} = $ref;
}
#
# Add back in the used shared bandwidth.
#
if (defined($experiment)) {
# Read the vinterfaces table to get any bandwidth in use by
# this experiment.
my $exptidx = $experiment->idx();
my $pstateDir = $experiment->WorkDir() . "/pstate";
DBQueryFatal("create temporary table if not exists ".
"vinterfaces_${exptidx} like vinterfaces");
DBQueryFatal("delete from vinterfaces_${exptidx}");
DBQueryFatal("load data infile '$pstateDir/vinterfaces' ".
"into table vinterfaces_${exptidx}")
if (-e "$pstateDir/vinterfaces");
$result = DBQueryFatal("select * from vinterfaces_$exptidx ".
"where exptidx=$exptidx");
while (my $row = $result->fetchrow_hashref()) {
my $node = $row->{'node_id'};
my $iface = $row->{'iface'};
my $bandwidth = $row->{'bandwidth'};
next
if (!defined($iface) || $bandwidth <= 0);
next
if (!exists($interfacestate{"$node:$iface"}));
my $ref = $interfacestate{"$node:$iface"};
$ref->{'remaining_bandwidth'} =
$ref->{'remaining_bandwidth'} + $bandwidth;
}
}
$result = DBQueryFatal("SELECT node_id1,card1,port1,node_id2,card2,port2" .
" from wires where type=\"Node\" or type=\"Trunk\"");
while (($node1,$card1,$port1,$node2,$card2,$port2) =
$result->fetchrow_array) {
if ((defined($nodes{$node1}) || defined($switches{$node1})) &&
(defined($nodes{$node2}) || defined($switches{$node2})) &&
! defined($component_name)) {
# Types for this link - for the time being, we assume that all
# links are Ethernet, though this will certaily change later.
my $basetype = "ethernet";
$iface1 = get_iface($node1,$card1,$port1);
$iface2 = get_iface($node2,$card2,$port2);
$iface1bw = get_ifacebw($node1,$card1,$port1,$basetype);
$iface2bw = get_ifacebw($node2,$card2,$port2,$basetype);
my @types = ($basetype);
next
if (! exists($interfacecardports{"$node1:$iface1"}));
# XXX - This is a bad, bad hack - we use our knowledge that in the
# wires table links to the switch always come as node2.
# Chris has something better on the way (storing the speed on the
# switch side), so this is just a temp. hack.
if (!defined($switches{$node1}) && defined($switches{$node2})) {
$bw = $iface1bw;
} else {
if ($iface1bw < $iface2bw) {
$bw = $iface1bw;
} else {
$bw = $iface2bw;
}
}
if (defined($switches{$node2})) {
$used_switches{$node2} = 1;
}
if (defined($switches{$node1})) {
$used_switches{$node1} = 1;
}
if (defined($switches{$node1}) && defined($switches{$node2})) {
# interswitch link
if (defined($interconnects{"$node1:$node2"})) {
$interconnects{"$node1:$node2"} += $bw;
} else {
$interconnects{"$node1:$node2"} = new Math::BigInt $bw;
}
} else {
# Node-to-switch link
# !!! - Here we use our knowledge that in the wires table links
# to the switch always come as node2.
# Come up with some other types for this link. The idea is that
# it allows people to ask for links to specific switches, specific
# interface types, etc.
my $switch = get_ifaceswitch($node1,$iface1);
if ($switch) {
push @types, "$basetype-$switch";
}
if ($interfacetypes{"$node1:$card1:$port1"}) {
push @types, "$basetype-" .
$interfacetypes{"$node1:$card1:$port1"};
}
push @types, "$basetype-$bw";
if ($sharing_mode{$node1}) {
$bw =
$interfacestate{"$node1:$iface1"}->{'remaining_bandwidth'};
next
if ($bw == 0);
}
print_simple_link($node1, $iface1,
$node2, $iface2,
$bw, 0, 0, @types);
}
}
}
#
# If we're supposed to track interswitch bandwidth, subtract out the amount
# that's already in use
#
if ($TRACK_INTERSWITCH_BANDWIDTH) {
#
# Get a list of all VLANs
#
my @vlans;
if (VLan->AllVLans(\@vlans) != 0) {
die("*** $0:\n".
" Unable to load VLANs for all experiments\n");
}
foreach my $vlan (@vlans) {
my @members;
if ($vlan->MemberList(\@members) != 0) {
die("*** $0:\n".
" Unable to load members for $vlan\n");
}
my %switches = ();
foreach my $member (@members) {
my $node;
my $iface;
if ($member->GetNodeIface(\$node, \$iface) != 0) {
die("*** $0:\n".
" Missing attributes for $member in $vlan\n");
}
my $nodeid = $node->node_id();
my $switch = get_ifaceswitch($nodeid,$iface);
my ($card, $port) = get_ifacecardport($nodeid,$iface);
my $bw = get_ifacebw($nodeid,$card,$port,"ethernet");
$switches{$switch} += $bw;
}
#
# Check to see if more than one switch was found among the member
# list, and if so, go through all the pairs
#
my @switches = keys %switches;
if (@switches > 1) {
for (my $i = 0; $i < (@switches -1); $i++) {
my $switch1 = $switches[$i];
my $switch2 = $switches[$i+1];
my $bw = $switches{$switch1};
if ($switches{$switch2} < $bw) {
$bw = $switches{$switch2};
}
#
# The trunk link could be listed in either order
#
if ($interconnects{"$switch1:$switch2"}) {
$interconnects{"$switch1:$switch2"} -= $bw;
} elsif ($interconnects{"$switch2:$switch1"}) {
$interconnects{"$switch2:$switch1"} -= $bw;
}
}
}
}
}
if (! defined($component_name)) {
# TODO: Figure out how to actually add interconnect interfaces rather than
# just having them be (null).
foreach $interconnect (keys(%interconnects)) {
($src,$dst) = split(":",$interconnect);
my $speed = $interconnects{$interconnect};
# This is really dumb - BigInts like to print out with a leading '+',
# which we don't want. Stript it off.
$speed =~ s/^\+|-//;
print_named_link("link-$interconnect",
$src, "(null)",
$dst, "(null)",
$speed, 0, 0, "ethernet");
}
}
#
# Fake switch. Hardwired for now.
#
my @wireless_protos = ("80211", "80211a", "80211b", "80211g", "flex900");
my $fake_switch = "airswitch";
my @fake_switch_types = map("*$_:*", @wireless_protos);
if (! defined($component_name)) {
print_node($fake_switch, \@fake_switch_types, [], [], undef, [], undef,
undef, undef);
foreach my $interface (keys(%interfacetypes)) {
my ($node,$card,$port) = split(":", $interface);
next
if (!defined($nodes{$node}));;
my $type = $interfacetypes{$interface};
next
if (!defined($interfaceprotocols{$type}));
my @protos = @{ $interfaceprotocols{$type} };
my $iface = get_iface($node,$card,$port);
#
# Get the intersection of the protocols supported by this interface, and
# the wireless protocols we know about
#
my (%union, %intersection);
foreach $proto (@protos, @wireless_protos) {
$union{$proto}++ && $intersection{$proto}++;
}
my @intersection = keys %intersection;
#
# Skip this interface if it speaks no wireless protocols
#
next unless @intersection;
#
# Find the max bandwidth supported by any of the wireless protocols
# supported by this interface
#
my $max_bw = 0;
foreach my $proto (@intersection) {
my $ifacebw = get_ifacebw($node,$card,$port,$proto);
if ($ifacebw > $max_bw) {
$max_bw = $ifacebw;
}
}
print_simple_link($node, $iface,
$fake_switch, "(null)",
$max_bw, 0, 0, @intersection);
}
}
print_footer();
exit(0);
# Print out links
sub get_iface {
($node,$card,$port) = @_;
if (defined($interfacemap{"$node:$card:$port"})) {
if ($interfacemap{"$node:$card:$port"} eq "") {
return "(null)";
} else {
return $interfacemap{"$node:$card:$port"};
}
} else {
# shark hack
if ($node =~ /^sh/) {
return "eth0";
} else {
return "(null)";
}
# end shark hack
}
};
# Find the bandwidth for an interface, when using the given protocol (which
# most of the time is ethernet).
sub get_ifacebw {
($node,$card,$port,$protocol) = @_;
if (defined($interfacetypes{"$node:$card:$port"})) {
my $bw = $interfacespeeds{$interfacetypes{"$node:$card:$port"}}{$protocol};
return $bw if defined( $bw );
}
return $default_switchport_speed;
}
sub get_ifaceswitch {
($node,$iface) = @_;
if (defined($interfaceswitches{"$node:$iface"})) {
return $interfaceswitches{"$node:$iface"};
} else {
return undef;
}
}
sub get_ifacecardport {
($node,$iface) = @_;
if (defined($interfacecardports{"$node:$iface"})) {
return @{$interfacecardports{"$node:$iface"}};
} else {
return ();
}
}
######################################################################
# Functions for printing XML
######################################################################
sub print_header {
if ($do_xml && !$genimode) {
print "\n";
print "\n";
} elsif ($do_xml && $genimode) {
print "\n";
print "\n";
}
}
sub print_footer {
if ($do_xml && !$genimode) {
print "\n";
} elsif ($do_xml && $genimode) {
print "\n";
}
}
# Special print function for switches.
sub print_switch
{
my $name = shift(@_);
my $uuid = shift(@_);
my $country = shift(@_);
my $latitude = shift(@_);
my $longitude = shift(@_);
my $interfaces = [];
if ($do_xml && $genimode)
{
push @$interfaces, "(null)";
}
# XXX
print_node($name, ["switch:1", "*lan:*"], [], [], $uuid, $interfaces,
$country, $latitude, $longitude);
}
sub print_node
{
my $name = shift(@_);
my $types = shift(@_);
my $features = shift(@_);
my $flags = shift(@_);
my $uuid = shift(@_);
my $interfaces = shift(@_);
my $country = shift(@_);
my $lat = shift(@_);
my $long = shift(@_);
if (!$do_xml) {
my $text = "node $name " .
join(" ", @$types) . " - " . join(" ", @$features) .
" - " . join(" ", @$flags);
print "$text\n";
} elsif ($genimode) {
# rspec format
print "\n";
# TODO: Virtualization type
print_node_types(@$types);
if ($nodetoavailable{$name}) {
print " true\n";
} else {
print " false\n";
}
if ($sharing_mode{$name}) {
print " false\n";
}
else {
print " true\n";
}
if (defined($lat) && defined($long)) {
# TODO: May not be a good default for country
if (!defined($country) || $country eq "") {
$country = "US";
}
print " \n";
}
print_node_interfaces($name, @$interfaces);
print "\n";
} else {
# ptop format
print "\n";
print_node_types(@$types);
print_node_flags(@$flags);
print_node_features(@$features);
print "\n";
}
}
# The order print_node_types(), print_node_features(),
# print_node_flags() must always be observed lest we break the schema.
sub print_node_types
{
my $i = 0;
for (; $i < scalar(@_); ++$i) {
my ($name, $count) = split(/:/, $_[$i], 2);
my $is_static = 0;
if ($name =~ /^\*/) {
$name = substr($name, 1);
$is_static = 1;
}
print " \n";
}
}
sub print_node_features
{
my $i = 0;
for (; $i < scalar(@_); ++$i) {
my ($name, $value) = split(/:/, $_[$i], 2);
my $flags = " ";
if ($value >= 1.0) {
$flags .= "";
}
if ($name =~ /^\?\+/) {
$flags .= "+";
$name = substr($name, 2);
}
elsif ($name =~ /^\*&/) {
$flags .= "FirstFree";
$name = substr($name, 2);
}
elsif ($name =~ /^\*!/) {
$flags .= "OnceOnly";
$name = substr($name, 2);
}
print " \n";
print " $name\n";
print " $value\n";
if ($flags ne " ") {
print $flags."\n";
}
print " \n";
}
}
sub print_node_flags
{
my $i = 0;
for (; $i < scalar(@_); ++$i) {
my ($name, $value) = split(/:/, $_[$i], 2);
if ($name eq "trivial_bw") {
print " $value\n";
}
elsif ($name eq "subnode_of") {
print " $value\n";
}
elsif ($name eq "unique") {
print " \n";
}
elsif ($name eq "disallow_trivial_mix") {
print " \n";
}
}
}
sub print_node_interfaces
{
my $nodeName = shift(@_);
my @interfaces = @_;
my $i = 0;
for (; $i < scalar(@interfaces); ++$i) {
my $name = $interfaces[$i];
my $urn = GeniHRN::GenerateInterface($OURDOMAIN, $nodeName, $name);
print " \n";
}
}
sub print_named_link_ptop
{
my $name = shift(@_);
my $source = shift(@_);
my $source_if = shift(@_);
my $dest = shift(@_);
my $dest_if = shift(@_);
my $bw = shift(@_);
my $delay = shift(@_);
my $loss = shift(@_);
my $proto_count = scalar(@_);
my $source_full = "$source:$source/$source_if";
my $dest_full = "$dest:$dest_if";
if ($source =~ /cisco/ && $dest =~ /cisco/)
{
$source_full = $source;
$dest_full = $dest;
}
print "link $name $source_full "
. "$dest_full $bw $delay $loss 1 " . join(" ", @_) . "\n";
}
sub print_named_link_xml
{
my $name = shift(@_);
my $source = shift(@_);
my $source_if = shift(@_);
my $dest = shift(@_);
my $dest_if = shift(@_);
my $bw = shift(@_);
my $delay = shift(@_);
my $loss = shift(@_);
my $proto_count = scalar(@_);
if ($genimode) {
print "\n";
print_interface($source, $source_if);
print_interface($dest, $dest_if);
} else {
print "\n";
print " \n";
print_interface_contents($source, $source_if);
print " \n";
print " \n";
print_interface_contents($dest, $dest_if);
print " \n";
}
print " $bw\n";
print " $delay\n";
print " $loss\n";
if ($genimode) {
my $i = 0;
for (; $i < $proto_count; ++$i) {
print " \n";
}
} else {
my $i = 0;
for (; $i < $proto_count; ++$i) {
print " " . $_[$i]
. "\n";
}
}
print "\n\n";
}
sub print_interface
{
my $node = shift(@_);
my $interface = shift(@_);
print " \n";
}
sub print_interface_contents
{
my $node = shift(@_);
my $interface = shift(@_);
print " $node\n";
print " $interface\n";
}
# Print a link with a unique name not necessarily related to source,
# dest, source_if, and dest_if.
sub print_named_link
{
if (!$do_xml) {
print_named_link_ptop(@_);
} elsif ($do_xml) {
print_named_link_xml(@_);
}
}
# Print a link where the name is just a recapitulation of the source
# and destination node and interface names.
sub print_simple_link
{
print_named_link("link-".$_[0].":".$_[1]."-".$_[2].":".$_[3], @_);
}