tb_compat.tcl.in 78.5 KB
Newer Older
1
# -*- tcl -*-
Leigh Stoller's avatar
Leigh Stoller committed
2
#
3
# Copyright (c) 2000-2018 University of Utah and the Flux Group.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
# 
# {{{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/>.
# 
# }}}
Leigh Stoller's avatar
Leigh Stoller committed
23 24
#

25 26 27
# This is the tb_compact.tcl that deals with all the TB specific commands.
# It should be loaded at the beginning of any ns script using the TB commands.

Leigh Stoller's avatar
Leigh Stoller committed
28 29 30 31 32
# We set up some helper stuff in a separate namespace to avoid any conflicts.
namespace eval TBCOMPAT {
    var_import ::GLOBALS::DB
    var_import ::GLOBALS::pid
    var_import ::GLOBALS::eid
33
    var_import ::GLOBALS::elabinelab_fw_type
Leigh Stoller's avatar
Leigh Stoller committed
34 35 36 37 38 39 40 41

    # This is regular expression that matches slightly more than valid
    # IP addresses.  The only thing it doesn't check is that IP 
    # addresses are in range (i.e. 0-255).
    variable IP {^([0-9]{1,3}\.){3,3}[0-9]{1,3}$}

    # This is an RE to match a floating point number.
    variable FLOAT {(^[0-9]+(\.[0-9]+)?$)|(^\.[0-9]+$)}
42 43 44 45 46 47 48

    # This is the default weight for a soft vtype.
    variable default_soft_vtype_weight 0.5

    # This is the default weight for a hard vtype.
    variable default_hard_vtype_weight 1.0

49 50
    variable prefix "@prefix@"

51 52
    # Substitutions for "/proj",
    variable FSDIR_PROJ "@FSDIR_PROJ@"
53
    variable PROJROOT	"@PROJROOT_DIR@"
54 55 56

    # ... "/groups",
    variable FSDIR_GROUPS "@FSDIR_GROUPS@"
57
    variable GROUPROOT	  "@GROUPSROOT_DIR@"
58

59
    # ... "/users",
60
    variable FSDIR_USERS "@FSDIR_USERS@"
61
    variable USERROOT	 "@USERSROOT_DIR@"
62

63
    # ... "/share", and
64
    variable FSDIR_SHARE "@FSDIR_SHARE@"
65 66 67 68 69
    variable SHAREROOT	 "@SHAREROOT_DIR@"

    # ... "/scratch".
    variable FSDIR_SCRATCH "@FSDIR_SCRATCH@"
    variable SCRATCHROOT   "@SCRATCHROOT_DIR@"
70

Leigh Stoller's avatar
Leigh Stoller committed
71 72 73 74 75 76 77 78 79
    # This is a general procedure that takes a node, an object (lan or link)
    # it is connected to, and an IP address, and sets the IP address
    # for the node on that object.  It checks both the validity of the
    # IP addresses and the fact that the node is actually a member of the
    # lan/link.
    proc set-ip {node obj ip} {
	variable IP
	set caller [lindex [info level -1] 0]
	if {[regexp $IP $ip] == 0} {
80
	    perror "$caller - $ip is not a valid IP address."
Leigh Stoller's avatar
Leigh Stoller committed
81 82 83 84
	    return
	}
	set port [$node find_port $obj]
	if {$port == -1} {
85
	    perror "$caller - $node is not connected to $obj."
Leigh Stoller's avatar
Leigh Stoller committed
86 87 88 89 90 91 92
	    return
	}
	$node ip $port $ip
    }

    # Let's set up a hwtypes table that contains all valid hardware types.
    variable hwtypes
93
    variable isremote
94
    variable isvirt
Leigh Stoller's avatar
Leigh Stoller committed
95
    variable issubnode
Leigh Stoller's avatar
Leigh Stoller committed
96

97 98
    # Storage object tracking (types, resources, etc.)
    variable sotypes
99 100
    variable soclasses
    variable soprotocols
101

102 103 104 105
    variable sodesires 
    array set sodesires {
	"class" 1
	"protocol" 1
106
	"lease" 1
107
    }
108 109 110 111 112 113

    variable soplacementdesires
    array set soplacementdesires {
	"ANY"       "?+disk_any"
	"SYSVOL"    "?+disk_sysvol"
	"NONSYSVOL" "?+disk_nonsysvol"
114
    }
115
    variable sodefaultplacement "ANY"
116 117 118 119
    variable sopartialplacements
    array set sopartialplacements {}
    variable sofullplacements
    array set sofullplacements {}
120

121 122 123 124 125 126 127 128 129
    variable sodisallowedmounts {
	"/" "/bin" "/boot" "/dev" "/etc" "/lib" "/libexec" "/proc" 
	"/sbin" "/sys" "/usr" "/usr/bin" "/usr/local" "/usr/local/etc" 
	"/usr/local/bin" "/usr/local/sbin" "/usr/sbin" "/var"
	"/etc/emulab" "/group" "/proj" "/share" "/scratch" 
	"/users" "/usr/local/etc/emulab" "/var/emulab"
    }
    variable sonodemounts
    array set sonodemounts {}
130

Shashi Guruprasad's avatar
Shashi Guruprasad committed
131 132 133
    # NSE hack: sim type is not in DB. Just adding it now
    set hwtypes(sim) 1
    set isremote(sim) 0
134
    set isvirt(sim) 0
Leigh Stoller's avatar
Leigh Stoller committed
135
    set issubnode(sim) 0
Shashi Guruprasad's avatar
Shashi Guruprasad committed
136

137 138 139 140 141
    # The permissions table. Entries in this table indicate who is allowed
    # to use nodes of a particular type. No entries means anyone can use it.
    #
    # We omit this check in anonymous mode.
    #
142
    variable nodetypeXpid_permissions
143
    
144 145 146 147
    # And a os table with valid OS Descriptor names. While we still call
    # them "osids", we are using the user level name not the internal,
    # globally unique name. We leave it to a later phase to deal with it.
    #
Leigh Stoller's avatar
Leigh Stoller committed
148
    # We omit this check in anonymous mode.
149 150 151 152 153 154 155 156 157
    #
    variable osids

    # The default OSID for the node type. 
    variable default_osids

    # A mapping of event objects and types.
    variable objtypes
    variable eventtypes
158
    variable triggertypes
159 160 161 162 163 164

    # Existing (reserved nodes).
    variable reserved_list
    variable reserved_type
    variable reserved_node
    set reserved_list {}
165

166 167 168 169
    # Input parameters for Templates
    variable parameter_list_defaults
    array set parameter_list_defaults {}

170 171
    # Physical node names
    variable physnodes
172 173 174 175 176 177

    ## Feedback related stuff below:

    # Experiment directory name.
    variable expdir

178 179
    # ElabInElab stuff. Do not initialize.
    variable elabinelab_maxpcs
180 181
    variable elabinelab_hardware
    variable elabinelab_fixnodes
182
    variable elabinelab_nodeos
183
    variable elabinelab_source_tarfile ""
184
    variable elabinelab_tarfiles
185
    variable elabinelab_cnetspeed 0
186

187 188
    # Elabinelab attribute stuff.
    variable elabinelab_attributes
189
    set elabinelab_attributes {}
190
    variable EINEROLE  {^(all|boss|ops|fs|router|node)$}
191
    variable EINEKEY   {^([-\w\.]+)$}
192
    variable EINEVALUE {^([-\w\.\+\,\s\/:\@]+)$}
193 194
    variable EINEORDER {^\d+$}

195 196 197
    # Address Pool.
    variable virt_address_pools

198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
    # virt blobs stuff
    variable vblob_id_count 0
    variable virt_blobs {}
    variable vblobmap
    array set vblobmap {}

    # client service/hook control stuff
    variable servicenames
    array set servicenames {}
    variable servicepoints
    array set servicepoints {}
    variable virt_service_ctls
    array set virt_service_ctls {}
    variable virt_service_hooks
    array set virt_service_hooks {}

Xing Lin's avatar
Xing Lin committed
214 215 216 217 218 219 220 221 222 223 224 225 226
    # OML measurement stuff.
    set oml_mps {}

    # OML-server listening port.
    set oml_server_port 8000

    # OML-server node.
    set omlserver omlserver

    # flag to identify which network is used to send measurement data
    # by default, use control network.
    set oml_use_control 1

227 228 229 230 231 232 233 234
    # Mapping of "resource classes" and "reservation types" to bootstrap
    # values, where a resource class is a symbolic string provided by the user
    # (e.g. Client, Server), and a reservation type is a resource name provided
    # by the system (e.g. cpupercent, kbps).  This array will be filled by the
    # tb-feedback methods and then written out to a "bootstrap_data.tcl" file
    # to be read in during future evaluations of the NS file.
    variable BootstrapReservations

235 236 237 238 239 240 241
    # Table of vnodes/vlinks that were locate on an overloaded pnode.
    variable Alerts

