Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
emulab
emulab-devel
Commits
9c17c18d
Commit
9c17c18d
authored
Nov 26, 2012
by
Kirk Webb
Browse files
Merge branch 'stordev-parser'
parents
8b322701
07f6693e
Changes
13
Hide whitespace changes
Inline
Side-by-side
db/BlockstoreType.pm
0 → 100644
View file @
9c17c18d
#!/usr/bin/perl -wT
#
# Copyright (c) 2012 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/>.
#
# }}}
#
package
BlockstoreType
;
use
strict
;
use
Exporter
;
use
vars
qw(@ISA @EXPORT)
;
@ISA
=
"
Exporter
";
@EXPORT
=
qw (
);
use
libdb
;
use
libtestbed
;
use
English
;
use
Data::
Dumper
;
use
overload
('
""
'
=>
'
Stringify
');
# Cache of instances to avoid regenerating them.
my
%bstypes
=
();
my
$debug
=
0
;
# Little helper and debug function.
sub
mysystem
($)
{
my
(
$command
)
=
@_
;
print
STDERR
"
Running '
$command
'
\n
"
if
(
$debug
);
return
system
(
$command
);
}
#
# Lookup a (physical) storage object type and create a class instance to
# return.
#
sub
Lookup
($$)
{
my
(
$class
,
$type
)
=
@_
;
# Look in cache first
return
$bstypes
{
$type
}
if
(
exists
(
$bstypes
{
$type
}));
my
$self
=
{};
$self
->
{"
TYPE
"}
=
$type
;
$self
->
{"
ATTRS
"}
=
undef
;
bless
(
$self
,
$class
);
# Load attributes for type from DB. No attrs means type doesn't exist.
$self
->
LoadAttributes
();
if
(
!
$self
->
{"
ATTRS
"})
{
return
undef
;
}
# Add to cache.
$bstypes
{
$type
}
=
$self
;
return
$self
;
}
#
# Force a reload of the data.
#
sub
LookupSync
($$)
{
my
(
$class
,
$type
)
=
@_
;
# delete from cache
delete
(
$bstypes
{
$type
})
if
(
exists
(
$bstypes
{
$type
}));
return
Lookup
(
$class
,
$type
);
}
#
# Return a list of all types.
#
sub
AllTypes
($)
{
my
(
$class
)
=
@_
;
my
@alltypes
=
();
my
$query_result
=
DBQueryWarn
("
select distinct type from blockstore_type_attributes
");
return
()
if
(
!
$query_result
||
!
$query_result
->
numrows
);
while
(
my
(
$type
)
=
$query_result
->
fetchrow_array
())
{
my
$typeinfo
=
Lookup
(
$class
,
$type
);
# Something went wrong?
return
()
if
(
!
defined
(
$typeinfo
));
push
(
@alltypes
,
$typeinfo
);
}
return
@alltypes
;
}
sub
AllClasses
($)
{
my
(
$class
)
=
@_
;
my
@allclasses
=
();
my
@alltypes
=
$class
->
AllTypes
();
foreach
my
$bst
(
@alltypes
)
{
my
$cl
=
$bst
->
class
();
if
(
$cl
)
{
push
(
@allclasses
,
$cl
)
}
}
return
@allclasses
;
}
sub
AllProtocols
($)
{
my
(
$class
)
=
@_
;
my
@allprotos
=
();
my
@alltypes
=
$class
->
AllTypes
();
foreach
my
$bst
(
@alltypes
)
{
my
$proto
=
$bst
->
protocol
();
if
(
$proto
)
{
push
(
@allprotos
,
$proto
)
}
}
return
@allprotos
;
}
#
# Load attributes if not already loaded.
#
sub
LoadAttributes
($)
{
my
(
$self
)
=
@_
;
return
-
1
if
(
!
ref
(
$self
));
return
0
if
(
defined
(
$self
->
{"
ATTRS
"}));
#
# Get the attribute array.
#
my
$type
=
$self
->
type
();
my
$query_result
=
DBQueryWarn
("
select attrkey,attrvalue,attrtype
"
.
"
from blockstore_type_attributes
"
.
"
where type='
$type
'
");
$self
->
{"
ATTRS
"}
=
{};
while
(
my
(
$key
,
$val
,
$type
)
=
$query_result
->
fetchrow_array
())
{
$self
->
{"
ATTRS
"}
->
{
$key
}
=
{
"
key
"
=>
$key
,
"
value
"
=>
$val
,
"
type
"
=>
$type
};
}
return
0
;
}
#
# Stringify for output.
#
sub
Stringify
($)
{
my
(
$self
)
=
@_
;
my
$type
=
$self
->
type
();
my
$class
=
$self
->
class
();
return
"
[BlockstoreType:
$type
/
$class
]
";
}
#
# Look for an attribute.
#
sub
GetAttribute
($$
;
$$
)
{
my
(
$self
,
$attrkey
,
$pattrvalue
,
$pattrtype
)
=
@_
;
goto
bad
if
(
!
ref
(
$self
));
$self
->
LoadAttributes
()
==
0
or
goto
bad
;
if
(
!
exists
(
$self
->
{"
ATTRS
"}
->
{
$attrkey
}))
{
return
undef
if
(
!
defined
(
$pattrvalue
));
$$pattrvalue
=
undef
;
return
0
;
}
my
$ref
=
$self
->
{"
ATTRS
"}
->
{
$attrkey
};
# Return value instead if a $pattrvalue not provided.
return
$ref
->
{'
value
'}
if
(
!
defined
(
$pattrvalue
));
$$pattrvalue
=
$ref
->
{'
value
'};
$$pattrtype
=
$ref
->
{'
type
'}
if
(
defined
(
$pattrtype
));
return
0
;
bad:
return
undef
if
(
!
defined
(
$pattrvalue
));
$$pattrvalue
=
undef
;
return
-
1
;
}
#
# Grab all attributes.
#
sub
GetAttributes
($)
{
my
(
$self
)
=
@_
;
return
undef
if
(
!
ref
(
$self
));
$self
->
LoadAttributes
()
==
0
or
return
undef
;
return
$self
->
{"
ATTRS
"};
}
# Shortcuts for typical attributes.
sub
type
($)
{
return
$_
[
0
]
->
{'
TYPE
'};
}
sub
class
($;$) {
return
GetAttribute
(
$_
[
0
],
"
class
",
$_
[
1
]);
}
sub
protocol
($;$) {
return
GetAttribute
(
$_
[
0
],
"
protocol
",
$_
[
1
]);
}
#
# Set the value of an attribute
#
sub
SetAttribute
($$$
;
$
)
{
my
(
$self
,
$attrkey
,
$attrvalue
,
$attrtype
)
=
@_
;
goto
bad
if
(
!
ref
(
$self
));
$self
->
LoadAttributes
()
==
0
or
return
-
1
;
$attrtype
=
"
string
"
if
(
!
defined
(
$attrtype
));
my
$safe_attrvalue
=
DBQuoteSpecial
(
$attrvalue
);
my
$type
=
$self
->
type
();
DBQueryWarn
("
replace into blockstore_type_attributes set
"
.
"
type='
$type
', attrkey='
$attrkey
',
"
.
"
attrtype='
$attrtype
', attrvalue=
$safe_attrvalue
")
or
return
-
1
;
$self
->
{"
ATTRS
"}
->
{
$attrkey
}
=
$attrvalue
;
return
0
;
}
# _Always_ make sure that this 1 is at the end of the file...
1
;
db/Experiment.pm.in
View file @
9c17c18d
...
...
@@ -174,7 +174,9 @@ $EXPT_RESOURCESHOSED = 0;
"virt_blobs"
,
"virt_client_service_ctl"
,
"virt_client_service_hooks"
,
"virt_client_service_opts"
);
"virt_client_service_opts"
,
"virt_blockstores"
,
"virt_blockstore_attributes"
);
%
physicalTables
=
(
"delays"
=>
[
"node_id"
,
"vname"
,
"vnode0"
,
"vnode1"
],
"v2pmap"
=>
[
"node_id"
,
"vname"
],
...
...
db/GNUmakefile.in
View file @
9c17c18d
...
...
@@ -48,7 +48,7 @@ LIB_SCRIPTS = libdb.pm Node.pm libdb.py libadminctrl.pm Experiment.pm \
Image.pm OSinfo.pm Archive.pm Logfile.pm Lan.pm emdbi.pm \
emdb.pm emutil.pm Firewall.pm VirtExperiment.pm libGeni.pm \
libEmulab.pm EmulabConstants.pm TraceUse.pm EmulabFeatures.pm \
Port.pm
Port.pm
BlockstoreType.pm
# Stuff installed on plastic.
USERSBINS = genelists.proxy dumperrorlog.proxy backup
...
...
db/VirtExperiment.pm.in
View file @
9c17c18d
...
...
@@ -98,6 +98,8 @@ my $debug = 0;
"virt_client_service_hooks"
=>
[
"vnode"
,
"service_idx"
,
"env"
,
"whence"
,
"hook_vblob_id"
],
"virt_client_service_opts"
=>
[
"vnode"
,
"opt_name"
,
"opt_value"
],
"virt_blockstores"
=>
[
"vname"
],
"virt_blockstore_attributes"
=>
[
"vname"
,
"attrkey"
],
);
#
...
...
@@ -1260,5 +1262,15 @@ use vars qw(@ISA);
@
ISA
=
"VirtExperiment::VirtTableRow"
;
use
VirtExperiment
;
package
VirtExperiment
::
VirtTableRow
::
virt_blockstores
;
use
vars
qw
(@
ISA
);
@
ISA
=
"VirtExperiment::VirtTableRow"
;
use
VirtExperiment
;
package
VirtExperiment
::
VirtTableRow
::
virt_blockstore_attributes
;
use
vars
qw
(@
ISA
);
@
ISA
=
"VirtExperiment::VirtTableRow"
;
use
VirtExperiment
;
#
_Always_
make
sure
that
this
1
is
at
the
end
of
the
file
...
1
;
db/xmlconvert.in
View file @
9c17c18d
...
...
@@ -163,6 +163,13 @@ my %virtual_tables =
"
virt_client_service_opts
"
=>
{
rows
=>
undef
,
tag
=>
"
virt_client_service_opts
",
row
=>
"
virt_client_service_opt
"},
"
virt_blockstores
"
=>
{
rows
=>
undef
,
tag
=>
"
blockstores
",
row
=>
"
blockstore
"},
"
virt_blockstore_attributes
"
=>
{
rows
=>
undef
,
tag
=>
"
virt_blockstore_attributes
",
row
=>
"
virt_blockstore_attribute
"},
# This is a fake table. See below. If we add more, lets generalize.
"
external_sourcefiles
"
=>
{
rows
=>
undef
,
tag
=>
"
nsfiles
",
...
...
tbsetup/ns2ir/GNUmakefile.in
View file @
9c17c18d
...
...
@@ -37,7 +37,8 @@ LIB_STUFF = lanlink.tcl node.tcl sim.tcl tb_compat.tcl null.tcl \
elabinelab.ns elabinelab-withfsnode.ns elabinelab-opsvm.ns \
fw.ns timeline.tcl sequence.tcl \
topography.tcl console.tcl path.tcl \
disk.tcl custom.tcl elabinelab-xen.ns
disk.tcl custom.tcl elabinelab-xen.ns \
blockstore.tcl
BOSSLIBEXEC = parse-ns
USERLIBEXEC = parse.proxy
...
...
tbsetup/ns2ir/blockstore.tcl
0 → 100644
View file @
9c17c18d
# -*- tcl -*-
#
# Copyright
(
c
)
2012 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/>.
#
#
}}}
#
######################################################################
# blockstore.tcl
#
# This class defines the blockstore storage object.
#
######################################################################
Class Blockstore -superclass NSObject
namespace eval GLOBALS
{
set new_classes
(
Blockstore
)
{}
}
Blockstore instproc init
{
s
}
{
global ::GLOBALS::last_class
$self set sim $s
$self set node
{}
$self set type
{}
$self set size 0
$self set type
{}
$self set role
"unknown"
# storage attributes
(
class, protocol, etc.
)
$self instvar attributes
array set attributes
{}
set ::GLOBALS::last_class $self
}
Blockstore instproc rename
{
old new
}
{
$self instvar sim
$sim rename_blockstore $old $new
}
Blockstore instproc set-class
{
newclass
}
{
var_import ::TBCOMPAT::soclasses
$self instvar attributes
if
{
!
[
info exists soclasses
(
$newclass
)]}
{
perror
"
\[
set-class] Invalid storage class:
$newclass
"
return
}
$self set attributes
(
class
)
$newclass
return
}
Blockstore instproc set-protocol
{
newproto
}
{
var_import ::TBCOMPAT::soprotocols
$self instvar attributes
if
{
!
[
info exists soprotocols
(
$newproto
)]}
{
perror
"
\[
set-protocol] Invalid storage protocol:
$newproto
"
return
}
$self set attributes
(
protocol
)
$newproto
return
}
Blockstore instproc set-type
{
newtype
}
{
var_import ::TBCOMPAT::sotypes
if
{
!
[
info exists sotypes
(
$newtype
)]}
{
perror
"
\[
set-type] Invalid storage object type:
$newtype
"
return
}
$self set type $type
return
}
Blockstore instproc set-size
{
newsize
}
{
set mindisksize 1
;
# 1 MiB
# Convert various input size strings to mebibytes.
set convsize
[
convert_to_mebi $newsize
]
# Do some boundary checks.
if
{
$convsize < $mindisksize
}
{
perror
"
\[
set-size]
$newsize
is smaller than allowed minimum (1 MiB)"
return
}
$self set size $convsize
return
}
# Create a node object to represent the host that contains this blockstore,
# or return it if it already exists.
Blockstore instproc get_node
{}
{
$self instvar sim
$self instvar node
if
{
$node
!=
{}}
{
return $node
}
# Allocate parent host and bind to it.
set hname
"sanhost-
${self}
"
uplevel
"#0"
"set
$hname
[
$sim
node
]
"
$hname set subnodehost 1
$hname set subnodechild $self
set node $hname
# Return parent node object.
return $hname
}
# updatedb DB
# This adds rows to the virt_blockstores and virt_blockstore_attributes
# tables, corresponding to this storage object.
Blockstore instproc updatedb
{
DB
}
{
var_import ::GLOBALS::pid
var_import ::GLOBALS::eid
$self instvar sim
$self instvar node
$self instvar type
$self instvar size
$self instvar role
$self instvar attributes
# XXX: role needs more thought...
#if
{
$role ==
"unknown"
}
{
# puts stderr
"*** WARNING: blockstore role not set and unable to infer it."
#
}
# Emit top-level storage object stuff.
set vb_fields
[
list
"vname"
"type"
"role"
"size"
"fixed"
]
set vb_values
[
list $self $type $role $size $node
]
$sim spitxml_data
"virt_blockstores"
$vb_fields $vb_values
# Emit attributes.
foreach key
[
lsort
[
array names attributes
]]
{
set val $attributes
(
$key
)
$sim
spitxml_data
"virt_blockstore_attributes"
[
list
"vname"
"attrkey"
"attrvalue"
]
[
list $self $key $val
]
}
}
tbsetup/ns2ir/lanlink.tcl
View file @
9c17c18d
...
...
@@ -238,6 +238,9 @@ LanLink instproc init {s nodes bw d type} {
$self set layer
{}
$self set implemented_by
{}
# Is this a SAN?
$self set sanlan 0
# A simulated lanlink unless we find otherwise
$self set simulated 1
# Figure out if this is a lanlink that has at least
...
...
@@ -300,6 +303,13 @@ LanLink instproc init {s nodes bw d type} {
$self set ofenabled 0
foreach node $nodes
{
# If the node is actually a blockstore object, then we need
# to grab the parent host object and substitute it in here.
if
{[
$node
info class
]
==
"Blockstore"
}
{
set bs $node
set node
[
$bs
get_node
]
$self
set sanlan 1
}
set nodepair
[
list $node
[
$node
add_lanlink $self
]]
set bandwidth
(
$nodepair
)
$bw
set rbandwidth
(
$nodepair
)
$bw
...
...
@@ -1178,6 +1188,7 @@ Lan instproc updatedb {DB} {
$self instvar ofenabled
$self instvar ofcontroller
$self instvar bridge_links
$self instvar sanlan
set vindex 0
if
{
$modelnet
_cores > 0 || $modelnet_edges > 0
}
{
...
...
@@ -1197,6 +1208,13 @@ Lan instproc updatedb {DB} {
$sim
spitxml_data
"virt_lan_settings"
$fields
$values
}
#
# If this is a SAN, then nullify shaping
#
if
{
$sanlan
== 1
}
{
set nobwshaping 1
}
foreach nodeport $nodelist
{
set node
[
lindex $nodeport 0
]
set isvirt
[
$node
set isvirt
]
...
...
tbsetup/ns2ir/nstb_compat.tcl
View file @
9c17c18d
...
...
@@ -331,6 +331,10 @@ Simulator instproc make-path {linklist} {
Simulator instproc make-portinvlan
{
node token
}
{
}
Simulator instproc blockstore
{
args
}
{
return
[
$self
node
]
}
Node instproc program-agent
{
args
}
{
}
...
...
tbsetup/ns2ir/parse-ns.in
View file @
9c17c18d
...
...
@@ -109,6 +109,7 @@ use NodeType;
use
Template
;
use
Experiment
;
use
User
;
use
BlockstoreType
;
use
constant
false
=>
0
;
use
constant
true
=>
1
;
...
...
@@ -869,9 +870,24 @@ sub GenDefsFile($)
}
}
}
print
TCL
"
\n\n
";
print
TCL
"
\n
";
print
TCL
"
# Storage Objects
\n
";
my
@sotypes
=
BlockstoreType
->
AllTypes
();
foreach
my
$sot
(
@sotypes
)
{
my
$type
=
$sot
->
type
();
my
$cl
=
$sot
->
class
();
my
$proto
=
$sot
->
protocol
();
print
TCL
"
set sotypes(
$type
) 1
\n
"
if
defined
(
$type
);
print
TCL
"
set soclasses(
$cl
) 1
\n
"
if
defined
(
$cl
);
print
TCL
"
set soprotocols(
$proto
) 1
\n
"
if
defined
(
$proto
);
}
print
TCL
"
\n
";
print
TCL
"
}
\n
";
print
TCL
"
}
\n
\n
";
close
(
TCL
);
}
...
...
tbsetup/ns2ir/parse.tcl.in
View file @
9c17c18d
...
...
@@ -394,6 +394,7 @@ source ${GLOBALS::libdir}/sequence.tcl
source ${GLOBALS::libdir}/console.tcl
source ${GLOBALS::libdir}/topography.tcl
source ${GLOBALS::libdir}/disk.tcl
source ${GLOBALS::libdir}/blockstore.tcl
source ${GLOBALS::libdir}/custom.tcl
##################################################
...
...
@@ -558,11 +559,14 @@ proc new {class args} {
# in Kbps.
proc parse_bw {bspec {islink 1}} {
#
# Special case
; "*" means let assign pick the bandwidth. Make it zero.
# Special case
s