Merge branch 'stordev-parser'

db/BlockstoreType.pm

+#!/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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

+
+# -*- 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

@@ -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

@@ -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

@@ -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

@@ -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 cases