    # Table of "estimated" reservations.  Basically, its our memory of previous
    # guesses for vnodes that have 0% CPU usage on an overloaded pnode.
    variable EstimatedReservations

242 243
    # The experiment directory, this is where the feedback related files will
    # be read from and dumped to.  XXX Hacky
244 245 246
    # XXX Hacky II: we must use PROJROOT and not FSDIR_PROJ since these
    # sourced file paths get recorded and used on boss.
    set expdir "${PROJROOT}/${::GLOBALS::pid}/exp/${::GLOBALS::eid}/"
247 248

    # XXX Just for now...
249
    variable tbxlogfile
250
    if {[file exists "$expdir"]} {
251 252
	set logname "$expdir/logs/feedback.log"
	set tbxlogfile [open $logname w 0664];
253
	catch "exec chmod 0664 $logname"
254
	puts $tbxlogfile "BEGIN feedback log"
255 256 257 258 259 260 261 262 263 264
    }

    # Get any Emulab generated feedback data from the experiment directory.
    if {[file exists "${expdir}/tbdata/feedback_data.tcl"]} {
	source "${expdir}/tbdata/feedback_data.tcl"
    }
    # Get any bootstrap feedback data from a previous run.
    if {[file exists "${expdir}/tbdata/bootstrap_data.tcl"]} {
	source "${expdir}/tbdata/bootstrap_data.tcl"
    }
265 266 267 268
    # Get any estimated feedback data from a previous run.
    if {[file exists "${expdir}/tbdata/feedback_estimate.tcl"]} {
	source "${expdir}/tbdata/feedback_estimate.tcl"
    }
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308

    #
    # Configure the default reservations for an object based on an optional
    # "resource class".  First, the function will check for a reservation
    # specifically made for the object, then it will try to initialize the
    # reservation from the resource class, otherwise it does nothing and
    # returns zero.
    #
    # @param object The object name for which to configure the feedback
    #   defaults.
    # @param rclass The "resource class" of the object or the empty string if
    #   it is not part of any class.  This is just a symbolic string, such as
    #   "Client" or "Server".
    # @return One, if there is an initialized slot in the "Reservations" array
    #   for the given object, or zero if it could not be initialized.
    #
    proc feedback-defaults {object rclass} {
	var_import ::TBCOMPAT::Reservations;  # The reservations to make

	if {[array get Reservations $object,*] == ""} {
	    # No node-specific values exist, try to initialize from the rclass.
	    if {[array get Reservations $rclass,*] != ""} {
		# Use bootstrap feedback from a previous topology,
		set rcdefaults [array get Reservations $rclass,*]
		# ... substitute the node name for the rclass, and
		regsub -all -- $rclass $rcdefaults $object rcdefaults
		# ... add all the reservations to the table.
		array set Reservations $rcdefaults
		set retval 1
	    } else {
		# No feedback exists yet, let the caller fill it in.
		set retval 0
	    }
	} else {
	    # Node-specific values exist, use those.
	    set retval 1
	}
	return $retval
    }

309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
    #
    # Produce an estimate of a vnode's resource usage.  If a guess was already
    # made in the previous iteration, double that value.  Otherwise, we just
    # assume 10%.
    #
    # @param object The object for which to produce the estimate.
    # @param rtype The resource type: cpupercent, rampercent
    # @return The estimated resource usage.
    # 
    proc feedback-estimate {object rtype} {
	var_import ::TBCOMPAT::EstimatedReservations

	if {[array get EstimatedReservations $object,$rtype] != ""} {
	    set retval [expr [set EstimatedReservations($object,$rtype)] * 2]
	} else {
	    set retval 10.0; # XXX get from DB
	}
	set EstimatedReservations($object,$rtype) $retval
	return $retval
    }

330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
    #
    # Record bootstrap feedback data for a resource class.  This function
    # should be called for every member of a resource class so that the one
    # with the highest reservation will be used to bootstrap.
    #
    # @param rclass The "resource class" for which to update the bootstrap
    #   feedback data.  This is just a symbolic string, such as "Client" or
    #   "Server".
    # @param rtype The type of reservation (e.g. cpupercent,kbps).
    # @param res The amount to reserve.
    #
    proc feedback-bootstrap {rclass rtype res} {
	# The bootstrap reservations
	var_import ::TBCOMPAT::BootstrapReservations

	if {$rclass == ""} {
	    # No class to operate on...
	} elseif {([array get BootstrapReservations($rclass,$rtype)] == "") ||
	    ($res > $BootstrapReservations($rclass,$rtype))} {
		# This is either the first time this function was called for
		# this rclass/rtype or the new value is greater than the old.
		set BootstrapReservations($rclass,$rtype) $res
	}
    }
354 355 356 357 358 359 360

    #
    # Verify that the argument is an http, https, or ftp URL.
    #
    # @param url The URL to check.
    # @return True if "url" looks like a URL.
    #
361 362
    # What is xxx:// you might ask? Its part of experimental template code.
    #
363 364 365
    proc verify-url {url} {
	if {[string match "http://*" $url] ||
	    [string match "https://*" $url] ||
366 367
	    [string match "ftp://*" $url] ||
	    [string match "xxx://*" $url]} {
368 369 370 371 372 373
	    set retval 1
	} else {
	    set retval 0
	}
	return $retval
    }
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397

    # Add an IP alias for a node given a particular lan.
    proc add-ipalias {node obj ip} {
	variable IP
	set caller [lindex [info level -1] 0]
	if {[regexp $IP $ip] == 0} {
	    perror "$caller - $ip is not a valid IP address."
	    return
	}
	$node add_ipalias $obj $ip
    }

    # Request a number of IP aliases for a node on a particular lan.
    variable MAX_NODEPORT_IPALIASES 10
    proc request-ipaliases {node obj count} {
	variable MAX_NODEPORT_IPALIASES
	set caller [lindex [info level -1] 0]
	if {$count > $MAX_NODEPORT_IPALIASES} {
	    perror "$caller - Number of IP aliases requested ($count) is too large (max: $MAX_NODEPORT_IPALIASES)."
	    return
	}
	$node want_ipaliases $obj $count
    }

398 399
}

Leigh Stoller's avatar
Leigh Stoller committed
400 401
# IP addresses routines.  These all do some checks and convert into set-ip
# calls.
402
proc tb-set-ip {node ip} {
Leigh Stoller's avatar
Leigh Stoller committed
403 404
    $node instvar portlist
    if {[llength $portlist] != 1} {
405
	perror "\[tb-set-ip] $node does not have a single connection."
Leigh Stoller's avatar
Leigh Stoller committed
406 407 408
	return
    }
    ::TBCOMPAT::set-ip $node [lindex $portlist 0] $ip
409 410
}
proc tb-set-ip-interface {src dst ip} {
Leigh Stoller's avatar
Leigh Stoller committed
411 412 413 414
    set sim [$src set sim]
    set reallink [$sim find_link $src $dst]
    if {$reallink == {}} {
	perror \
415
	    "\[tb-set-ip-interface] No connection between $src and $dst."
Leigh Stoller's avatar
Leigh Stoller committed
416
	return
417
    }
Leigh Stoller's avatar
Leigh Stoller committed
418
    ::TBCOMPAT::set-ip $src $reallink $ip
419 420
}
proc tb-set-ip-lan {src lan ip} {
Leigh Stoller's avatar
Leigh Stoller committed
421
    if {[$lan info class] != "Lan"} {
422
	perror "\[tb-set-ip-lan] $lan is not a LAN."
Leigh Stoller's avatar
Leigh Stoller committed
423 424 425
	return
    }
    ::TBCOMPAT::set-ip $src $lan $ip
426 427
}
proc tb-set-ip-link {src link ip} {
Leigh Stoller's avatar
Leigh Stoller committed
428
    if {[$link info class] != "Link"} {
429
	perror "\[tb-set-ip-link] $link is not a link."
Leigh Stoller's avatar
Leigh Stoller committed
430 431 432
	return
    }
    ::TBCOMPAT::set-ip $src $link $ip
433
}
Leigh Stoller's avatar
Leigh Stoller committed
434

435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468
#
# Append an IP address alias for a node given a particular lan or link.
#
proc tb-add-ip-alias-lan {src lan ip} {
    if {[$lan info class] != "Lan"} {
	perror "\[tb-add-ip-alias-lan] $lan is not a LAN."
	return
    }
    ::TBCOMPAT::add-ipalias $src $lan $ip
}
proc tb-add-ip-alias-link {src link ip} {
    if {[$link info class] != "Link"} {
	perror "\[tb-add-ip-alias-link] $link is not a link."
	return
    }
    ::TBCOMPAT::add-ipalias $src $link $ip
}

# Request a number of automatically assigned ip aliases on a lan or link.
proc tb-request-ip-alias-lan {src lan count} {
    if {[$lan info class] != "Lan"} {
	perror "\[tb-add-ip-alias-lan] $lan is not a LAN."
	return
    }
    ::TBCOMPAT::request-ipaliases $src $lan $count
}
proc tb-request-ip-alias-link {src link count} {
    if {[$link info class] != "Link"} {
	perror "\[tb-add-ip-alias-link] $link is not a link."
	return
    }
    ::TBCOMPAT::request-ipaliases $src $link $count
}

