Commit 9b895f95 authored by Leigh B Stoller's avatar Leigh B Stoller

New script to generate SVG images of the topology (and thumbnails).

parent eabb41ae
#
# Copyright (c) 2000-2004 University of Utah and the Flux Group.
# Copyright (c) 2000-2013 University of Utah and the Flux Group.
#
# {{{EMULAB-LICENSE
#
......@@ -30,7 +30,7 @@ include $(OBJDIR)/Makeconf
BIN_SCRIPTS = dbvistopology
LIBEXEC_SCRIPTS = webvistopology webfloormap
LIBEXEC_VIS = prerender render prerender_all floormap
LIBEXEC_VIS = prerender render prerender_all floormap svgrender
#
# Force dependencies on the scripts so that they will be rerun through
......
#!/usr/bin/perl -wT
#
# Copyright (c) 2000-2003, 2006 University of Utah and the Flux Group.
# Copyright (c) 2000-2013 University of Utah and the Flux Group.
#
# {{{EMULAB-LICENSE
#
......@@ -35,7 +35,7 @@ sub usage()
"Usage: dbvistoplogy [-o <outputfile>] [-t <thumbsize> ] [-z <zoomfactor>] [-d <detaillevel>] <pid> <eid>\n";
exit(-1);
}
my $optlist = "o:z:d:t:";
my $optlist = "o:z:d:t:xs:";
#
# Configure variables
......@@ -145,18 +145,18 @@ if (! ExpState($pid, $eid)) {
die("*** $0:\n".
" No such experiment $pid/$eid\n");
}
#
# Verify that this person is allowed to look at experiment.
#
if (! TBExptAccessCheck($UID, $pid, $eid, TB_EXPT_READINFO)) {
die("*** $0:\n".
" You do not have permission to view experiment $pid/$eid\n");
}
my $args = "";
if (defined($options{"x"})) {
$args .= "-x ";
}
if (defined($options{"s"})) {
my $uid = $options{"s"};
if ($uid =~ /^([-\w]+)$/) {
$uid = $1;
}
$args .= "-s $uid ";
}
if (defined($zoom)) {
$args .= "-z $zoom ";
......
#!/usr/bin/perl -w
#
# Copyright (c) 2000-2007 University of Utah and the Flux Group.
# Copyright (c) 2000-2013 University of Utah and the Flux Group.
#
# {{{EMULAB-LICENSE
#
......@@ -50,7 +50,15 @@ sub usage {
die "Usage:\nrender [-v] [-t <thumbsize>] [-z <zoomfactor>] [-d <detaillevel>] <pid> <eid>\n";
}
my $optlist = "z:d:vt:";
#
# Look for -x option, and chain to SVG rendering.
#
if (grep {$_ eq "-x"} @ARGV) {
exec "$TB/libexec/vis/svgrender", @ARGV;
die("render: Could not exec svgrender: $!");
}
my $optlist = "z:d:vt:x";
if (! getopts($optlist, \%options)) { usage; }
if (@ARGV != 2) { usage; }
......
#!/usr/bin/perl -w
#
# Copyright (c) 2000-2013 University of Utah and the Flux Group.
#
# {{{EMULAB-LICENSE
#
# This file is part of the Emulab network testbed software.
#
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General Public
# License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this file. If not, see <http://www.gnu.org/licenses/>.
#
# }}}
#
use English;
use Getopt::Std;
use strict;
#
# Setup GateOne stuff for in browser SSH client.
#
sub usage()
{
print STDERR "Usage: render [-v] [-s <uid>] [-t <thumbsize>] [-z <zoomfactor>] ".
"[-d <detaillevel>] <pid> <eid>\n";
exit(-1);
}
my $optlist = "z:d:vt:xs:";
my $debug = 0;
my $regen = 0;
my $zoom = 2;
my $detail = 0;
my $sshuser = undef;
my $thumbnail = 0;
#
# Configure variables
#
my $TB = "@prefix@";
my $ICONDIR = "$TB/www";
my $OURDOMAIN = "@OURDOMAIN@";
# Locals
my %nodes = ();
my %links = ();
my %lans = ();
my $noNodes = 0;
my ($min_x,$min_y, $max_x, $max_y);
#
# Testbed Support libraries
#
use lib "@prefix@/lib";
use libdb;
use libtestbed;
use Experiment;
#
# Function prototypes
#
sub fatal($);
sub dprint($);
sub ThumbNail();
sub NormalSize();
my %options = ();
if (! getopts($optlist, \%options)) {
usage();
}
if (@ARGV != 2) { usage(); }
if (defined($options{"v"})) {
$debug++;
}
if (defined($options{"s"})) {
$sshuser = $options{"s"};
}
if ( defined($options{"z"} ) ) {
my $zf = $options{"z"};
if ($zf =~ /^([\.0-9]+)/) {
$zoom = $1;
} else {
fatal("Bad argument to -z; must be float.");
}
}
if (defined($options{"d"})) {
my $df = $options{"d"};
if ($df =~ /^([0-9]+)/) {
$detail = $1;
} else {
fatal("Bad argument to -d; must be non-negative integer.");
}
}
if (defined($options{"t"})) {
my $tf = $options{"t"};
if ($tf =~ /^([0-9]+)/) {
$thumbnail = $1;
} else {
die("Bad argument to -t; must be non-negative integer.");
}
}
my $pid = $ARGV[0];
my $eid = $ARGV[1];
my $experiment = Experiment->Lookup($pid, $eid);
if (!defined($experiment)) {
fatal("No such experiment $pid/$eid!");
}
# Get node list.
# (left join info from vis_nodes; could also left join virt_lans,
# but there's no reason to since lan info shows up on the link,
# not the LAN node.)
my $result = DBQueryFatal("SELECT vis.vname, vis.vis_type, vis.x, vis.y, ".
" virt.type,r.node_id,n.sshdport,np.node_id " .
"FROM vis_nodes as vis " .
"LEFT JOIN virt_nodes as virt on ".
" vis.vname=virt.vname and vis.pid=virt.pid and".
" vis.eid=virt.eid ".
"left join reserved as r on ".
" r.exptidx=vis.exptidx and r.vname=vis.vname ".
"left join nodes as n on ".
" n.node_id=r.node_id ".
"left join nodes as np on ".
" np.node_id=n.phys_nodeid ".
"WHERE vis.pid='$pid' AND vis.eid='$eid'");
while (my ($name, $vis_type, $vis_x, $vis_y, $virt_type,
$node_id, $sshdport, $physnode) = $result->fetchrow) {
dprint "NODE $name $vis_type $vis_x $vis_y\n";
$nodes{$name}{"type"} = $vis_type; # vis type, not hwtype.
$nodes{$name}{"x"} = $vis_x;
$nodes{$name}{"y"} = $vis_y;
# what appears in label depends on the detail level.
my $label = $name;
if ($detail > 0) {
if (defined($virt_type)) {
$label .= "(" . $virt_type . ")";
}
}
$nodes{$name}{"label"} = $label;
if (!(defined $min_x) || $vis_x < $min_x) { $min_x = $vis_x; }
if (!(defined $min_y) || $vis_y < $min_y) { $min_y = $vis_y; }
if (!(defined $max_x) || $vis_x > $max_x) { $max_x = $vis_x; }
if (!(defined $max_y) || $vis_y > $max_y) { $max_y = $vis_y; }
if (defined($sshuser) && defined($node_id)) {
$nodes{$name}{"pnode_id"} = $physnode;
$nodes{$name}{"sshdport"} = $sshdport
if ($node_id ne $physnode);
}
}
if (!(defined $min_x)) {
# no nodes.
if ($thumbnail != 0) {
$max_x = 64;
$max_y = 64;
}
$noNodes = 1;
# die "No visible nodes in '$pid/$eid', or experiment does not exist.\n";
} else {
dprint "min x,y = $min_x, $min_y\n" .
"max x,y = $max_x, $max_y\n";
# adjust each node's position so topleftmost node is at (60,60) * $zoom.
foreach my $i (keys %nodes) {
$nodes{$i}{"x"} = (($nodes{$i}{"x"} - $min_x) * $zoom) + 60;
$nodes{$i}{"y"} = (($nodes{$i}{"y"} - $min_y) * $zoom) + 60;
}
# adjust max x,y appropriately.
$max_x = (($max_x - $min_x) * $zoom) + 120;
$max_y = (($max_y - $min_y) * $zoom) + 120;
}
# get vlan list.
$result = DBQueryFatal("SELECT vname, vnode, vport, ip, ".
"delay, bandwidth, lossrate, " .
"rdelay, rbandwidth, rlossrate, " .
"member FROM virt_lans " .
"WHERE pid='$pid' AND eid='$eid'");
while (my ($vname, $vnode, $vport, $ip, $delay, $bandwidth,
$lossrate, $rdelay, $rbandwidth,
$rlossrate, $member) = $result->fetchrow) {
$member =~ s/\:.*//;
$lans{$vname}{$member}{"delay"} = $delay;
$lans{$vname}{$member}{"bw"} = $bandwidth;
$lans{$vname}{$member}{"loss"} = $lossrate;
$lans{$vname}{$member}{"rdelay"} = $rdelay;
$lans{$vname}{$member}{"rbw"} = $rbandwidth;
$lans{$vname}{$member}{"rloss"} = $rlossrate;
# what appears in label depends on the detail level.
if ($detail > 0) {
if (defined($ip)) {
$nodes{$vnode}{"label"} .= " " . $ip;
}
}
}
foreach my $lan (keys %lans) {
if ((keys %{$lans{$lan}}) == 2) {
# amalgamate into 2 member link.
my $a = (keys %{$lans{$lan}})[0];
my $b = (keys %{$lans{$lan}})[1];
my $delaya2b = $lans{$lan}{$a}{"delay"} + $lans{$lan}{$b}{"rdelay"};
my $delayb2a = $lans{$lan}{$b}{"delay"} + $lans{$lan}{$a}{"rdelay"};
my $bwa2b = min( $lans{$lan}{$a}{"bw"}, $lans{$lan}{$b}{"rbw"} );
my $bwb2a = min( $lans{$lan}{$b}{"bw"}, $lans{$lan}{$a}{"rbw"} );
my $lossa2b = combineloss( $lans{$lan}{$a}{"loss"}, $lans{$lan}{$b}{"rloss"} );
my $lossb2a = combineloss( $lans{$lan}{$b}{"loss"}, $lans{$lan}{$a}{"rloss"} );
my $desc = "";
if ($detail > 1) {
$desc = gendesc( $delaya2b, $delayb2a, $bwa2b, $bwb2a, $lossa2b, $lossb2a );
}
# create the link
dprint "LINK $a $b '$desc'\n";
$links{"$a $b"}{"label"} = $desc;
} else {
# add links from node to LAN.
unless (exists $nodes{$lan} && ($nodes{$lan}{"type"} eq "lan")) {
warn "No LAN $lan!";
}
foreach my $node (keys %{$lans{$lan}}) {
my $delayin = $lans{$lan}{$node}{"delay"};
my $delayout = $lans{$lan}{$node}{"rdelay"};
my $bwin = $lans{$lan}{$node}{"bw"};
my $bwout = $lans{$lan}{$node}{"rbw"};
my $lossin = $lans{$lan}{$node}{"loss"};
my $lossout = $lans{$lan}{$node}{"rloss"};
my $desc = "";
if ($detail > 1) {
$desc = gendesc( $delayin, $delayout, $bwin, $bwout, $lossin, $lossout );
}
# create a link from node to lan.
$links{"$node $lan"}{"label"} = $desc;
dprint "LINK $node $lan '$desc'\n";
}
}
}
# if $embiggen == 1, node fonts will be rendered bigger.
# if $embiggen == 2, node and link fonts will be rendered bigger.
my $embiggen = 0;
if ($zoom >= 1.5) { $embiggen = 1; }
if ($zoom >= 1.75) { $embiggen = 2; }
dprint "Image size = $max_x x $max_y\n";
print "<svg style='display: block; margin: 0 auto' ". ($thumbnail ?
"height='160' width='160' " :
"height='$max_y' width='$max_x'") .
" xmlns='http://www.w3.org/2000/svg' ".
" xmlns:svg='http://www.w3.org/2000/svg' ".
" xmlns:xlink='http://www.w3.org/1999/xlink'>\n";
if ($thumbnail) {
ThumbNail();
}
else {
NormalSize();
}
print "</svg>\n";
exit(0);
sub ThumbNail()
{
# Thumbnails are drawn similarly to full views,
# but there are enough differences to warrant separate code.
foreach my $i (keys %links) {
# get endpoint names from link name
my ($a, $b) = ($i =~ /(\S+)\s(\S+)/);
# get endpoint node location
my ($x1, $y1) = ($nodes{ $a }{"x"}, $nodes{ $a }{"y"});
my ($x2, $y2) = ($nodes{ $b }{"x"}, $nodes{ $b }{"y"});
# scale down to thumbnail size; 'ceil' prevents subpixel errors,
# though it is probably not needed for lines.
$x1 = ceil(($x1 * $thumbnail) / $max_x);
$y1 = ceil(($y1 * $thumbnail) / $max_y);
$x2 = ceil(($x2 * $thumbnail) / $max_x);
$y2 = ceil(($y2 * $thumbnail) / $max_y);
print "<line style='fill: black; fill-opacity: 1.0; ".
"stroke: black; ".
"stroke-opacity: 1.0; stroke-width: 1; stroke-linecap: square' ".
"x1='$x1' x2='$x2' y1='$y1' y2='$y2' />\n";
}
foreach my $i (keys %nodes) {
# get node position and type.
my ($x, $y) = ($nodes{$i}{"x"}, $nodes{$i}{"y"});
my $type = $nodes{$i}{"type"};
# scale down to thumbnail size; 'ceil' prevents subpixel errors.
# 'ceil' is important, since if $x has a fractional part as well as $size,
# when they're added together, they may produce an additional pixel of
# width or height on some of the nodes; such an error is surprisingly noticable.
$x = ceil(($x * $thumbnail) / $max_x);
$y = ceil(($y * $thumbnail) / $max_y);
my $size = ceil(min( min( 16 * $thumbnail /
$max_x, 16 * $thumbnail / $max_y ),
$thumbnail / 16));
if ($type eq "special") {
print "<rect height='$size' style='fill: darkred; ".
"fill-opacity: 1.0; ".
"stroke: black; stroke-opacity: 1.0; stroke-width: 2' ".
"width='$size' x='$x' y='$x' />\n";
}
elsif ($type eq "lan") {
print "<circle cx='$x' cy='$y' r='$size' ".
"style='fill: blue; fill-opacity: 1.0; stroke: black; ".
"stroke-opacity: 1.0; stroke-width: 2' />\n";
}
elsif ($type eq "node") {
# x,y,size in SVG coords.
$x -= $size;
$y -= $size;
$size = $size * 2;
print "<rect height='$size' style='fill: palegreen; ".
"fill-opacity: 1.0; ".
"stroke: black; stroke-opacity: 1.0; stroke-width: 2' ".
"width='$size' x='$x' y='$y' />\n";
}
}
}
sub NormalSize()
{
foreach my $i (keys %links) {
# get endpoint names from link name
my ($a, $b) = ($i =~ /(\S+)\s(\S+)/);
# get endpoint node location
my ($x1, $y1) = ($nodes{ $a }{"x"}, $nodes{ $a }{"y"});
my ($x2, $y2) = ($nodes{ $b }{"x"}, $nodes{ $b }{"y"});
print "<g>\n";
print "<line style='fill: black; fill-opacity: 1.0; ".
"stroke: black; ".
"stroke-opacity: 1.0; stroke-width: 1; stroke-linecap: square' ".
"x1='$x1' x2='$x2' y1='$y1' y2='$y2' />\n";
# only render label if there _is_ a label.
if (!exists $links{$i}{"label"}) { goto skip1; }
# calculate midpoint of link line
my ($x, $y) = ( ($x1 + $x2) / 2, ($y1 + $y2) / 2 );
# split lines by space
my @lines = split " ", $links{$i}{"label"};
# center vertically
$y -= (0.5 * (@lines * 6));
# Same as above.
my $fontSize = ($embiggen ? 12 : 10);
my $linenum = 0;
foreach my $j (@lines) {
my $xpos = $x - ((length($j) - 0.5) * ($fontSize / 2)) / 2;
my $ypos = $y + $fontSize;
print "<text fill='black' font='Helvetica' ".
"font-size='$fontSize' ".
"font-weight='bold' x='$xpos' y='$ypos'>$j</text>\n";
$y += $fontSize;
}
skip1:
print "</g>\n";
}
foreach my $i (keys %nodes) {
# get node position and type.
my ($x, $y) = ($nodes{$i}{"x"}, $nodes{$i}{"y"});
my $size = 16;
my $type = $nodes{$i}{"type"};
print "<g>\n";
if ($type eq "lan") {
print "<circle cx='$x' cy='$y' r='$size' ".
"style='fill: blue; fill-opacity: 1.0; stroke: black; ".
"stroke-opacity: 1.0; stroke-width: 2' />\n";
}
elsif ($type eq "node") {
# x,y,size in SVG coords.
my $sx = $x - $size;
my $sy = $y - $size;
my $ss = $size * 2;
if (exists($nodes{"$i"}{"pnode_id"})) {
my $physnode = $nodes{"$i"}{"pnode_id"};
my $sshdport = "";
# Not needed on plain phys nodes ...
$sshdport = ":" . $nodes{"$i"}{"sshdport"}
if (exists($nodes{"$i"}{"sshdport"}));
my $url =
"ssh://${sshuser}\@${physnode}.${OURDOMAIN}${sshdport}/";
print "<a xlink:href='$url'>";
}
print "<rect style='fill: palegreen; ".
"fill-opacity: 1.0; ".
"stroke: black; stroke-opacity: 1.0; stroke-width: 2' ".
"width='$ss' height='$ss' x='$sx' y='$sy' />\n";
if (exists($nodes{"$i"}{"sshdport"})) {
print "</a>\n";
}
}
# only render label if there _is_ a label.
if (!exists $nodes{$i}{"label"}) { goto skip2; }
my $nm = $nodes{$i}{"label"};
my @lines = ();
# append space, so same patterns work on the last word.
$nm .= " ";
# first word (i.e., node name)
# always gets its own line.
$nm =~ s/^(\S+)\s+//;
push @lines, $1;
# greedy line breaking (split works for links, but
# isn't quite sexy enough for nodes.):
while ($nm ne "") {
if ($nm =~ s/^(.{1,12})\s+//) {
# if the next n words (plus the space between them)
# total less than 13 characters, use that as a line.
push @lines, $1;
} elsif ($nm =~ s/^(\S+)\s+//) {
# if the next word is longer than 12, we fall through to,
# this which uses that word as a line.
push @lines, $1;
} else {
# if neither of the above applies,
# we abort the loop, and add a complaint to the string list.
push @lines, "ERROR";
last;
}
}
# now that lines contains each line of the node caption,
# render it.
my $linenum = 0;
foreach my $j (@lines) {
if ($linenum++ == 0) {
# The first line, so we render it bigger.
my $fontSize = ($embiggen ? 13 : 12);
my $xpos = $x - ((length($j) - 0.5) * ($fontSize / 2)) / 2;
my $ypos = $y + $size + $fontSize;
print "<text fill='black' font='Helvetica' ".
"font-size='$fontSize' ".
"font-weight='bold' x='$xpos' y='$ypos'>$j</text>\n";
$y += $fontSize;
}
else {
# Not the first line, so we render it smaller.
my $fontSize = ($embiggen ? 12 : 10);
my $xpos = $x - ((length($j) - 0.5) * ($fontSize / 2)) / 2;
my $ypos = $y + $size + $fontSize;
print "<text fill='black' font='Helvetica' ".
"font-size='$fontSize' ".
"font-weight='bold' x='$xpos' y='$ypos'>$j</text>\n";
$y += $fontSize;
}
} # foreach $j (@lines)
skip2:
print "</g>\n";
}
}
# functions to generate labels for links on $detail > 0
sub reportbw {
my $bandwidth = shift;
if ($bandwidth >= 5000000) {
return sprintf( "%.0f", ($bandwidth / 1000000) ) . "Gb";
} elsif ($bandwidth >= 1000000) {
return sprintf( "%.1f", ($bandwidth / 1000000) ) . "Gb";
} elsif ($bandwidth >= 5000) {
return sprintf( "%.0f", ($bandwidth / 1000) ) . "Mb";
} elsif ($bandwidth >= 1000) {
return sprintf( "%.1f", ($bandwidth / 1000) ) . "Mb";
} elsif ($bandwidth >= 5) {
return sprintf( "%.0f", $bandwidth ) . "kb";
} else {
return sprintf( "%.1f", $bandwidth ) . "kb";
}
}
sub reportdelay {
my $delay = shift;
if ($delay == 0) { return "0msec"; }
if ($delay >= 10) {
return sprintf( "%.0f", $delay ) . "msec";
} else {
return sprintf( "%.1f", $delay ) . "msec";
}
}
sub reportloss {
my $losspct = shift;
$losspct *= 100;
if ($losspct < 0.0001) { return "0\%loss"; }
if ($losspct > 5) {
return sprintf( "%.0f", $losspct ) . "\%loss";
} elsif ($losspct > 1) {
return sprintf( "%.1f", $losspct ) . "\%loss";
} elsif ($losspct > 0.1) {
return sprintf( "%.2f", $losspct ) . "\%loss";
} else {
return sprintf( "%.3f", $losspct ) . "\%loss";
}
}
sub gendesc {
my ($delay0, $delay1, $bw0, $bw1, $loss0, $loss1) = @_;
my $desc = "";
if ($bw0 == $bw1) {