Mellanox XML gateway adapter/wrapper module.

This module wraps the Mellanox XML-gateway API, an "interesting" sort of
interface offered up by Mellanox switches running MLNX-OS.  This module
handles all of the connection setup and XML encoding / decoding.  Users
of the module pass in arrays of commands to run, and arrays of results
are returned.  All commands in lists passed to a single call() invocation
will be passed along together to be invoked, in order, on the switch.
Mixtures of 'get', 'set-*', and 'action' commands are allowed.

This check-in also includes a test harness for this module.

Sample use:

my $gw = MLNX_XMLGateway->new("user:pass@switch.somehost.org");
my @cmds = (
  ["get", "/some/REST/path"],
  ["set-create", "/some/REST/path/to/create"],
  ["set-modify", "/some/REST/path/to/modify=newvalue"],
  ["action", "/some/REST/action/path", {var => value, ...}]
);

$results = eval { $gw->call(\@cmds) };

if ($@) {
  die "error: $@";
}

foreach my $res (@$results) {
  # path, type, value
  print "@$res\n";
}

tbsetup/snmpit_test/MLNX-test.pl

+#!/usr/bin/perl -w
+
+#
+# Copyright (c) 2013 University of Utah and the Flux Group.
+# 
+# {{{EMULAB-LGPL
+# 
+# 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 Lesser General Public License as published by
+# the Free Software Foundation; either version 2.1 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 Lesser General Public
+# License for more details.
+# 
+# You should have received a copy of the GNU Lesser General Public License
+# along with this file.  If not, see <http://www.gnu.org/licenses/>.
+# 
+# }}}
+#
+
+# Simple test harness for the MLNX-gateway module.
+
+use MLNX_XMLGateway;
+use Getopt::Std;
+use strict;
+
+my @get_test1 = (
+    ["name", "Basic 'get' Test #1"],
+    ["get","/mlnxos/v1/api_version"],
+    ["get","/mlnxos/v1/chassis/model"],
+    ["get","/mlnxos/v1/chassis/pn"],
+    ["get","/mlnxos/v1/chassis/fans/FAN/1/speed"],
+    ["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
+    ["submit"]
+);
+
+my @get_test2 = (
+    ["name","Interface name 'get' Test #2"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces_by_name/*"],
+    ["submit"]
+);
+
+my @pget_test1 = (
+    ["name", "Port 'get' Test (Eth1/8) #1"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/type"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/mtu"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/mode"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/allowed/*"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/physical_location"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/supported_speed"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/configured_speed"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/actual_speed"],
+    ["submit"]
+);
+
+my @pget_test2 = (
+    ["name", "Port 'get' Test (Po1) #2"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/enabled"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/type"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/vlans/pvid"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/vlans/mode"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/vlans/allowed/*"],
+    ["submit"]
+);
+
+my @vlan_test1 = (
+    ["name", "Vlan Creation Test #1"],
+    ["action","/mlnxos/v1/vsr/default_vsr/vlans/add",{vlan_id => 666}],
+    ["set-modify","/mlnxos/v1/vsr/default_vsr/vlans/666/name=testvlan"],
+    ["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
+    ["submit"],
+    ["action","/mlnxos/v1/vsr/default_vsr/vlans/delete",{vlan_id => 666}],
+    ["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
+    ["submit"]
+);
+
+
+my @port_test1 = (
+    ["name", "Port Toggle Test (Eth1/8) #1"],
+    ["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled=false"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled"],
+    ["submit"],
+    ["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled=true"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled"],
+    ["submit"]
+);
+
+my @vport_test1 = (
+    ["name", "Vlan + Port Test (Eth1/8) #1"],
+    ["action","/mlnxos/v1/vsr/default_vsr/vlans/add",{vlan_id => 666}],
+    ["set-modify","/mlnxos/v1/vsr/default_vsr/vlans/666/name=testvlan"],
+    ["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid=666"],
+    ["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid"],
+    ["submit"],
+    ["action","/mlnxos/v1/vsr/default_vsr/vlans/delete",{vlan_id => 666}],
+    ["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid=53"],
+    ["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
+    ["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid"],
+    ["submit"]
+);
+
+# List the tests to run here.
+my @testsets = (\@get_test1, \@pget_test1);
+
+my %opts = ();
+
+if (!getopts("a:d:",\%opts)) {
+    print "Usage: $0 -a <uri_auth_string> -d <level>\n";
+    exit 1;
+}
+
+my $auth  = "";
+my $debug = 0;
+$auth  = $opts{'a'} or die "Must specify an auth string!";
+$debug = $opts{'d'} if $opts{'d'};
+
+my $gateway = MLNX_XMLGateway->new($auth);
+$gateway->debug($debug) if $debug;
+
+foreach my $tlist (@testsets) {
+    my @cmdset  = ();
+    my @results = ();
+    my $testname = "unnamed";
+
+    foreach my $cmd (@{$tlist}) {
+        TESTSW1: for ((@{$cmd})[0]) {
+	    /^name$/ && do {
+		$testname = (@{$cmd})[1];
+		print "========== Running Test: $testname ==========\n";
+		last TESTSW1;
+	    };
+	
+	    /^submit$/ && do {
+		push @results, $gateway->call(\@cmdset);
+		@cmdset = ();
+		last TESTSW1;
+	    };
+      
+	    # Default
+	    push @cmdset, $cmd;
+	}
+    }
+
+    print "--- Results:\n";
+    my $i = 1;
+    foreach my $reslist (@results) {
+	print "* Submission $i:\n";
+	foreach my $res (@$reslist) {
+	    print "@$res\n";
+	}
+	++$i;
+    }
+
+    print "\n";
+}
+

tbsetup/snmpit_test/MLNX_XMLGateway.pm

@@ -23,9 +23,8 @@
 # }}}
 #
 
-
 # Mellanox XML-Gateway handler class.  Hides all of the connection
-# management, method invocation, and response parsing goo from the caller.
+# management, XML method invocation, and response parsing goo from the caller.
 
 package MLNX_XMLGateway;
 
@@ -38,14 +37,18 @@ use strict;
 
 $| = 1; # Turn off line buffering on output
 
+my $DEBUG = 0;
+
 my $MLNX_GATEWAY_PATH = "/xtree";
 my $MLNX_AUTH_PATH  = '/admin/launch?script=rh&template=login&action=login';
+my $MLNX_CHECK_RPATH = "/mlnxos/v1/chassis/model";
 my %MLNX_ACTIONS = ("action"     => 1, 
 		    "get"        => 1, 
 		    "set-create" => 1, 
 		    "set-modify" => 1, 
 		    "set-delete" => 1);
 
+
 #
 # Create a new Mellanox XML-Gateway object.  $authority is an authority
 # component for an HTTP URI.  e.g., 'user:pass@hostname[:port]'
@@ -96,6 +99,54 @@ sub DESTROY($) {
     $self->{'CONN'} = undef;
 }
 
+#
+# Set/unset/query debug level
+#
+sub debug($;$) {
+    my ($self,$level) = @_;
+    
+    if (defined($level)) {
+	$level =~ /^\d+$/ or
+	    die "Debug level must be a positive integer or zero!";
+	$DEBUG = $level;
+    }
+
+    return $DEBUG;
+}
+
+#
+# Debug print wrapper function
+#
+sub debugpr($;$) {
+    my ($msg, $level) = @_;
+
+    # Default to debug level '1' if not specified.
+    $level ||= 1;
+
+    if ($DEBUG >= $level) {
+	print $msg;
+    }
+}
+
+#
+# Pretty print a parsed XML::LibXML DOM object.  Requires a separate
+# perl module.  Assumes you are passing in a valid DOM object!
+#
+sub XMLPrettyPrint($) {
+    my ($xmldom,) = @_;
+    my $retstr;
+
+    eval { require XML::LibXML::PrettyPrint };
+    if ($@) {
+	$retstr = "-> Can't pretty print: XML::LibXML::PrettyPrint not found.";
+    } else {
+	my $pp = XML::LibXML::PrettyPrint->new(indent_string => "  ");
+	$retstr = $pp->pretty_print($xmldom->documentElement()->cloneNode(1))->toString();
+    }
+
+    return $retstr;
+}
+
 #
 # Establish an authenticated session with the XML gateway on the switch.
 # Users of this module should not call this method directly.
@@ -107,24 +158,39 @@ sub connect($) {
     my $user = $self->{'USER'};
     my $pass = $self->{'PASS'};
 
-    # See if we have a connection, and if it is still valid/active.
+    # See if we already have a connection, and if it is still valid.
     if (defined($self->{'CONN'})) {
-	my $ccache = $self->{'CONN'}->conn_cache();
-	$ccache->prune();  # test the connection, and remove if closed.
-	if (scalar($ccache->get_connections()) == 1) {
-	    # Existing connection is valid - pass it back to the caller.
-	    return $self->{'CONN'};
-	} else {
-	    # De-alloc the connection object.  We will try to reconnect
-	    # and authenticate again below.
-	    $ccache = undef;
+	# Do a quick check to make sure we have a valid session.
+	my $checkdom = XMLEncodeCallStack(
+	    [XMLEncodeCall("get",$MLNX_CHECK_RPATH),]);
+	my $resp = $self->{'CONN'}->post($self->{'URI'},
+					 Content => $checkdom->serialize());
+	my $resp2 = 
+	    eval { XMLDecodeResponse(
+		       XML::LibXML->load_xml(string =>
+					     $resp->decoded_content())) };
+	if ($@ || scalar(@{$resp2}) == 0) {
+	    if ($@) {
+		debugpr "Failed connection test message:\n$@\n";
+	    } elsif (!scalar(@{$resp2})) {
+		debugpr "No response to basic get [$MLNX_CHECK_RPATH] ...\n";
+	    }
+	    $resp2 = $resp = $checkdom = undef;
 	    $self->{'CONN'} = undef;
+	    warn "Cached connection invalid.  Attempting to reconnect.\n";
+	} else {
+	    return $self->{'CONN'};
 	}
     }
 
     my $ua = LWP::UserAgent->new();
-    $ua->conn_cache(LWP::ConnCache->new()); # need an http 1.1 session.
-    $ua->cookie_jar({});
+    $ua->cookie_jar({});         # need to store the session cookie.
+
+    # Enable debug output from www user agent if debug level is high.
+    if ($DEBUG > 3) {
+	$ua->add_handler("request_send",  sub { shift->dump; return });
+	$ua->add_handler("response_done", sub { shift->dump; return });
+    }
 
     # Create a new URI with the host defined in the URI created via
     # the constructor.
@@ -140,14 +206,26 @@ sub connect($) {
 	'f_password' => $pass
     );
     # Make the call and check that it went through OK.  Die if not.
-    # XXX: may want to put in some retry logic, and/or check for timeout.
+    # If there is a valid "session" cookie sent back, then we're good
+    # to go.  Note: Almost unbelievably, if authentication fails, then
+    # the web service on the switch will return a "200" code along
+    # with some big old long login page.  On success, it returns a
+    # code "302".  Really Mellanox?
     my $authres = $ua->post($authuri, \%form);
-    if ($authres->code != 302) {
-	die "Failed to authenticate to ". $authuri->host() .": ".
-	    $authres->dump();
+    my $valid_session = 0;
+    $ua->cookie_jar()->scan(
+	sub {
+	    my ($version, $key, $val, $path, $domain, $port, 
+		$path_spec, $secure, $expires, $discard, $hash) = @_;
+	    debugpr("scanning cookie: $domain: $key => $val\n", 2);
+	    $valid_session = 1 if ($key eq "session");
+	});
+    if (!$valid_session) {
+	die "Failed to authenticate to ". $authuri->host();
     }
 
     # Connected.  Stash the LWP::UserAgent object and pass it back to caller.
+    debugpr "Successfully connected to ". $authuri->host() ."\n";
     $self->{'CONN'} = $ua;
     return $ua;
 }
@@ -178,7 +256,7 @@ sub call($$) {
     }
 
     # will die() if it encounters a problem, which we let flow through.
-    return $self->DispatchCallStack(XMLEncodeCallStack(@callstack));
+    return $self->DispatchCallStack(XMLEncodeCallStack(\@callstack));
 }
 
 #
@@ -195,19 +273,29 @@ sub XMLEncodeCall($$;$) {
     exists($MLNX_ACTIONS{$action})
 	or die "Unknown call type: $action";
 
-    $restpath =~ qr|^(/[\w\*]+){1,}/?$|
+    $restpath =~ qr|^(/[\w\*=]+){1,}/?$|
 	or die "REST-path does not look valid: $restpath";
 
     if (defined($arguments) && ref($arguments) eq "HASH") {
-	$action ne "action" && $action ne "set-modify"
-	    and die "Must NOT supply arguments hash with 'set-create', 'set-delete' or 'get' calls.";
+	$action ne "action"
+	    and die "Must NOT supply an arguments hash with 'set-*' or 'get' calls.";
 	# Append arguments on to the REST-path.
 	while (my ($arg_name,$arg_val) = each %{$arguments}) {
 	    $restpath .= "|${arg_name}=${arg_val}";
 	}
     } else {
-	$action eq "action" || $action eq "set-modify"
-	    and die "Must supply an arguments hash with 'action' or 'set-modify' calls.";
+	$action eq "action"
+	    and die "Must supply an arguments hash with 'action' calls.";
+    }
+
+    # Print out some debug stuff, if requested.
+    if ($DEBUG > 1) {
+	debugpr "XML Encoding: $action, $restpath\n";
+	if (defined($arguments)) {
+	    while (my ($k,$v) = each %$arguments) {
+		debugpr "\tArg: $k => $v\n";
+	    }
+	}
     }
 
     # Conjure a partial XML tree for this call.
@@ -225,10 +313,10 @@ sub XMLEncodeCall($$;$) {
 # individual calls passed in (preserving their order).  Meant for
 # internal use by this module.
 #
-sub XMLEncodeCallStack(@) {
-    my @callstack = @_;
+sub XMLEncodeCallStack($) {
+    my ($callstack,) = @_;
 
-    scalar(@callstack) > 0
+    scalar(@{$callstack}) > 0
 	or die "Must pass in at least one call to add";
 
     # Create the boilerplate that wraps the RPCs to send.
@@ -248,10 +336,16 @@ sub XMLEncodeCallStack(@) {
     $areq->appendChild($nodes);
 
     # drop in each of the call nodes (created by XMLEncodeCall()).
-    foreach my $call (@callstack) {
+    foreach my $call (@{$callstack}) {
 	$nodes->appendChild($call);
     }
 
+    # Pretty print the XML if debug level is sufficiently high.
+    # Requires another module that is not part of core XML::LibXML.
+    if ($DEBUG > 2) {
+	debugpr "Encoded XML Call Stack:\n". XMLPrettyPrint($dom) ."\n";
+    }
+
     return $dom;
 }
 
@@ -271,10 +365,7 @@ sub DispatchCallStack($$) {
 			 Content => $dom->serialize());
 
     if ($resp->is_error()) {
-	print "Error while calling XML-gateway. XML callstack:\n".
-	    $dom->serialize() ."\n\n".
-	    "Server output: ". $resp->dump() ."\n";
-	die "Error dispatching call stack.";
+	die "Error dispatching call stack: ". $resp->status_line();
     }
 
     # Parse the XML encoded response from the gateway into a DOM object.
@@ -282,9 +373,12 @@ sub DispatchCallStack($$) {
     my $respdom = eval { XML::LibXML->load_xml(string => 
 					       $resp->decoded_content()) };
     if ($@) {
-	print "Invalid gateway response (not XML?).  Full HTTP contents:\n".
-	      $resp->dump() ."\n";
-	die "Invalid gateway response (not XML?).";
+	die "Invalid gateway response (not XML?): $@";
+    }
+
+    # Purty print the response.
+    if ($DEBUG > 2) {
+	debugpr "XML Response from switch:\n". XMLPrettyPrint($dom) ."\n";
     }
 
     # Allow any die() exceptions to just flow on through.
@@ -313,7 +407,7 @@ sub XMLDecodeResponse($) {
     my $nodes_xlist = $respdom->findnodes("//nodes/node");
 
     # Return an empty list of there aren't any data nodes in the response.
-    return () if !defined($nodes_xlist);
+    return [] if !defined($nodes_xlist);
 
     # Process the list of data nodes.  Extract the path,type,value
     # tuples from the XML and return these as a list of anonymous arrays.
@@ -331,5 +425,5 @@ sub XMLDecodeResponse($) {
 		    $value->string_value()];
 	});
 
-    return @nodelist;
+    return \@nodelist;
 }