469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486
#
# Set the netmask. To make it easier to compute subnets later, do
# allow the user to alter the netmask beyond the bottom 3 octets.
# This restricts the user to a lan of 4095 nodes, but that seems okay
# for now. 
# 
proc tb-set-netmask {lanlink netmask} {
    var_import ::TBCOMPAT::IP
    
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-netmask] $lanlink is not a link or a lan."
	return
    }
    if {[regexp $IP $netmask] == 0} {
	perror "\[tb-set-netmask] - $netmask is not a valid IP mask"
	return
    }
    set netmaskint [inet_atohl $netmask]
487
    if {[expr ($netmaskint & 0xFFFF0000)] != 0xFFFF0000} {
488 489 490 491 492 493
	perror "\[tb-set-netmask] - $netmask is too big"
	return
    }
    $lanlink set netmask $netmask
}

494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578
proc tb-set-node-service {service args} {
    var_import ::TBCOMPAT::servicenames
    var_import ::TBCOMPAT::servicepoints
    var_import ::TBCOMPAT::virt_service_ctls
    var_import ::TBCOMPAT::vblob_id_count
    var_import ::TBCOMPAT::virt_blobs
    var_import ::TBCOMPAT::vblobmap

    set cmd "tb-set-node-service"

    # these defaults should match the default value for each DB field
    # in virt_client_service* tables
    ::GLOBALS::named-args $args {
	-node "" -env "boot" -whence "every" -script "" -scriptblob ""
	-enable 1 -enablehooks 1 -fatal 1
    }

    if { $(-script) != "" && $(-scriptblob) != "" } {
	perror "\[$cmd] you cannot define both a script ($(-script)) and a scriptblob ($(-scriptblob))!"
	return
    }

    if {![info exists servicenames("$service:$(-env):$(-whence)")]} {
	if {[info exists servicepoints($service)]} {
	    perror "\[$cmd] service $service can only be controlled for the following whence and env tuples: $servicepoints($service); $service:$(-env):$(-whence)."
	    return
	}
	perror "\[$cmd] Invalid service $service."
	return
    }

    set mykey "$(-node):$service:$(-env):$(-whence)"
    if {[info exists virt_service_ctls($mykey)]} {
	perror "\[$cmd] service $service has already been controlled once for node $(-node) at $(-whence):$(-env)"
	return
    } else {
	set vblobid $(-scriptblob)
	if { $(-script) != "" && [info exists vblobmap($(-script))]} {
	    # try to reuse virt blobs that already have been created
	    set vblobid $vblobmap($(-script))
	} elseif { $(-script) != "" } {
	    # if we need to make a virt blob, do so now

	    # Check the script to make sure it exists, is readable, etc...
	    if {[string match "*://*" $(-script)]} {
		perror "\[$cmd] '$(-script)' cannot be a URL!"
		return
		# It is a URL, check for a valid protocol.
		#if {![::TBCOMPAT::verify-url $(-script)]} {
		#    perror "\[$cmd] '$(-script)' is not an http, https, or ftp URL."
		#    return
		#}
	    } elseif {![string match "${::TBCOMPAT::PROJROOT}/*" $(-script)] &&
		      ![string match "${::TBCOMPAT::GROUPROOT}/*" $(-script)] &&
		      ![string match "${::TBCOMPAT::USERROOT}/*" $(-script)] &&
		      (${::TBCOMPAT::SCRATCHROOT} == "" ||
		       ![string match "${::TBCOMPAT::SCRATCHROOT}/*" $(-script)])} {
		perror "\[$cmd] '$(-script)' is not in an allowed directory"
		return
	    } elseif {![file exists $(-script)]} {
		perror "\[$cmd] '$(-script)' does not exist."
		return
	    } elseif {![file isfile $(-script)]} {
		perror "\[$cmd] '$(-script)' is not a file."
		return
	    } elseif {![file readable $(-script)]} {
		perror "\[$cmd] '$(-script)' is not readable."
		return
	    }

	    # finally, make the virt blob!
	    lappend virt_blobs [list $vblob_id_count $(-script)]
	    set vblobid $vblob_id_count
	    set vblobmap($(-script)) $vblob_id_count

	    incr vblob_id_count
	}

	set serviceidx $servicenames("$service:$(-env):$(-whence)")
	set virt_service_ctls($mykey) \
	    [list $(-node) $serviceidx $(-env) $(-whence) \
		 $vblobid $(-enable) $(-enablehooks) $(-fatal)]
    }
}

579 580 581 582 583 584
proc tb-add-address-pool {id count} {
    var_import ::TBCOMPAT::virt_address_pools

    set virt_address_pools($id) $count
}

585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672
proc tb-add-node-service-hook {service args} {
    var_import ::TBCOMPAT::servicenames
    var_import ::TBCOMPAT::servicepoints
    var_import ::TBCOMPAT::virt_service_hooks
    var_import ::TBCOMPAT::vblob_id_count
    var_import ::TBCOMPAT::virt_blobs
    var_import ::TBCOMPAT::vblobmap

    set cmd "tb-add-node-service-hook"

    # these defaults should match the default value for each DB field
    # in virt_client_service* tables
    ::GLOBALS::named-args $args {
	-node "" -env "boot" -whence "every" -script "" -scriptblob ""
	-op "boot" -point "post" -argv "" -fatal 1
    }

    if { $(-script) != "" && $(-scriptblob) != "" } {
	perror "\[$cmd] you cannot define both a script ($(-script)) and a scriptblob ($(-scriptblob))!"
	return
    } elseif { $(-script) == "" && $(-scriptblob) == "" } {
	perror "\[$cmd] you must define either a script or a scriptblob!"
	return
    }

    if {![info exists servicenames("$service:$(-env):$(-whence)")]} {
	if {[info exists servicepoints($service)]} {
	    perror "\[$cmd] service $service can only be controlled for the following whence and env tuples: $servicepoints($service); $service:$(-env):$(-whence)."
	    return
	}
	perror "\[$cmd] Invalid service $service."
	return
    }

    set mykey "$(-node):$service:$(-env):$(-whence)"
    if {![info exists virt_service_ctls($mykey)]} {
	set virt_service_ctls($mykey) {}
    }

    set vblobid $(-scriptblob)
    if { $(-script) != "" && [info exists vblobmap($(-script))]} {
	# try to reuse virt blobs that already have been created
	set vblobid $vblobmap($(-script))
    } elseif { $(-script) != "" } {
	# if we need to make a virt blob, do so now

	# Check the script to make sure it exists, is readable, etc...
	if {[string match "*://*" $(-script)]} {
	    perror "\[$cmd] '$(-script)' cannot be a URL!"
	    return
	    # It is a URL, check for a valid protocol.
	    #if {![::TBCOMPAT::verify-url $(-script)]} {
	    #    perror "\[$cmd] '$(-script)' is not an http, https, or ftp URL."
	    #    return
	    #}
	} elseif {![string match "${::TBCOMPAT::PROJROOT}/*" $(-script)] &&
		  ![string match "${::TBCOMPAT::GROUPROOT}/*" $(-script)] &&
		  ![string match "${::TBCOMPAT::USERROOT}/*" $(-script)] &&
		  (${::TBCOMPAT::SCRATCHROOT} == "" ||
		   ![string match "${::TBCOMPAT::SCRATCHROOT}/*" $(-script)])} {
	    perror "\[$cmd] '$(-script)' is not in an allowed directory"
	    return
	} elseif {![file exists $(-script)]} {
	    perror "\[$cmd] '$(-script)' does not exist."
	    return
	} elseif {![file isfile $(-script)]} {
	    perror "\[$cmd] '$(-script)' is not a file."
	    return
	} elseif {![file readable $(-script)]} {
	    perror "\[$cmd] '$(-script)' is not readable."
	    return
	}

	# finally, make the virt blob!
	lappend virt_blobs [list $vblob_id_count $(-script)]
	set vblobid $vblob_id_count
	set vblobmap($(-script)) $vblob_id_count

	incr vblob_id_count
    }

    # finally, add the hook!
    set serviceidx $servicenames("$service:$(-env):$(-whence)")
    lappend virt_service_hooks($mykey) \
	[list $(-node) $serviceidx $(-env) $(-whence) \
	     $vblobid $(-op) $(-point) $(-argv) $(-fatal)]
}

