ptopgen.in

#!/usr/bin/perl -w

#
# EMULAB-COPYRIGHT
# Copyright (c) 2000-2008 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);

sub usage()
{
    print("Usage: ptopgen [-v] [-s switch] [-p pid [-e eid]] [-m factor] " .
	  "[-n c/e] [-x] [-g]\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".
	  "       -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");
        exit(-1);
}

my $optlist = "s:e:m:vp:rSan:c:uxg";
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 $cmuuid = TBGetSiteVar('protogeni/cm_uuid');

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 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 $DEADPID = NODEDEAD_PID();
my $DEADEID = NODEDEAD_EID();

my $pid;
my $exempt_eid;
my $switchtouse;

#
# 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{"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));
}
if (defined($options{"x"})) {
    $genimode = 1
	if (defined($options{"g"}));
    $do_xml = 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");
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, " .
		       "b.node_id, nt.isremotenode, " .
		       "dedicated_wa_types.attrvalue " .
		       "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, $reserved, $isremotenode,
	$wa_attrvalue) = $result->fetchrow_array) {
    $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 $isfree = !$islocal || (! defined($reserved) && $isup);
    $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->{'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;
$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)) {
    print_switch($switchtouse);
    $switches{$switchtouse} = 1;
}
else {
    $result =
	DBQueryFatal("select node_id,uuid from nodes ".
		     "where role='testswitch' or role='widearea_switch'");

    while (($switch, $uuid) = $result->fetchrow_array) {
	print_switch($switch, $uuid);
	$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 genimode exclude nodes with exclusion attribute.
if ($genimode) {
    $free_condition = "($free_condition and ".
	"(nat.attrvalue is null or nat.attrvalue=0))";
}

# If the user wants all nodes, we consider everything to be free (this
# overrides the other possible free conditions
if ($allnodes) {
    $free_condition = "1";
}

$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 ".
		 "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 nat on ".
		 "     nat.node_id=a.node_id and ".
		 "     nat.attrkey='protogeni_exclude' ".
		 "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 ".
		 "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) =
       $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;
    $node_uuids{$node} = $uuid;

    if ($reserved) {
	$is_reserved{$node} = 1;
    } else {
	$is_reserved{$node} = 0;
    }

    $is_prereserved{$node} = $prereserved;

    $curr_state{$node} = $eventstate;
    $curr_batt{$node} = $battery_perc;
}

#
# 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 = $node_uuids{$node};
    
    my @types = ("$type:1");
    my @features;
    my @flags;
    my $needvirtgoo = 0;

    # 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";
    }

    #
    # 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 features for all of the OSes that this node (as evidenced by its
    # type) can support
    #
    if ($node_type_osids{$type}) {
	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}}) {
	    # 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}";
    }

    my @parse_features = split(" ", join(" ", @features));
    print_node($node, \@types, \@parse_features, \@flags, $uuid,
	       $nodetointerface{$node});
}

#
# 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) {
    #
    # 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, []);
    
    #
    # 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,".
                     "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 ".
		     "        dedicated_wa_types.attrvalue is NULL)");
    
    while (($physnode,$ptype,$status,$mpid,$meid,$site,$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});

        #
        # 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} && (!defined($IP) || $IP eq ""));

    $interfacecardports{"$node:$iface"} = [$card,$port];
}

$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}))) {

        
        # 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";

	    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;
		}
	    }
	}
    }
}

# 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";
if (!$genimode) {
    my @fake_switch_types = map("*$_:*", @wireless_protos);
    print_node($fake_switch, \@fake_switch_types, [], [], 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"})) {
	return $interfacespeeds{$interfacetypes{"$node:$card:$port"}}{$protocol};
    }
    else {
	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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
	print "<ptop testbed=\"@THISHOMEBASE@\" "
	    . "xmlns=\"http://emulab.net/resources/ptop/0.1\">\n";
    } elsif ($do_xml && $genimode) {
	print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
	print "<rspec xmlns=\"http://www.protogeni.net/resources/rspec/0.1\" ";
	print "type=\"advertisement\" ";