#!/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 $default_long = undef; TBGetSiteVar('general/default_longitude', \$default_long); my $default_lat = undef; TBGetSiteVar('general/default_latitude', \$default_lat); my $default_country = undef; TBGetSiteVar('general/default_country', \$default_country); 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)); $fake_inet_switch = "internet"; $fake_inet_iface = "(null)"; if ($genimode) { $fake_inet_iface = "border"; } print_header(); my %nodetointerface; my %interfaceroles = (); my %interfacetypes = (); my %interfaceips = (); # Read interfaces my $result = DBQueryFatal("SELECT node_id,card,port,iface,interface_type,role,IP" . " from interfaces " . ($genimode ? "where role!='gw'" : "")); while (($node,$card,$port,$iface,$type,$role,$ip) = $result->fetchrow_array) { push @{ $nodetointerface{"$node"} }, $iface; $interfacemap{"$node:$card:$port"} = $iface; if ((defined $type) && ($type ne "")) { $interfacetypes{"$node:$card:$port"} = $type; } if ((defined $role) && ($role ne "")) { $interfaceroles{"$node:$iface"} = $role; } if ((defined $ip) && ($ip ne "")) { $interfaceips{"$node:$iface"} = $ip; } } my %nodetouuid; my %nodetoavailable; $result = DBQueryFatal("SELECT n.node_id, n.eventstate, n.role, n.uuid, " . "nt.isremotenode, " . "dedicated_wa_types.attrvalue, b.erole, " . "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, $erole, $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($erole) && $erole eq "sharedhost" && $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'"; } # # For subOS support (i.e., vnode OSes running atop vhost OSes), we have to # check both the subosid and all the parent_osid it can run on. # my $subosidquery = "select o.osid,o.parent_osid from os_submap as o " . "left join osidtoimageid as oi1 on o.osid = oi1.osid " . "left join osidtoimageid as oi2 on o.parent_osid = oi2.osid " . "left join images as i1 on oi1.imageid = i1.imageid ". "left join images as i2 on oi2.imageid = i2.imageid ". "where (i1.global = 1"; if ($pid) { $subosidquery .= " or i1.pid='$pid'"; } $subosidquery .= ") and (i2.global = 1"; if ($pid) { $subosidquery .= " or i2.pid='$pid'"; } $subosidquery .= ")"; my %node_type_osids; my %osid_node_types; my %osid_subosids; 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]; } } # # XXX Note below that for now, subosids cannot redirect to other subosids. # $result = DBQueryFatal($subosidquery); while (my ($subosid,$osid) = $result->fetchrow()) { if ($osid_subosids{$osid}) { push @{$osid_subosids{$osid}}, $subosid; } else { $osid_subosids{$osid} = [$subosid]; } } # # 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.erole='sharedhost' && ". " 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"); # Add any subOSes the shared node osid can support if (defined($osid_subosids{$osid})) { push (@features, map "OS-$osid-$_:0", @{$osid_subosids{$osid}}); } } elsif ($node_type_osids{$type}) { # # Add in features for all of the OSes that this node (as # evidenced by its type) can support # foreach my $o1 (@{$node_type_osids{$type}}) { push @features, "OS-$o1:0"; foreach my $o2 (@{$osid_subosids{$o1}}) { push @features, "OS-$o1-$o2:0"; } } } 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); } my @inet_protos = ("ipv4"); if (($widearea && ! defined($component_name)) || $genimode) { # # 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 @types = map("*$_:*", @inet_protos); print_node($fake_inet_switch, \@types, [], [], undef, [], undef, undef, undef); } # # 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)) { # # 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 && ! $genimode) { print_simple_link($physnode, $iface, $fake_inet_switch, $fake_inet_iface, 100000, 0, 0, @inet_protos); } # Insert into nodes array in case there are wires entries. $nodes{$physnode} = $ptype; } } if ($genimode) { foreach $key (keys %interfaceroles) { if (is_public_interface($key)) { $key =~ /^([^:]+):([^:]+)$/; my $node = $1; my $iface = $2; if (defined($nodes{$node})) { print_simple_link($node, $iface, $fake_inet_switch, $fake_inet_iface, 100000, 0, 0, @inet_protos); } } } } # 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 (! defined($lat) || ! defined($long)) { $lat = $default_lat; $long = $default_long; } if (! defined($country)) { $country = $default_country; } 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 ($name eq $fake_inet_switch) { print " \n"; print " \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_flags(@$flags); 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 .= " violatable=\"true\" "; } if ($name =~ /^\?\+/) { $flags .= " local_operator=\"+\" "; $name = substr($name, 2); } elsif ($name =~ /^\*&/) { $flags .= " global_operator=\"FirstFree\" "; $name = substr($name, 2); } elsif ($name =~ /^\*!/) { $flags .= " global_operator=\"OnceOnly\" "; $name = substr($name, 2); } print " \n"; } } sub print_node_flags { my $i = 0; for (; $i < scalar(@_); ++$i) { my ($name, $value) = split(/:/, $_[$i], 2); if ($name eq "trivial_bw" && ! $genimode) { print " $value\n"; } elsif ($name eq "subnode_of") { if ($genimode) { $value = GeniHRN::Generate($OURDOMAIN, "node", $value); } print " $value\n"; } elsif ($name eq "unique" && ! $genimode) { print " \n"; } elsif ($name eq "disallow_trivial_mix") { print " \n"; } } } sub make_ip { my $in = shift(@_); my @octets = split(/\./, $in); my $result = 0; my $i = 0; for (; $i < scalar(@octets); ++$i) { $result = (($result << 8) | $octets[$i]); } return $result; } sub is_routable { my @privateIps = (make_ip("10.0.0.0"), make_ip("172.16.0.0"), make_ip("192.168.0.0")); my @privateMasks = (8, 12, 16); my $in = shift(@_); my $result = 0; if (defined($in) && $in =~ /\d+\.\d+\.\d+\.\d+/) { $result = 1; my $ip = make_ip($in); my $i = 0; for ($i = 0; $i < scalar(@privateIps); ++$i) { my $mask = (0xffffffff << (32 - $privateMasks[$i])); if (($ip & $mask) == ($privateIps[$i] & $mask)) { $result = 0; } } } return $result; } sub is_public_interface { my $key = shift(@_); my $result = 0; if (exists($interfaceroles{$key}) && exists($interfaceips{$key})) { if ($interfaceroles{$key} eq "ctrl" && is_routable($interfaceips{$key})) { $result = 1; } } return $result; } 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], @_); }