Leigh Stoller's avatar
Leigh Stoller committed
673
# Node state routines.
674
proc tb-set-hardware {node type args} {
Leigh Stoller's avatar
Leigh Stoller committed
675
    var_import ::TBCOMPAT::hwtypes
676
    var_import ::TBCOMPAT::isremote
677
    var_import ::TBCOMPAT::isvirt
Leigh Stoller's avatar
Leigh Stoller committed
678
    var_import ::TBCOMPAT::issubnode
679 680 681
    var_import ::GLOBALS::vtypes
    if {(! [info exists hwtypes($type)]) &&
	(! [info exists vtypes($type)])} {
682
	perror "\[tb-set-hardware] Invalid hardware type $type."
Leigh Stoller's avatar
Leigh Stoller committed
683 684
	return
    }
685
    if {! ${GLOBALS::anonymous} && ! ${GLOBALS::passmode}} {
686 687
	var_import ::TBCOMPAT::nodetypeXpid_permissions
	var_import ::GLOBALS::pid
688
	set allowed 1
689 690
	
	if {[info exists nodetypeXpid_permissions($type)]} {
691
	    set allowed 0
692 693 694 695 696 697 698 699 700 701 702
	    foreach allowedpid $nodetypeXpid_permissions($type) {
		if {$allowedpid == $pid} {
		    set allowed 1
		}
	    }
	}
	if {! $allowed} {
	    perror "\[tb-set-hardware] No permission to use type $type."
	    return
	}
    }
703 704 705 706
    set remote 0
    if {[info exists isremote($type)]} {
	set remote $isremote($type)
    }
707 708 709 710
    set isv 0
    if {[info exists isvirt($type)]} {
	set isv $isvirt($type)
    }
Leigh Stoller's avatar
Leigh Stoller committed
711
    set issub 0
712
    if {[info exists issubnode($type)]} {
Leigh Stoller's avatar
Leigh Stoller committed
713 714 715
	set issub $issubnode($type)
    }
    $node set_hwtype $type $remote $isv $issub
716
}
717

718
proc tb-set-node-os {node os {parentos 0}} {
719 720
    if {! ${GLOBALS::anonymous} && ! ${GLOBALS::passmode} &&
        ([regexp {^(ftp|http|https):} $os] == 0) } {
Leigh Stoller's avatar
Leigh Stoller committed
721
	var_import ::TBCOMPAT::osids
722
	var_import ::GLOBALS::pid
723

724 725 726 727 728 729
	# Do not allow RHL-STD or FBSD-STD anymore.
	if { $os == "RHL-STD" || $os == "FBSD-STD" } {
	    perror "\[tb-set-node-os] $os is no longer supported; remove this statement if you really do not care what OS you get."
	    return
	}

730 731 732 733 734 735
	# Look for :version in the name.
	set osid $os
        if { [regexp {:} $os] } {
	    set osid [lindex [split $os {:}] 0]
	}
	if {! [info exists osids($osid)]} {
736
	    perror "\[tb-set-node-os] Invalid osid $os."
Leigh Stoller's avatar
Leigh Stoller committed
737 738
	    return
	}
739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754
	#
	# Always qualify the name if there is one in the current project.
	#
	if { ${GLOBALS::rspecmode} } {
	    if { ! [regexp {/} $os] } {
		set pos = "$pid/$osid"
		if { [info exists osids($pos)]} {
		    $osid = $pos
		} else {
		    set pos = "emulab-ops/$osid"
		    if { [info exists osids($pos)]} {
			$osid = $pos
		    }
		}
	    }
	}
755
	if {$parentos != {} && $parentos != 0} {
756 757 758 759 760 761
	    # Look for :version in the name.
	    set posid $parentos
	    if { [regexp {:} $parentos] } {
		set posid [lindex [split $os {:}] 0]
	    }
	    if {! [info exists osids($posid)]} {
762 763 764 765
		perror "\[tb-set-node-os] Invalid parent osid $parentos."
		return
	    }
	}
Leigh Stoller's avatar
Leigh Stoller committed
766 767
    }
    $node set osid $os
768 769 770
    if {$parentos != {} && $parentos != 0} {
	$node set parent_osid $parentos
    }
Leigh Stoller's avatar
Leigh Stoller committed
771
}
772 773 774 775 776 777 778 779 780 781 782 783 784
proc tb-set-node-loadlist {node loadlist} {
    if {! ${GLOBALS::anonymous} && ! ${GLOBALS::passmode}} {
	var_import ::TBCOMPAT::osids
	set oslist [split $loadlist ","]
	foreach os $oslist {
	    if {! [info exists osids($os)]} {
		perror "\[tb-set-node-loadlist] Invalid osid $os."
		return
	    }
	}
    }
    $node set loadlist $loadlist
}
Leigh Stoller's avatar
Leigh Stoller committed
785 786 787 788 789
proc tb-set-node-cmdline {node cmdline} {
    $node set cmdline $cmdline
}
proc tb-set-node-rpms {node args} {
    if {$args == {}} {
790
	perror "\[tb-set-node-rpms] No rpms given."
Leigh Stoller's avatar
Leigh Stoller committed
791 792
	return
    }
793 794 795 796
    # Lets assume that a single argument is a string and break it up.
    if {[llength $args] == 1} {
	set args [split [lindex $args 0] " "]
    }
797
    $node set rpms [join $args ";"]
798
}
Leigh Stoller's avatar
Leigh Stoller committed
799 800 801
proc tb-set-node-startup {node cmd} {
    $node set startup $cmd
}
802 803 804 805 806
proc tb-proc-tarfiles {cmd args0} { ; # args has special meaning that we
				      # don't want here
    set SHAREDNFS [expr {! "@NOSHAREDFS@"}]
    set args $args0

807 808 809 810
    # Lets assume that a single argument is a string and break it up.
    if {[llength $args] == 1} {
	set args [split [lindex $args 0] " "]
    }
811

Leigh Stoller's avatar
Leigh Stoller committed
812
    if {[expr [llength $args] % 2] != 0} {
813
	perror "\[$cmd] Arguments should be node and series of pairs."
Leigh Stoller's avatar
Leigh Stoller committed
814 815
	return
    }
816 817
    set tarfiles {}
    while {$args != {}} {
818 819 820
	set dir [lindex $args 0]
	set tarfile [lindex $args 1]
	
821
	#
822 823 824 825 826 827 828
	# Check the install directory to make sure it is not an NFS mount.
	# This check can also act as an alert to the user that the arguments
	# are wrong.  For example, the following line will pass the above
	# checks, but fail this one:
	#
	#   tb-set-node-tarfiles $node /proj/foo/bar.tgz /proj/foo/baz.tgz
	#
829 830 831
	# XXX This is a hack check because they can specify '/' and have
	# "proj/foo/..." in the tarball and still clobber themselves.
	#
832 833 834 835 836 837 838 839
	if {$SHAREDNFS && 
	    ([string match "${::TBCOMPAT::PROJROOT}/*" $dir] ||
	     [string match "${::TBCOMPAT::GROUPROOT}/*" $dir] ||
	     [string match "${::TBCOMPAT::USERROOT}/*" $dir] ||
	     [string match "${::TBCOMPAT::SHAREROOT}/*" $dir] ||
	     (${::TBCOMPAT::SCRATCHROOT} != "" &&
	      [string match "${::TBCOMPAT::SCRATCHROOT}/*" $dir]))} {
	    perror "\[$cmd] '$dir' refers to an NFS directory instead of the node's local disk."
840
	    return
841
	} elseif {![string match "/*" $dir]} {
842
	    perror "\[$cmd] '$dir' is not an absolute path."
843
	    return
844 845
	}

846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869
	# Skip verification in passmode.
	if { !${GLOBALS::anonymous} && !${GLOBALS::passmode}} {
	    # Check the tar file to make sure it exists, is readable, etc...
	    if {[string match "*://*" $tarfile]} {
		# It is a URL, check for a valid protocol.
		if {![::TBCOMPAT::verify-url $tarfile]} {
		    perror "\[$cmd] '$tarfile' is not an http, https, or ftp URL."
		    return
		}
	    } elseif {![string match "${::TBCOMPAT::PROJROOT}/*" $tarfile] &&
		      ![string match "${::TBCOMPAT::GROUPROOT}/*" $tarfile] &&
		      ![string match "${::TBCOMPAT::USERROOT}/*" $tarfile] &&
		      (${::TBCOMPAT::SCRATCHROOT} == "" ||
		       ![string match "${::TBCOMPAT::SCRATCHROOT}/*" $tarfile])} {
		perror "\[$cmd] '$tarfile' is not in an allowed directory"
		return
	    } elseif {![file exists $tarfile]} {
		perror "\[$cmd] '$tarfile' does not exist."
		return
	    } elseif {![file isfile $tarfile]} {
		perror "\[$cmd] '$tarfile' is not a file."
		return
	    } elseif {![file readable $tarfile]} {
		perror "\[$cmd] '$tarfile' is not readable."
870 871 872 873 874 875 876 877 878 879
		return
	    }
	}

	# Make sure the tarfile has a valid extension.
	if {![string match "*.tar" $tarfile] &&
	    ![string match "*.tar.Z" $tarfile] &&
	    ![string match "*.tar.gz" $tarfile] &&
	    ![string match "*.tgz" $tarfile] &&
	    ![string match "*.tar.bz2" $tarfile]} {
880
	    perror "\[$cmd] '$tarfile' does not have a valid extension (e.g. *.tar, *.tar.Z, *.tar.gz, *.tgz)."
881 882
	    return
	}
883
	lappend tarfiles [list $dir $tarfile]
884 885
	set args [lrange $args 2 end]
    }
886 887 888 889 890 891 892 893 894 895 896
    return $tarfiles
}
proc tb-set-node-tarfiles {node args} {
    if {$args == {}} {
	perror "\[tb-set-node-tarfiles] tb-set-node-tarfiles <node> (<dir> <tar>)+"
	return
    }
    set tarfiles {}
    foreach el [tb-proc-tarfiles "tb-set-node-tarfiles" $args] {
	lappend tarfiles [join $el " "]
    }
897
    $node set tarfiles [join $tarfiles ";"]
Leigh Stoller's avatar
Leigh Stoller committed
898
}
899 900 901 902 903 904 905 906 907 908 909 910
proc tb-set-tarfiles {args} {
    if {$args == {}} {
	perror "\[tb-set-tarfiles] tb-set-tarfiles (<dir> <tar>)+"
	return
    }
    set tarfiles [tb-proc-tarfiles "tb-set-tarfiles" $args]
    if [info exists ::TBCOMPAT::tarfiles] {
	set ::TBCOMPAT::tarfiles [concat $::TBCOMPAT::tarfiles $tarfiles]
    } else {
	set ::TBCOMPAT::tarfiles $tarfiles
    }
}
911 912 913
proc tb-set-ip-routing {type} {
    var_import ::GLOBALS::default_ip_routing_type

914
    if {$type == {}} {
915
	perror "\[tb-set-ip-routing] No type given."
916 917 918
	return
    }
    if {($type != "none") &&
919 920
	($type != "ospf")} {
	perror "\[tb-set-ip-routing] Type is not one of none|ospf"
921 922
	return
    }
923
    set default_ip_routing_type $type
924
}
Leigh Stoller's avatar
Leigh Stoller committed
925 926 927 928 929 930
proc tb-set-node-usesharednode {node weight} {
    $node add-desire "pcshared" $weight
}
proc tb-set-node-sharingmode {node sharemode} {
    $node set sharing_mode $sharemode
}
Leigh Stoller's avatar
Leigh Stoller committed
931 932 933 934 935 936

