Commit 43c6b0aa authored by Christopher Alfeld's avatar Christopher Alfeld
Browse files

assign_wrapper - This is a PERL replacement for assign.tcl. It adds

LAN support, cleans up the code, and is generally a nicer program.  It also
now supports a -v option which will provide lots of debugging output.

postassign - This should be called after assign_wrapper has finished and
the resulting nodes reserved.  It will updated the delays table and the
vname column of reserved.

assign.tcl - Replaced by assign_wrapper.

Note on placement: Both of these programs should end up in libexec.
parent 16ad6a20
#!/usr/local/bin/tclsh
# This program needs to:
#
# 1) Extract the topology section from the specificed IR file and translate
# into a top file.
#
# 2) Run assign on the top file and testbed.ptop.
#
# 3) Translate the results into the virtual section and apprend to the IR.
#
# 4) Cross reference with macs.txt and generate the VLAN section.
# XXX - this is rather hackish right now. This should be rewritten using
# irlib when, if ever, that is written.
if {[file dirname [info script]] == "."} {
set updir ".."
} else {
set updir [file dirname [file dirname [info script]]]
}
if {[file exists $updir/../assign/assign]} {
set assign "$updir/../assign/assign"
} else {
set assign "$updir/../assign"
}
load /usr/testbed/lib/sql.so
set DB [sql connect]
sql selectdb $DB tbdb
set maxrun 5
set delaythresh .25
if {[llength $argv] != 2} {
puts stderr "Syntax: assign <ir> <ptop>"
exit 1
}
set testbed [lindex $argv 1]
set irfile [lindex $argv 0]
# Generate top file.
set fp [open $irfile "r"]
proc readto {fp s} {
while {[gets $fp line] >= 0} {
# ignore comments
if {[regexp "^\#" $line] == 1} {continue}
if {$line == {}} {continue}
if {$line == $s} {return}
}
error "$s not found"
}
puts "Reading virtual topology"
readto $fp "START topology"
# XXX: we ignore lans for now.
readto $fp "START nodes"
# nodes is an array of nodes with contents of link list.
while {[gets $fp line] >= 0} {
if {[regexp "^\#" $line] == 1} {continue}
if {$line == {}} {continue}
if {$line == "END nodes"} {break}
set nodes([lindex $line 0]) [lrange $line 1 end]
}
readto $fp "START links"
# XXX: we ignore ports for now.
while {[gets $fp line] >= 0} {
if {[regexp "^\#" $line] == 1} {continue}
if {$line == {}} {continue}
if {$line == "END links"} {break}
set links([lindex $line 0]) [lrange $line 1 end]
}
readto $fp "START lans"
while {[gets $fp line] >= 0} {
if {[regexp "^\\#" $line] == 1} {continue}
if {$line == {}} {continue}
if {$line == "END lans"} {break}
set lans([lindex $line 0]) [lrange $line 1 end]
}
# close the ir for now
close $fp
# now we need to generate a top file.
set tmpfile "/tmp/[pid].top"
puts "Writing topfile ($tmpfile)"
set topfp [open $tmpfile w]
# translate lans into nodes and links
foreach lan [array names lans] {
set laninfo $lans($lan)
set nodelist [lindex $laninfo 0]
set bw [lindex $laninfo 1]
set delay [lindex $laninfo 2]
set loss [lindex $laninfo 3]
set extlinks [lrange $laninfo 4 end]
# we create a node with the same name as the lan and type of lan
set nodes($lan) "lan $extlinks"
# the links of the node will be one for every node in the lan
# plus one for every external link to the lan
foreach node $nodelist {
set linkname lanlink-$lan-$node
set links($linkname) "$node -1 $lan -1 $bw $bw $delay $delay $loss"
set nodes($lan) "$nodes($lan) $linkname"
}
}
# calculate delay stuff
set delayI 0
set delayinfo {}
foreach link [array names links] {
set src [lindex $links($link) 0]
set dst [lindex $links($link) 2]
set bw [string trimright [lindex $links($link) 4] "MbmB"]
set delay [string trimright [lindex $links($link) 6] "msMS"]
set loss [lindex $links($link) 8]
if {($bw != 100 && $bw != 10) ||
($delay > $delaythresh) ||
($loss > 0)} {
# we need a delay node
set nodes(delay$delayI) [list delay]
set rlinks(dsrc_$link) [list $src -1 delay$delayI -1 100Mb 100Mb 1ms 1ms]
set rlinks(ddst_$link) [list $dst -1 delay$delayI -1 100Mb 100Mb 1ms 1ms]
lappend delayinfo "$link delay$delayI $bw $delay $loss"
incr delayI
} else {
set rlinks($link) $links($link)
}
}
# write nodes
foreach node [array names nodes] {
puts $topfp "node $node [lindex $nodes($node) 0]"
}
# write links
foreach link [array names rlinks] {
set src [lindex $rlinks($link) 0]
set dst [lindex $rlinks($link) 2]
set bw [string trimright [lindex $rlinks($link) 4] "Mb"]
puts $topfp "link $link [lindex $src 0] [lindex $dst 0] $bw"
}
close $topfp
# run assign on the topfile and $testbed
puts "Running assign ($assign -b -t $testbed $tmpfile)"
puts " Log in [file dirname $irfile]/assign.log"
set run 0
while {$run < $maxrun} {
set assignfp [open "|$assign -b -t $testbed $tmpfile | tee -a [file dirname $irfile]/assign.log" r]
set problems 0
set score -1
set seed 0
while {$problems == 0 && [gets $assignfp line] >= 0} {
if {[regexp {BEST SCORE: ([0-9]+)} $line match score] == 1} {
continue;
}
if {[regexp {With ([0-9]+) violations} $line match problems] == 1} {
break;
}
if {[regexp {seed = ([0-9]+)} $line match seed] == 1} {
continue
}
}
puts "Done with assign"
if {$problems > 0} {
incr run
puts "Run $run resulted in $problems violations."
continue
}
# we should now be ready to read the solution
readto $assignfp "Nodes:"
while {[gets $assignfp line] >= 0} {
if {[regexp {unassigned:} $line] == 1} {
puts stderr "Assign error ($line). I'm confused! (not deleting $tmpfile)"
exit 1
}
if {$line == "End Nodes"} {break}
lappend map([lindex $line 1]) [list [lindex $line 0] [lindex $line 2]]
set nmap([lindex $line 0]) [lrange $line 1 end]
}
readto $assignfp "Edges:"
while {[gets $assignfp line] >= 0} {
if {$line == "End Edges"} {break}
set plinks([lindex $line 0]) [lrange $line 1 end]
}
break
}
if {$run >= $maxrun} {
puts "Could not find solution (not deleting $tmpfile)!"
exit 1
}
close $assignfp
# append virtual section to ir
set fp [open $irfile a]
puts "Adding virtual section"
# XXX: we don't do links or lans yet
# XXX: We need to handle delay links
puts $fp "START virtual"
puts $fp "START nodes"
foreach switch [array names map] {
foreach pair $map($switch) {
set v2pmap([lindex $pair 0]) [lindex $pair 1]
set p2vmap([lindex $pair 1]) [lindex $pair 0]
puts $fp "$pair"
}
}
puts $fp "END nodes"
proc get_link_name {s} {
set t [split $s _]
set v [lindex $t 0]
if {$v == "dsrc" || $v == "ddst"} {
return [join [lrange $t 1 end] _]
} else {
return $s
}
}
puts $fp "START links"
foreach link [array names plinks] {
set pls {}
foreach element [lrange $plinks($link) 1 end] {
if {[string index $element 0] == "("} {continue}
lappend pls $element
}
set name [get_link_name $link]
if {! [info exists linktmp($name)]} {
set linktmp($name) {}
}
foreach l $pls {
lappend linktmp($name) $l
}
}
proc node_name {s} {
return [lindex [split $s -] 0]
}
proc is_lan {n} {
return [regexp {^lan[0-9]+$} [node_name $n]]
}
foreach link [array names linktmp] {
# Any sub-link (pair of nodes) with a lan node in it
# should be recorded for inclusion in the lan section and
# not spit out in the links section. If there is another
# sub-link it should be listed under a virtual link of the
# lan name. All such sublinks should go under the same
# virtual link.
set lanlink 0
foreach item $linktmp($link) {
if {[is_lan $item]} {set lanlink 1}
}
if {$lanlink == 0} {
# Any "duplicates" should go together.
# RULES: Can only swap a and b or c and d (i.e. within a link)
# This will only happen in the case of a delay node which will
# have four elements (two links of src/dst), we just check every
# case.
if {[llength $linktmp($link)] == 4} {
set a [lindex $linktmp($link) 0]
set b [lindex $linktmp($link) 1]
set c [lindex $linktmp($link) 2]
set d [lindex $linktmp($link) 3]
if {[node_name $b] == [node_name $d]} {
set tmp $d
set d $c
set c $tmp
} elseif {[node_name $a] == [node_name $c]} {
set tmp $b
set b $a
set a $tmp
} elseif {[node_name $a] == [node_name $d]} {
set tmp $b
set b $a
set a $tmp
set tmp $d
set d $c
set c $tmp
}
set linktmp($link) [list $a $b $c $d]
}
puts $fp "$link $linktmp($link)"
} else {
if {[llength $linktmp($link)] == 2} {
set A [lindex $linktmp($link) 0]
set B [lindex $linktmp($link) 1]
if {[is_lan $A]} {
lappend lansection($p2vmap([node_name $A])) [node_name $B]
}
if {[is_lan $B]} {
lappend lansection($p2vmap([node_name $B])) [node_name $A]
}
set linktmp($link) [list $A $B]
puts $fp "$link $A $B"
} else {
set A [lindex $linktmp($link) 0]
set B [lindex $linktmp($link) 1]
set C [lindex $linktmp($link) 2]
set D [lindex $linktmp($link) 3]
set ABlan ""
set CDlan ""
if {[is_lan $A] || [is_lan $B]} {
# in a 4 link only one of the two will be a LAN
if {[is_lan $A]} {
set ABlan [node_name $A]
lappend lansection($p2vmap([node_name $A])) [node_name $B]
} else {
set ABlan [node_name $B]
lappend lansection($p2vmap([node_name $B])) [node_name $A]
}
}
if {[is_lan $C] || [is_lan $D]} {
# in a 4 link only one of the two will be a LAN
if {[is_lan $C]} {
set CDlan [node_name $C]
lappend lansection($p2vmap([node_name $C])) [node_name $D]
} else {
set CDlan [node_name $D]
lappend lansection($p2vmap([node_name $D])) [node_name $C]
}
}
if {$ABlan != "" && $CDlan != ""} {
# delayed lan<->lan link
set linktmp($link) [list $A $B $D $C]
puts $fp "$link $A $B $D $C"
} else {
# delayed lan<->node link
if {$ABlan != ""} {
lappend lanlinks($p2vmap($ABlan)) $C $D
} else {
lappend lanlinks($p2vmap($CDlan)) $A $B
}
}
}
}
}
if {[info exists lanlinks]} {
foreach lanlink [array names lanlinks] {
puts $fp "$lanlink $lanlinks($lanlink)"
}
}
puts $fp "END links"
# write /virtual/lans section
if {[info exists lansection]} {
puts $fp "START lans"
foreach lan [array names lansection] {
puts $fp "$lan $lansection($lan)"
}
puts $fp "END lans"
}
puts $fp "END virtual"
## now we apprend the vlan section
# first we need to read in macs
puts "Adding VLAN section"
puts $fp "START vlan"
proc getmac {s} {
set t [split [string trim $s "()"] ,]
if {[lindex $t 0] == "(null)"} {
return [lindex $t 1]
} else {
return [lindex $t 0]
}
}
proc find_base_lan {lan} {
global lanvlan
set current $lan
puts "find_base_lan $lan"
while {[info exists lanvlan($current)] &&
[regexp {^=>([^ ]+)$} $lanvlan($current) match next] == 1} {
puts " ->$next"
set current $next
}
puts " ended on $current"
if {! [info exists lanvlan($current)]} {
return ""
} else {
return $current
}
}
proc tracelanvlan {a b op} {
upvar #0 $a A
puts "${a}($b) = $A($b)"
}
trace variable lanvlan w "tracelanvlan"
foreach link [array names plinks] {
puts "!plink $link - $plinks($link)"
set t $plinks($link)
set type [lindex $t 0]
set name [get_link_name $link]
switch $type {
"intraswitch" {
set nodeA [lindex $t 1]
set nodeB [lindex $t 3]
if {[is_lan $nodeA]} {
set lan [node_name $nodeA]
set laninfo [lindex $t 4]
} elseif {[is_lan $nodeB]} {
set lan [node_name $nodeB]
set laninfo [lindex $t 2]
} else {
set lan {}
}
if {$lan == {}} {
# 2 links, but each goes to a switch
set srcmac [getmac [lindex $t 2]]
set dstmac [getmac [lindex $t 4]]
lappend linktmpb($name) [list $srcmac $dstmac]
} elseif {[is_lan $nodeA] && [is_lan $nodeB]} {
# undelayed lan<->lan link
set Abase [find_base_lan $p2vmap([node_name $nodeA])]
set Bbase [find_base_lan $p2vmap([node_name $nodeB])]
puts "lan<->lan $nodeA ($Abase) $nodeB ($Bbase)"
if {$Abase == "" && $Bbase == ""} {
set base $p2vmap([node_name $nodeA])
set lanvlan($p2vmap([node_name $nodeB])) "=>$base"
} elseif {$Abase == ""} {
set base $Bbase
set lanvlan($p2vmap([node_name $nodeA])) "=>$base"
if {$base != $p2vmap([node_name $nodeB])} {
set lanvlan($p2vmap([node_name $nodeB])) "=>$base"
}
} elseif {$Bbase == ""} {
puts "!=!=!=!="
set base $Abase
set lanvlan($p2vmap([node_name $nodeB])) "=>$base"
if {$base != $p2vmap([node_name $nodeA])} {
set lanvlan($p2vmap([node_name $nodeA])) "=>$base"
}
} else {
puts stderr "Assert failure, two undelayed connected lans go to different sets - Internal error."
exit 1
}
# No actual macs in this list
if {! [info exists lanvlan($base)]} {
set lanvlan($base) ""
}
} else {
# lan<->node link
set base [find_base_lan $p2vmap($lan)]
puts "$p2vmap($lan) => $base"
if {$base == ""} {set base $p2vmap($lan)}
lappend lanvlan($base) [getmac $laninfo]
# hack to get the vlan info in, the other
# vlan info showed up in the non-lan pair.
set mac [getmac [lindex $t 2]]
if {$mac == "null)"} {
set mac [getmac [lindex $t 4]]
}
lappend linktmpb($name) [list $mac NA]
# set vlaninfo($name-1) [list $mac NA]
}
}
"interswitch" {
# 3 or four links
# XXX - in later versions this will become an arbitrary number
# of links.
set ll {}
if {[llength $t] == 8} {set num 4} else {set num 3}
for {set i 0} {$i < $num} {incr i} {
set l [lindex $t [expr $i*2+1]]
set mac [getmac [lindex $t [expr $i*2+2]]]
if {$mac != "(null)"} {
lappend ll $mac
}
}
lappend linktmpb($name) $ll
}
"direct" {
# 1 link
set macs [split [string trim [lindex $t 2] "()"] ","]
lappend linktmpb($name) $macs
}
}
}
foreach link [array names linktmpb] {
set llen [llength $linktmpb($link)]
set i 0
foreach l $linktmpb($link) {
set vlaninfo($link-$i) $l
if {([lindex $l 0] != "NA") &&
([lindex $l 1] != "NA")} {
puts $fp "$link-$i $l"
}
incr i
}
}
foreach lan [array names lanvlan] {
if {[regexp {^=>} $lanvlan($lan)] == 0} {
puts $fp "$lan $lanvlan($lan)"
}
}
puts $fp "END vlan"
# add delay seciton
puts $fp "START delay"
foreach line $delayinfo {
puts "! $line"
puts $fp [lrange $line 0 3]
}
puts $fp "END delay"
close $fp
file delete $tmpfile
# DEBUG
foreach line [array names vlaninfo] {
puts "VLANINFO: $line - $vlaninfo($line)"
}
# END DEBUG
# Add delay info to database
# Note on interface numbers: A delayed link has two vlans
# <link>-0 and <link>-1 the second mac of -0 and the first mac
# of -1 are the two macs on the delay node and correspond to the two
# intercaces.
foreach line $delayinfo {
set link [lindex $line 0]
set node [lindex $line 1]
set bw [lindex $line 2]
set delay [lindex $line 3]
set loss [lindex $line 4]
# extra macs of the two interfaces
set mac0 [lindex $vlaninfo($link-0) 1]
if {$mac0 == "NA"} {
set mac0 [lindex $vlaninfo($link-0) 0]
}
set mac1 [lindex $vlaninfo($link-1) 0]
if {$mac1 == "NA"} {
set mac1 [lindex $vlaninfo($link-0) 1]
}
puts "!!$line = $mac0 $mac1"
# use database to get interface numbers
sql query $DB "select card from interfaces where mac = \"$mac0\""
set int0 [sql fetchrow $DB]
sql endquery $DB
sql query $DB "select card from interfaces where mac = \"$mac1\""
set int1 [sql fetchrow $DB]
sql endquery $DB
# find the physical node for this dely
set pnode $v2pmap($node)
# remove any current entry in the delays table
# sql exec $DB "delete from delays where node_id = \"$pnode\""
# add this entry
# sql exec $DB "insert into delays (node_id,card0,card1,delay,bandwidth,lossrate) values (\"$pnode\",\"$int0\",\"$int1\",\"$delay\",\"$bw\",\"$loss\")"
}
puts "Done"
#!/usr/bin/perl -w
# This rather complex program acts as an interface between the IR
# and the assign engine. It translate between LANs and the star
# topologies used to emulate lans in assign. It genertes the
# top file, calls assign, and then interprets the output, generating
# the /virtual and /vlan section.
# The ptop file should be generated with 'avail | ptopgen'
# Syntax: assign_wrapper <ir> <ptop>
# Limitations:
# It is assumed that mac addresses are sufficient to generate vlans. From
# this data it should be possible to look up all other pertinant information
# about nodes. This is usually correct except in the case where there are
# multiple paths between nodes are different switches. Any information
# about which path was chosen by assign (for load balancing) is lost.
# Note that assign itself has a limitation that no two switches can have
# more than one intermediate switch.
# Debugging:
# Running with -v will produce a large amount of useful output.
# Caveats:
# The support for direct and interswitch links has not been
# testbed much at all.
# Some settings
# delaythresh is the maximum delay in ms above which a delay node is needed
# maxrun is the number of times to rerun assign if no match is found.
# assign is the path to assign
$delaythresh = .25;
$maxrun = 5;
$assign = "/usr/testbed/lib/assign";
push(@INC,"/usr/testbed/lib/tbsetup/ir");
require libir;
$verbose = -1;
if ($#ARGV == 2) {
if ($ARGV[0] eq "-v") {
$verbose = 1;
($irfile,$ptopfile) = @ARGV[1,2];
}
} elsif ($#ARGV == 1) {
if ($ARGV[0] ne "-v") {
$verbose = 0;
($irfile,$ptopfile) = @ARGV;
}
}
if ($verbose == -1) {
print STDERR "Syntax: $0 [-v] irfile ptopfile\n";
exit(1);
}
# printdb - prints out a debug message passed to it if $verbose == 1
sub printdb {
if ($verbose) {
print "DB: $_[0]";
}
};
# We now read in the topology section
eval {&ir_read($irfile)};
if ($@) {
print STDERR "Could not read $irfile ($@)\n";