# Lan/Link state routines.

# This takes two possible formats:
# tb-set-link-loss <link> <loss>
# tb-set-link-loss <src> <dst> <loss>
937
proc tb-set-link-loss {srclink args} {
Leigh Stoller's avatar
Leigh Stoller committed
938
    var_import ::TBCOMPAT::FLOAT
939 940
    if {[llength $args] == 2} {
	set dst [lindex $args 0]
Leigh Stoller's avatar
Leigh Stoller committed
941 942 943 944
	set lossrate [lindex $args 1]
	set sim [$srclink set sim]
	set reallink [$sim find_link $srclink $dst]
	if {$reallink == {}} {
945
	    perror "\[tb-set-link-loss] No link between $srclink and $dst."
Leigh Stoller's avatar
Leigh Stoller committed
946
	    return
947 948
	}
    } else {
Leigh Stoller's avatar
Leigh Stoller committed
949
	set reallink $srclink
950
	set lossrate [lindex $args 0]
Leigh Stoller's avatar
Leigh Stoller committed
951 952
    }
    if {([regexp $FLOAT $lossrate] == 0) ||
953
	(($lossrate != 0) && (($lossrate > 1.0) || ($lossrate < 0.000005)))} {
954
	perror "\[tb-set-link-loss] $lossrate is not a valid loss rate."
Leigh Stoller's avatar
Leigh Stoller committed
955
    }
956 957
    $reallink instvar loss
    $reallink instvar rloss
Leigh Stoller's avatar
Leigh Stoller committed
958 959 960
    set adjloss [expr 1-sqrt(1-$lossrate)]
    foreach pair [array names loss] {
	set loss($pair) $adjloss
961
	set rloss($pair) $adjloss
962
    }
963
}
964

965
# This takes two possible formats:
Mike Hibler's avatar
Mike Hibler committed
966 967
# tb-set-link-est-bandwidth <link> <bandwidth>
# tb-set-link-est-bandwidth <src> <dst> <bandwidth>
968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990
proc tb-set-link-est-bandwidth {srclink args} {
    if {[llength $args] == 2} {
	set dst [lindex $args 0]
	set bw [lindex $args 1]
	set sim [$srclink set sim]
	set reallink [$sim find_link $srclink $dst]
	if {$reallink == {}} {
	    perror "\[tb-set-link-est-bandwidth] No link between $srclink and $dst."
	    return
	}
    } else {
	set reallink $srclink
	set bw [lindex $args 0]
    }
    $reallink instvar bandwidth
    $reallink instvar ebandwidth 
    $reallink instvar rebandwidth
    foreach pair [array names bandwidth] {
	set ebandwidth($pair) [parse_bw $bw]
	set rebandwidth($pair) [parse_bw $bw]
    }
}

991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034
# This takes two possible formats:
# tb-set-link-backfill <link> <bw>
# tb-set-link-backfill <src> <dst> <bw>
proc tb-set-link-backfill {srclink args} {
    if {[llength $args] == 2} {
	set dst [lindex $args 0]
	set bw [lindex $args 1]
	set sim [$srclink set sim]
	set reallink [$sim find_link $srclink $dst]
	if {$reallink == {}} {
	    perror "\[tb-set-link-backfill] No link between $srclink and $dst."
	    return
	}
    } else {
	if {[$srclink info class] != "Link"} {
	    perror "\[tb-set-link-backfill] $srclink is not a link."
	    return
	}
	set reallink $srclink
	set bw [lindex $args 0]
    }
    $reallink instvar bandwidth
    $reallink instvar backfill
    $reallink instvar rbackfill
    foreach pair [array names bandwidth] {
	set backfill($pair) [parse_bw $bw]
	set rbackfill($pair) [parse_bw $bw]
    }
}

# This takes two possible formats:
# tb-set-link-backfill <link> <src> <bw>
proc tb-set-link-simplex-backfill {link src bw} {
    var_import ::TBCOMPAT::FLOAT
    if {[$link info class] != "Link"} {
	perror "\[tb-set-link-simplex-backfill] $link is not a link."
	return
    }
    if {[$src info class] != "Node"} {
	perror "\[tb-set-link-simplex-backfill] $src is not a node."
	return
    }
    set port [$link get_port $src]
    if {$port == {}} {
1035
	perror "\[tb-set-link-simplex-backfill] $src is not in $link."
1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048
	return
    }
    set np [list $src $port]
    foreach nodeport [$link set nodelist] {
	if {$nodeport != $np} {
	    set onp $nodeport
	}
    }
    set realbw [parse_bw $bw]
    $link set backfill($np) $realbw
    $link set rbackfill($onp) $realbw
}

Leigh Stoller's avatar
Leigh Stoller committed
1049 1050 1051
proc tb-set-lan-loss {lan lossrate} {
    var_import ::TBCOMPAT::FLOAT
    if {[$lan info class] != "Lan"} {
1052
	perror "\[tb-set-lan-loss] $lan is not a lan."
Leigh Stoller's avatar
Leigh Stoller committed
1053 1054 1055
	return
    }
    if {([regexp $FLOAT $lossrate] == 0) ||
1056
	(($lossrate != 0) && (($lossrate > 1.0) || ($lossrate < 0.000005)))} {
1057
	perror "\[tb-set-lan-loss] $lossrate is not a valid loss rate."
Leigh Stoller's avatar
Leigh Stoller committed
1058 1059
    }
    $lan instvar loss
1060
    $lan instvar rloss
Leigh Stoller's avatar
Leigh Stoller committed
1061 1062 1063
    set adjloss [expr 1-sqrt(1-$lossrate)]
    foreach pair [array names loss] {
	set loss($pair) $adjloss
1064
	set rloss($pair) $adjloss
Leigh Stoller's avatar
Leigh Stoller committed
1065
    }
Christopher Alfeld's avatar
Christopher Alfeld committed
1066
}
Leigh Stoller's avatar
Leigh Stoller committed
1067

1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082
proc tb-set-lan-est-bandwidth {lan bw} {
    if {[$lan info class] != "Lan"} {
	perror "\[tb-set-lan-est-bandwidth] $lan is not a lan."
	return
    }

    $lan instvar bandwidth
    $lan instvar ebandwidth 
    $lan instvar rebandwidth
    foreach pair [array names bandwidth] {
	set ebandwidth($pair) [parse_bw $bw]
	set rebandwidth($pair) [parse_bw $bw]
    }
}

1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097
proc tb-set-lan-backfill {lan bw} {
    if {[$lan info class] != "Lan"} {
	perror "\[tb-set-lan-backfill] $lan is not a lan."
	return
    }

    $lan instvar bandwidth
    $lan instvar backfill
    $lan instvar rbackfill
    foreach pair [array names bandwidth] {
	set backfill($pair) [parse_bw $bw]
	set rbackfill($pair) [parse_bw $bw]
    }
}

Leigh Stoller's avatar
Leigh Stoller committed
1098 1099
proc tb-set-node-lan-delay {node lan delay} {
    if {[$node info class] != "Node"} {
1100
	perror "\[tb-set-node-lan-delay] $node is not a node."
Leigh Stoller's avatar
Leigh Stoller committed
1101 1102 1103
	return
    }
    if {[$lan info class] != "Lan"} {
1104
	perror "\[tb-set-node-lan-delay] $lan is not a lan."
Leigh Stoller's avatar
Leigh Stoller committed
1105 1106 1107 1108
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
1109
	perror "\[tb-set-node-lan-delay] $node is not in $lan."
Leigh Stoller's avatar
Leigh Stoller committed
1110 1111
	return
    }
Mike Hibler's avatar
Mike Hibler committed
1112 1113 1114 1115

    set rdelay [parse_delay $delay]
    $lan set delay([list $node $port]) $rdelay
    $lan set rdelay([list $node $port]) $rdelay
Christopher Alfeld's avatar
Christopher Alfeld committed
1116
}
1117 1118


Leigh Stoller's avatar
Leigh Stoller committed
1119 1120
proc tb-set-node-lan-bandwidth {node lan bw} {
    if {[$node info class] != "Node"} {
1121
	perror "\[tb-set-node-lan-bandwidth] $node is not a node."
Leigh Stoller's avatar
Leigh Stoller committed
1122 1123 1124
	return
    }
    if {[$lan info class] != "Lan"} {
1125
	perror "\[tb-set-node-lan-bandwidth] $lan is not a lan."
Leigh Stoller's avatar
Leigh Stoller committed
1126 1127 1128 1129
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
1130
	perror "\[tb-set-node-lan-bandwidth] $node is not in $lan."
Leigh Stoller's avatar
Leigh Stoller committed
1131 1132 1133
	return
    }
    $lan set bandwidth([list $node $port]) [parse_bw $bw]
1134
    $lan set rbandwidth([list $node $port]) [parse_bw $bw]
1135
}
1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152
proc tb-set-node-lan-est-bandwidth {node lan bw} {
    if {[$node info class] != "Node"} {
	perror "\[tb-set-node-lan-est-bandwidth] $node is not a node."
	return
    }
    if {[$lan info class] != "Lan"} {
	perror "\[tb-set-node-lan-est-bandwidth] $lan is not a lan."
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
	perror "\[tb-set-node-lan-est-bandwidth] $node is not in $lan."
	return
    }
    $lan set ebandwidth([list $node $port]) [parse_bw $bw]
    $lan set rebandwidth([list $node $port]) [parse_bw $bw]
}
1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169
proc tb-set-node-lan-backfill {node lan bw} {
    if {[$node info class] != "Node"} {
	perror "\[tb-set-node-lan-backfill] $node is not a node."
	return
    }
    if {[$lan info class] != "Lan"} {
	perror "\[tb-set-node-lan-backfill] $lan is not a lan."
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
	perror "\[tb-set-node-lan-backfill] $node is not in $lan."
	return
    }
    $lan set backfill([list $node $port]) [parse_bw $bw]
    $lan set rbackfill([list $node $port]) [parse_bw $bw]
}
Leigh Stoller's avatar
Leigh Stoller committed
1170 1171 1172
proc tb-set-node-lan-loss {node lan loss} {
    var_import ::TBCOMPAT::FLOAT
    if {[$node info class] != "Node"} {
Mike Hibler's avatar
Mike Hibler committed
1173
	perror "\[tb-set-node-lan-loss] $node is not a node."
Leigh Stoller's avatar
Leigh Stoller committed
1174 1175 1176
	return
    }
    if {[$lan info class] != "Lan"} {
Mike Hibler's avatar
Mike Hibler committed
1177
	perror "\[tb-set-node-lan-loss] $lan is not a lan."
Leigh Stoller's avatar
Leigh Stoller committed
1178 1179 1180 1181
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
Mike Hibler's avatar
Mike Hibler committed
1182
	perror "\[tb-set-node-lan-loss] $node is not in $lan."
Leigh Stoller's avatar
Leigh Stoller committed
1183 1184 1185
	return
    }
    if {([regexp $FLOAT $loss] == 0) ||
1186
	(($loss != 0) && (($loss > 1.0) || ($loss < 0.000005)))} {
1187
	perror "\[tb-set-link-loss] $loss is not a valid loss rate."
Leigh Stoller's avatar
Leigh Stoller committed
1188 1189
    }
    $lan set loss([list $node $port]) $loss
1190
    $lan set rloss([list $node $port]) $loss
Christopher Alfeld's avatar
Christopher Alfeld committed
1191
}
Leigh Stoller's avatar
Leigh Stoller committed
1192 1193 1194 1195
proc tb-set-node-lan-params {node lan delay bw loss} {
    tb-set-node-lan-delay $node $lan $delay
    tb-set-node-lan-bandwidth $node $lan $bw
    tb-set-node-lan-loss $node $lan $loss
1196
}
1197 1198

proc tb-set-node-failure-action {node type} {
1199
    if {[$node info class] != "Node" && [$node info class] != "Bridge"} {
1200 1201 1202 1203 1204 1205 1206 1207
	perror "\[tb-set-node-failure-action] $node is not a node."
	return
    }
    if {[lsearch -exact {fatal nonfatal ignore} $type] == -1} {
	perror "\[tb-set-node-failure-action] type must be one of fatal|nonfatal|ignore."
	return
    }
    $node set failureaction $type
1208 1209
}

1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221
proc tb-set-link-failure-action {lanlink type} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-link-failure-action] $lanlink is not a link or a lan."
	return
    }
    if {[lsearch -exact {fatal nonfatal} $type] == -1} {
	perror "\[tb-set-link-failure-action] must be one of fatal|nonfatal"
	return
    }
    $lanlink set failureaction $type
}

1222
proc tb-fix-node {vnode pnode} {
1223
    if {[$vnode info class] != "Node" && 
Kirk Webb's avatar
Kirk Webb committed
1224
	[$vnode info class] != "Blockstore"} {
1225
	perror "\[tb-fix-node] $vnode is not a node."
1226 1227
	return
    }
1228
    $vnode set_fixed $pnode
1229 1230
}

1231 1232
proc tb-make-soft-vtype {name types} {
    var_import ::TBCOMPAT::hwtypes
1233
    var_import ::TBCOMPAT::isremote
1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246
    var_import ::GLOBALS::vtypes
    var_import ::TBCOMPAT::default_soft_vtype_weight

    foreach type $types {
	if {! [info exists hwtypes($type)]} {
	    perror "\[tb-make-soft-vtype] Invalid hardware type $type."
	}
    }
    set vtypes($name) [Vtype $name $default_soft_vtype_weight $types]
}

proc tb-make-hard-vtype {name types} {
    var_import ::TBCOMPAT::hwtypes
1247
    var_import ::TBCOMPAT::isremote
1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260
    var_import ::GLOBALS::vtypes
    var_import ::TBCOMPAT::default_hard_vtype_weight

    foreach type $types {
	if {! [info exists hwtypes($type)]} {
	    perror "\[tb-make-hard-vtype] Invalid hardware type $type."
	}
    }
    set vtypes($name) [Vtype $name $default_hard_vtype_weight $types]
}

proc tb-make-weighted-vtype {name weight types} {
    var_import ::TBCOMPAT::hwtypes
1261
    var_import ::TBCOMPAT::isremote
1262 1263 1264 1265 1266
    var_import ::GLOBALS::vtypes
    var_import ::TBCOMPAT::FLOAT

    foreach type $types {
	if {! [info exists hwtypes($type)]} {
1267 1268 1269 1270
	    perror "\[tb-make-weighted-vtype] Invalid hardware type $type."
	}
	if {$isremote($type)} {
	    perror "\[tb-make-weighted-vtype] Remote type $type not allowed."
1271 1272 1273 1274 1275 1276 1277
	}
    }
    if {([regexp $FLOAT $weight] == 0) ||
	($weight <= 0) || ($weight >= 1.0)} {
	perror "\[tb-make-weighted-vtype] $weight is not a valid weight. (0 < weight < 1)."
    }
    set vtypes($name) [Vtype $name $weight $types]
1278 1279 1280 1281 1282 1283 1284 1285 1286
}

proc tb-set-link-simplex-params {link src delay bw loss} {
    var_import ::TBCOMPAT::FLOAT
    if {[$link info class] != "Link"} {
	perror "\[tb-set-link-simplex-params] $link is not a link."
	return
    }
    if {[$src info class] != "Node"} {
1287
	perror "\[tb-set-link-simplex-params] $src is not a node."
1288 1289 1290 1291 1292 1293 1294
	return
    }
    set port [$link get_port $src]
    if {$port == {}} {
	perror "\[tb-set-link-simplex-params] $src is not in $link."
	return
    }
1295
    if {([regexp $FLOAT $loss] == 0) ||
1296
	(($loss != 0) && (($loss > 1.0) || ($loss < 0.000005)))} {
1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317
	perror "\[tb-set-link-simplex-params] $loss is not a valid loss rate."
	return
    }
    set adjloss [expr 1-sqrt(1-$loss)]
    set np [list $src $port]
    foreach nodeport [$link set nodelist] {
	if {$nodeport != $np} {
	    set onp $nodeport
	}
    }

    set realdelay [parse_delay $delay]
    set realbw [parse_bw $bw]
    $link set delay($np) [expr $realdelay / 2.0]
    $link set rdelay($onp) [expr $realdelay / 2.0]
    $link set bandwidth($np) $realbw
    $link set rbandwidth($onp) $realbw
    $link set loss($np) [expr $adjloss]
    $link set rloss($onp) [expr $adjloss]
}

1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339
proc tb-set-lan-simplex-backfill {lan node tobw frombw} {
    var_import ::TBCOMPAT::FLOAT
    if {[$node info class] != "Node"} {
	perror "\[tb-set-lan-simplex-params] $node is not a node."
	return
    }
    if {[$lan info class] != "Lan"} {
	perror "\[tb-set-lan-simplex-params] $lan is not a lan."
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
	perror "\[tb-set-lan-simplex-params] $node is not in $lan."
	return
    }
    set realtobw [parse_backfill $tobw]
    set realfrombw [parse_backfill $frombw]

    $lan set backfill([list $node $port]) $realtobw
    $lan set rbackfill([list $node $port]) $realfrombw
}

1340 1341 1342
proc tb-set-lan-simplex-params {lan node todelay tobw toloss fromdelay frombw fromloss} {
    var_import ::TBCOMPAT::FLOAT
    if {[$node info class] != "Node"} {
Mike Hibler's avatar
Mike Hibler committed
1343
	perror "\[tb-set-lan-simplex-params] $node is not a node."
1344 1345 1346
	return
    }
    if {[$lan info class] != "Lan"} {
Mike Hibler's avatar
Mike Hibler committed
1347
	perror "\[tb-set-lan-simplex-params] $lan is not a lan."
1348 1349 1350 1351
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
Mike Hibler's avatar
Mike Hibler committed
1352
	perror "\[tb-set-lan-simplex-params] $node is not in $lan."
1353 1354
	return
    }
1355
    if {([regexp $FLOAT $toloss] == 0) ||
1356
	(($toloss != 0) && (($toloss > 1.0) || ($toloss < 0.000005)))} {
1357 1358
	perror "\[tb-set-link-loss] $toloss is not a valid loss rate."
    }
1359
    if {([regexp $FLOAT $fromloss] == 0) ||
1360
	(($fromloss != 0) && (($fromloss > 1.0) || ($fromloss < 0.000005)))} {
1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374
	perror "\[tb-set-link-loss] $fromloss is not a valid loss rate."
    }

    set realtodelay [parse_delay $todelay]
    set realfromdelay [parse_delay $fromdelay]
    set realtobw [parse_bw $tobw]
    set realfrombw [parse_bw $frombw]

    $lan set delay([list $node $port]) $realtodelay
    $lan set rdelay([list $node $port]) $realfromdelay
    $lan set loss([list $node $port]) $toloss
    $lan set rloss([list $node $port]) $fromloss
    $lan set bandwidth([list $node $port]) $realtobw
    $lan set rbandwidth([list $node $port]) $realfrombw
1375 1376 1377
}

proc tb-set-uselatestwadata {onoff} {
1378
    var_import ::GLOBALS::uselatestwadata
1379 1380 1381 1382 1383 1384 1385 1386

    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-set-uselatestwadata] $onoff must be 0/1"
	return
    }

    set uselatestwadata $onoff
}
1387

1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398
proc tb-set-usewatunnels {onoff} {
    var_import ::GLOBALS::usewatunnels

    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-set-usewatunnels] $onoff must be 0/1"
	return
    }

    set usewatunnels $onoff
}

1399
proc tb-use-endnodeshaping {onoff} {
1400 1401 1402
    var_import ::GLOBALS::uselinkdelays

    if {$onoff != 0 && $onoff != 1} {
1403
	perror "\[tb-use-endnodeshaping] $onoff must be 0/1"
1404 1405 1406 1407 1408 1409
	return
    }

    set uselinkdelays $onoff
}

1410
proc tb-force-endnodeshaping {onoff} {
1411 1412 1413
    var_import ::GLOBALS::forcelinkdelays

    if {$onoff != 0 && $onoff != 1} {
1414
	perror "\[tb-force-endnodeshaping] $onoff must be 0/1"
1415 1416 1417 1418 1419 1420
	return
    }

    set forcelinkdelays $onoff
}

1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438
proc tb-set-wasolver-weights {delay bw plr} {
    var_import ::GLOBALS::wa_delay_solverweight
    var_import ::GLOBALS::wa_bw_solverweight
    var_import ::GLOBALS::wa_plr_solverweight

    if {($delay < 0) || ($bw < 0) || ($plr < 0)} {
	perror "\[tb-set-wasolver-weights] Weights must be postive integers."
	return
    }
    if {($delay == {}) || ($bw == {}) || ($plr == {})} {
	perror "\[tb-set-wasolver-weights] Must provide delay, bw, and plr."
	return
    }

    set wa_delay_solverweight $delay
    set wa_bw_solverweight $bw
    set wa_plr_solverweight $plr
}
1439 1440

#
1441
# Control emulated for a link
1442
# 
1443 1444 1445
proc tb-set-multiplexed {lanlink onoff} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan" } {
	perror "\[tb-set-multiplexed] $link is not a link or a lan."
1446 1447
	return
    }
1448 1449 1450 1451 1452 1453

    # looks like our GUI will spit out non-zero values other than 1 so...
    if {$onoff != 0} {
	set onoff 1
    }

1454
    $lanlink set emulated $onoff
1455 1456 1457
}

#
1458
# For emulated links, allow bw shaping to be turned off
1459
# 
1460 1461 1462
proc tb-set-noshaping {lanlink onoff} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan" } {
	perror "\[tb-set-noshaping] $link is not a link or a lan."
1463 1464
	return
    }
1465 1466 1467 1468 1469
    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-set-noshaping] $onoff must be 0/1"
	return
    }

1470
    $lanlink set nobwshaping $onoff
1471
}
1472

1473 1474
#
# For emulated links, allow veth device to be used. Not a user option.
1475
# XXX backward compat, use tb-set-link-encap now.
1476
# 
1477 1478 1479
proc tb-set-useveth {lanlink onoff} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-useveth] $link is not a link or a lan."
1480 1481
	return
    }
1482 1483 1484 1485 1486
    if {$onoff == 0} {
	$lanlink set encap "default"
    } else {
	$lanlink set encap "veth"
    }
1487 1488
}

1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499
#
# For emulated links, allow specifying encapsulation style.
# Generalizes tb-set-useveth.
# 
proc tb-set-link-encap {lanlink style} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-link-encap] $link is not a link or a lan."
	return
    }

    switch -- $style {
1500 1501 1502 1503 1504 1505 1506 1507
	"gre" {
	    set style "gre"
	}
	"egre" {
	    set style "egre"
	}
	"vtun" {
	    set style "vtun"
1508
	}
1509 1510 1511 1512
	"veth-ne" {
	    set style "veth-ne"
	}
	"vlan" {
1513
	    set style "vlan"
1514 1515
	}
	default {
1516
	    perror "\[tb-set-link-encap] one of: 'veth-ne', 'vlan'"
1517 1518 1519 1520 1521 1522 1523 1524
	    return
	}
    }

    $lanlink set encap $style
}


1525 1526 1527 1528 1529 1530
#
# Control linkdelays for lans and links
# 
proc tb-set-endnodeshaping {lanlink onoff} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-endnodeshaping] $lanlink is not a link or a lan."
1531 1532
	return
    }
1533 1534 1535 1536 1537
    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-set-endnodeshaping] $onoff must be 0/1"
	return
    }

1538
    $lanlink set uselinkdelay $onoff
1539
}
1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550

#
# Crude control of colocation of virt nodes. Will be flushed when we have
# a real story. Sets it for the entire link or lan. Maybe set it on a
# per node basis?
#
proc tb-set-allowcolocate {lanlink onoff} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-allowcolocate] $lanlink is not a link or a lan."
	return
    }
1551 1552 1553 1554 1555
    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-set-allowcolocate] $onoff must be 0/1"
	return
    }

1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572
    $lanlink set trivial_ok $onoff
}

#
# Another crude control. Allow override of multiplex factor that is listed
# in the node_types table. 
#
proc tb-set-colocate-factor {factor} {
    var_import ::GLOBALS::multiplex_factor

    if {$factor < 1 || $factor > 100} {
	perror "\[tb-set-colocate-factor] factor must be 1 <= factor <= 100"
	return
    }

    set multiplex_factor $factor
}
1573

1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587
#
# Set the packing strategy assign uses.
#
proc tb-set-packing-strategy {strategy} {
    var_import ::GLOBALS::packing_strategy

    if {$strategy != "pack" && $strategy != "balance"} {
	perror "\[tb-set-packing-strategy] strategy must be pack|balance"
	return
    }

    set packing_strategy $strategy
}

1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600
#
# Set the sync server for the experiment. Must a vnode name that has been
# allocated.
#
proc tb-set-sync-server {node} {
    var_import ::GLOBALS::sync_server

    if {[$node info class] != "Node"} {
	perror "\[tb-set-sync-server] $node is not a node."
	return
    }
    set sync_server $node
}
Leigh Stoller's avatar
Leigh Stoller committed
1601

1602 1603 1604 1605 1606 1607 1608
#
# Turn on or of the ipassign program for IP address assignment and route
# calculation
#
proc tb-use-ipassign {onoff} {
    var_import ::GLOBALS::use_ipassign

1609 1610 1611 1612 1613
    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-use-ipassign] $onoff must be 0/1"
	return
    }

1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625
    set use_ipassign $onoff
}

#
# Give arguments for ipassign
#
proc tb-set-ipassign-args {stuff} {
    var_import ::GLOBALS::ipassign_args

    set ipassign_args $stuff
}

Leigh Stoller's avatar
Leigh Stoller committed
1626 1627 1628 1629 1630
#
# Set the startup command for a node. Replaces the tb-set-node-startup
# command above, but we have to keep that one around for a while. This
# new version dispatched to the node object, which uses a program object.
# 
1631
proc tb-set-node-startcmd {node command} {
Leigh Stoller's avatar
Leigh Stoller committed
1632
    if {[$node info class] != "Node"} {
1633
	perror "\[tb-set-node-startcmd] $node is not a node."
Leigh Stoller's avatar
Leigh Stoller committed
1634 1635
	return
    }
1636
    set command "($command ; /usr/local/etc/emulab/startcmddone \$?)"
1637 1638 1639
    set newprog [$node start-command $command]

    return $newprog
Leigh Stoller's avatar
Leigh Stoller committed
1640
}
1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665

#
# More crude controls.
#
proc tb-set-mem-usage {usage} {
    var_import ::GLOBALS::mem_usage

    if {$usage < 1 || $usage > 5} {
	perror "\[tb-set-mem-usage] usage must be 1 <= factor <= 5"
	return
    }

    set mem_usage $usage
}
proc tb-set-cpu-usage {usage} {
    var_import ::GLOBALS::cpu_usage

    if {$usage < 1 || $usage > 5} {
	perror "\[tb-set-cpu-usage] usage must be 1 <= factor <= 5"
	return
    }

    set cpu_usage $usage
}

1666 1667 1668 1669 1670
#
# This is nicer syntax for subnodes.
#
proc tb-bind-parent {sub phys} {
    tb-fix-node $sub $phys
1671
}
1672

1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683
proc tb-fix-current-resources {onoff} {
    var_import ::GLOBALS::fix_current_resources

    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-fix-current-resources] $onoff must be 0/1"
	return
    }

    set fix_current_resources $onoff
}

1684 1685 1686 1687
#
# Control veth encapsulation. 
# 
proc tb-set-encapsulate {onoff} {
1688
    var_import ::GLOBALS::vlink_encapsulate
1689

1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705
    if {$onoff == 0} {
	set vlink_encapsulate "veth-ne"
    } elseif {$onoff == 1} {
	set vlink_encapsulate "default"
    } else {
	perror "\[tb-set-encapsulate] $onoff must be 0/1"
    }
}

#
# Control virtual link emulation style.
# 
proc tb-set-vlink-emulation {style} {
    var_import ::GLOBALS::vlink_encapsulate

    switch -- $style {
1706 1707 1708 1709 1710 1711 1712 1713
	"gre" {
	    set style "gre"
	}
	"egre" {
	    set style "egre"
	}
	"vtun" {
	    set style "vtun"
1714
	}
1715 1716 1717 1718
	"veth-ne" {
	    set style "veth-ne"
	}
	"vlan" {
1719
	    set style "vlan"
1720
	}
1721 1722 1723
	"alias" {
	    set style "alias"
	}
1724
	default {
1725
	    perror "\[tb-set-encapsulate] one of: 'veth-ne', 'vlan'"
1726 1727
	    return
	}
1728
    }
1729
    set vlink_encapsulate $style
1730 1731
}

1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759
#
# Control jail and delay nodes osnames. 
# 
proc tb-set-jail-os {os} {
    var_import ::GLOBALS::jail_osname
    
    if {! ${GLOBALS::anonymous} && ! ${GLOBALS::passmode}} {
	var_import ::TBCOMPAT::osids
	if {! [info exists osids($os)]} {
	    perror "\[tb-set-jail-os] Invalid osid $os."
	    return
	}
    }
    set jail_osname $os
}
proc tb-set-delay-os {os} {
    var_import ::GLOBALS::delay_osname
    
    if {! ${GLOBALS::anonymous} && ! ${GLOBALS::passmode}} {
	var_import ::TBCOMPAT::osids
	if {! [info exists osids($os)]} {
	    perror "\[tb-set-delay-os] Invalid osid $os."
	    return
	}
    }
    set delay_osname $os
}

1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773
#
# Set the delay capacity override. This is not documented cause we
# do not want people to do this!
#
proc tb-set-delay-capacity {cap} {
    var_import ::GLOBALS::delay_capacity

    if { $cap <= 0 || $cap > @DELAYCAPACITY@ } {
	perror "\[tb-set-delay-capacity] Must be 0 < X <= @DELAYCAPACITY@"
	return
    }
    set delay_capacity $cap
}

1774 1775 1776
#
# Allow type of lans (but not links) to be changed.
#
1777
proc tb-set-lan-protocol {lanlink protocol} {
1778
    if {[$lanlink info class] != "Lan"} {
1779
	perror "\[tb-set-lan-protocol] $lanlink is not a lan."
1780 1781 1782 1783 1784
	return
    }
    $lanlink set protocol $protocol
}

1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795
#
# Allow type of links (but not LANs) to be changed.
#
proc tb-set-link-protocol {lanlink protocol} {
    if {[$lanlink info class] != "Link"} {
	perror "\[tb-set-lan-protocol] $lanlink is not a link."
	return
    }
    $lanlink set protocol $protocol
}

1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807
#
# Set the fabric. We change the protocol as well.
#
proc tb-set-switch-fabric {lanlink fabric} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-lan-protocol] $lanlink is not a link or lan."
	return
    }
    $lanlink set protocol $fabric
    $lanlink set_setting "switch_fabric" $fabric
}

1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823
#
# XXX - We need to set the accesspoint for a wireless lan. I have no
# idea how this will eventually be done, but for now just do it manually.
# 
proc tb-set-lan-accesspoint {lanlink node} {
    if {[$lanlink info class] != "Lan"} {
	perror "\[tb-set-lan-accesspoint] $lanlink is not a lan."
	return
    }
    if {[$node info class] != "Node"} {
	perror "\[tb-set-lan-accesspoint] $node is not a node."
	return
    }
    $lanlink set_accesspoint $node
}

1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844
#
# Set capabilities for lans and members of lans.
#
proc tb-set-lan-setting {lanlink capkey capval} {
    if {[$lanlink info class] != "Lan"} {
	perror "\[tb-set-lan-setting] $lanlink is not a lan."
	return
    }
    $lanlink set_setting $capkey $capval
}
proc tb-set-node-lan-setting {lanlink node capkey capval} {
    if {[$lanlink info class] != "Lan"} {
	perror "\[tb-set-node-lan-setting] $lanlink is not a lan."
	return
    }
    if {[$node info class] != "Node"} {
	perror "\[tb-set-node-lan-setting] $node is not a node."
	return
    }
    $lanlink set_member_setting $node $capkey $capval
}
1845 1846 1847 1848 1849 1850 1851 1852

#
# Turn on or of the use of phys naming; if the user name for the node
# matches a real node in the testbed, do an implicit fix-node to it.
#
proc tb-use-physnaming {onoff} {
    var_import ::GLOBALS::use_physnaming

1853 1854 1855 1856 1857
    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-use-physnaming] $onoff must be 0/1"
	return
    }

1858 1859 1860
    set use_physnaming $onoff
}

1861 1862 1863 1864 1865 1866 1867 1868 1869 1870
#
# Write to the tb-experimental log file, as defined by the tbxlogfile global
# variable.  If the tbxlogfile variable is not set, the message is sent to
# /dev/null.
#
# @param msg The message to write to the log file.
#
# @global tbxlogfile The path to the log file, if defined.
#
proc tbx-log {msg} {
1871
    var_import ::TBCOMPAT::tbxlogfile;
1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886

    if {[info exists tbxlogfile]} {
	puts $tbxlogfile $msg
    }
}

##
## BEGIN Feedback
##

proc tb-feedback-vnode {vnode hardware args} {
    var_import ::TBCOMPAT::isvirt;        # Make sure $hardware is a vnode.
    var_import ::TBCOMPAT::Reservations;  # The reservations to make for nodes.
    var_import ::TBCOMPAT::BootstrapReservations;  # Bootstrap file.
    var_import ::TBCOMPAT::Alerts;        # Alert indicators
1887 1888 1889
    var_import ::GLOBALS::fix_current_resources

    ::GLOBALS::named-args $args {
1890
	-scale 1.2 -rclass "" -alertscale 2.0 -initscale 0.01
1891
    }
1892

1893
    set fix_current_resources 0
1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913

    # Check our inputs,
    if {[$vnode info class] != "Node"} {
	perror "\[