File Coverage

blib/lib/Cisco/UCS.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Cisco::UCS;

use warnings;
use strict;

use Cisco::UCS::Chassis;
use Cisco::UCS::Interconnect;
use Cisco::UCS::FEX;
use Cisco::UCS::Blade;
use Cisco::UCS::Fault;
use Cisco::UCS::MgmtEntity;
use Cisco::UCS::ServiceProfile;
use LWP;
use XML::Simple;
use Carp qw(croak carp cluck);

use vars qw($VERSION);

our $VERSION		= '0.35';

our @ATTRIBUTES		= qw(dn cluster cookie);

our %ATTRIBUTES		= ();

sub new {
        my ($class, %args) = @_;
	my $self = {};
        bless $self, $class;
        defined $args{cluster}  ? $self->{cluster}  = $args{cluster}	: croak 'cluster not defined';
        defined $args{username} ? $self->{username} = $args{username}	: croak 'username not defined';
        defined $args{passwd}	? $self->{passwd}   = $args{passwd}	: croak 'passwd not defined';
        defined $args{verify_hostname} ? $self->{verify_hostname} = $args{verify_hostname} : 0;
	$self->{port}		= ($args{port}	or 443);
	$self->{proto}		= ($args{proto} or 'https');
	$self->{dn}		= ($args{dn} or 'sys');
        return $self;
}

{
        no strict 'refs';

        while ( my ($pseudo, $attribute) = each %ATTRIBUTES ) {
                *{ __PACKAGE__ . '::' . $pseudo } = sub {
                        my $self = shift;
                        return $self->{$attribute}
                }
        }

        foreach my $attribute (@ATTRIBUTES) {
                *{ __PACKAGE__ . '::' . $attribute } = sub {
                        my $self = shift;
                        return $self->{$attribute}
                }
        }
}

sub login {
	my $self = shift;

	undef $self->{error};
	$self->{ua}	= LWP::UserAgent->new( ssl_opts => { verify_hostname => $self->{verify_hostname} } );
	$self->{uri}	= $self->{proto}. '://' .$self->{cluster}. ':' .$self->{port}. '/nuova';
	$self->{req}	= HTTP::Request->new(POST => $self->{uri});
	$self->{req}->content_type('application/x-www-form-urlencoded');
	$self->{req}->content('');
	my $res		= $self->{ua}->request($self->{req});

	unless ($res->is_success) {
		$self->{error}	= 'Login failure: '.$res->status_line;
		return 0
	}

	$self->{parser}	= XML::Simple->new;
	my $xml         = $self->{parser}->XMLin($res->content);

	if(defined $xml->{'errorCode'}) {
		$self->{error}	= 'Login failure: '. (defined $xml->{'errorDescr'} ? $xml->{'errorDescr'} : 'Unspecified error');
		return 0
	}

	$self->{cookie}	= $xml->{'outCookie'};
	return 1
}

sub refresh {
	my $self = shift;

	undef $self->{error};
	$self->{req}->content('');
	my $res	= $self->{ua}->request($self->{req});

	unless ($res->is_success) {
		$self->{error}	= 'Refresh failed: ' . $res->status_line;
		return 0
	}

	my $xml	= $self->{parser}->XMLin($res->content());

	if (defined $xml->{'errorCode'}) {
		$self->{error}	= 'Refresh failure: '. (defined $xml->{'errorDescr'} ? $xml->{'errorDescr'} : 'Unspecified error');
		return 0
	}

        $self->{cookie}	= $xml->{'outCookie'};
	return 1
}

sub logout {
	my $self = shift;
	return unless $self->{cookie};
	undef $self->{error};
	return ( $self->_ucsm_request('') ? 1 : 0 )
}

sub _ucsm_request {
	my ($self, $content, $class_id)	= @_;

	undef $self->{error};
	$self->{req}->content($content);
	my $res	= $self->{ua}->request($self->{req});

	$self->error($res->status_line) unless $res->is_success;

	my $xml = ( $class_id
			? $self->{parser}->XMLin($res->content, KeyAttr => $class_id)
			: $self->{parser}->XMLin($res->content, KeyAttr => [ 'name', 'key', 'id', 'intId' ] )
		);

	return ( $xml->{errorCode}
			? do {
				$self->{error}	= ( $xml->{'errorDescr'} ? $xml->{'errorDescr'} : 'Unspecified error' );
				undef
			  }
			: $xml
		);
}

# This private method provides an abstract factory-type constructor for resolved child
# objects of the specified dn.  To maintain compatibility with existing methods and to
# provide a single method for all child objects, there are a few important design
# considerations that have been made.
#
# Importantly we check for a 'class_filter' argument to the method which if present is
# used to call the 'resolve_class_filter' method rather than the 'resolve_children' method.
# This is necessary due to limitations and difficulties present in resolving child objects
# for some objects can lead to incorrect results.  For example, resolving the child objects
# for a chassis to retrieve the blades in the chassis is difficult, instead we can use a much
# more efficient and simpler method of retrieving the blades in a specified chassis by
# resolving all objects in the specified class (i.e. computeBlade) and restricting the
# results returned using a filter method.
#
# The implication of doing this is that the call to 'resolve_class_filter' returns an array
# which cannot be processed using the same logic as for a hash returned by the 'resolve_children'
# method.  Therefore we perform extra processing to convert the returned array results to a
# hash using a nominated attribute in the object as the hash index for the objects.
#
# SYNOPSIS
#	get_child_object ( %ARGS )
#
# PARAMETERS
#	id	The optional identifier of a specific child object.  This identifier is context
#		dependent and may be either numerical (as in the case of a chassis) or alphanumeric
#		(as is the case with a fabric interconnect - A or B).
#
#	type	The desired child object type to be resolved as according to the UCSM information
#		management hierarchy name. e.g. etherPIo is the ethernet port child object type for line cards.
#
#	class	The class into which the child object will be blessed.
#
#	attr	The pseudo-namespace in the Cisco::UCS object in which the retrieved child onjects will be cached.
#		For example; attr => 'interconnect' will mean that Cisco::UCS::Interconnect objects retrieved in
#		a $ucs->get_interconnects method call will be stored in $ucs->{interconnects}->{$OBJ}.
#
#	self	A reference to a Cisco::UCS object.  If not present $self is assumed to be a Cisco::UCS object.
#
#	uid	Where results are returned and parsed into an array and the array index is not aligned to an identifying
#		attribute of the object (i.e. the array index has no relation to a unique identifier for the object) then
#		the uid may be used to refer to a unique identifying attribute of the object that should be used.
#		For example, in resolving all blades for a Cisco::UCS object, the uid value of bladeId is used to uniquely
#		identify all Cisco::UCS::Blade objects as the array index has no relation to a uniquely identifying feature
#		of the blade and is not guaranteed to be consistent.
#
#	class_filter (%ARGS)
#			A class filter may be specified to filter the results to a particular subset.  This is useful for
#			operations like retrieving all blades in a particular chassis rather than retrieving all blades and
#			manually filtering the results.
#
#	Where %ARGS:
#
#	classId	The UCSM class which should be used for the UCSM query.  For example: classId => etherPio.
#
#	filter	Where filter is composed of any number of valid attribute/value pairs.  For example: slotId => 1, switchId => $self->{id}.
#

sub _get_child_objects {
        my ($self,%args)= @_;
	my $ucs = ( defined $self->{ucs}	? $self->{ucs}	: $self );
	my $ref = ( defined $args{self}		? $args{self}	: $self );
        my $xml = ( defined $args{class_filter}
			? $ucs->resolve_class_filter( %{$args{class_filter}} )
			: $ucs->resolve_children(dn => $ref->{dn})
		  );

	if (ref($xml->{outConfigs}->{$args{type}}) eq 'ARRAY') {
		$args{uid} ||= 'id';
		my $res;

		foreach my $obj (@{$xml->{outConfigs}->{$args{type}}}) {
			$res->{$obj->{$args{uid}}} = $obj
		}

		$xml->{outConfigs}->{$args{type}} = $res
	}
	elsif ((ref($xml->{outConfigs}->{$args{type}}) eq 'HASH') and (exists $xml->{outConfigs}->{$args{type}}->{dn})) {
		$args{uid} ||= 'id';
		my $res;
		$res->{$xml->{outConfigs}->{$args{type}}->{$args{uid}}} = $xml->{outConfigs}->{$args{type}};
		$xml->{outConfigs}->{$args{type}} = $res
	}

        return ( defined $xml->{outConfigs}->{$args{type}}
                ? do {  my @res;
                        foreach my $res (keys %{$xml->{outConfigs}->{$args{type}}}) {
                                my $obj = $args{class}->new( ucs => $ucs, dn => $xml->{outConfigs}->{$args{type}}->{$res}->{dn}, id => $res );
                                $ref->{$args{attr}}->{$res} = $obj; #print "Setting $ref\->{$args{attr}}->{$res} to $obj\n";
                                push @res, $obj;
                        }
                        return @res unless $args{id};
                        return $ref->{$args{attr}}->{$args{id}} if $args{id} and $ref->{$args{attr}}->{$args{id}};
                        return
                     }
                : ()
                );

}

sub get_error_id {
	warn "get_error_id has been deprecated in future releases";
	return get_error(@_)
}

sub error {
	my ($self, $id) = @_;
	return ( defined $self->{fault}->{$id} ? $self->{fault}->{$id} : $self->get_error($id) )
}

sub get_error {
	my ($self, $id)=@_;
	return $self->get_errors($id)
}

sub get_errors {
	my ($self, $id)	=@_;
	return $self->_get_child_objects(id => $id, type => 'faultInst', class => 'Cisco::UCS::Fault',
					uid => 'id', attr => 'fault', class_filter => { classId => 'faultInst' } );
}

sub _isInHierarchical {
	my $inHierarchical	= lc shift;

	return 'false' unless ($inHierarchical =~ /true|false|0|1/);

	return $inHierarchical if ($inHierarchical =~ /^true|false$/);

	return ($inHierarchical == 0 ? 'false' : 'true');
}

sub _createFilter {
	my ($self, %args)	= @_;

	unless (defined $args{classId}) {
		$self->{error}	= 'No classId specified';
		return
	}

	my $filter	= '';

	while (my($property,$value) = each %args) {
		next if ($property eq 'inHierarchical' or $property eq 'classId');
		$filter	.= '';
	}

	$filter		.= '';

	return $filter;
}

sub resolve_class {
	my ($self,%args)= @_;

	unless ( defined $args{classId} ) {
		$self->{error}	= 'No classId specified';
		return
	}

	$args{inHierarchical} = (defined $args{inHierarchical} ? _isInHierarchical($args{inHierarchical}) : 'false');

	my $xml	= $self->_ucsm_request('
299
					'" cookie="' . $self->{cookie} . '" classId="' . $args{classId} . '" />') or return;

	return $xml
}

sub resolve_classes {
	my ($self,%args)= @_;

	unless (defined $args{classId}) {
		$self->{error}	= 'No classID specified';
		return
	}

	$args{inHierarchical}	= (defined $args{inHierarchical} ? _isInHierarchical($args{inHierarchical}) : 'false');

	my $xml	= $self->_ucsm_request(	'
315
					'" cookie="' . $self->{cookie} . '">' .
					'
317
					'" />', 'classId'
				) or return;

	return $xml
}

sub resolve_dn {
	my ($self,%args)= @_;

	unless (defined $args{dn}) {
		$self->{error}	= 'No dn specified';
		return
	}

	$args{inHierarchical}	= (defined $args{inHierarchical} ? _isInHierarchical($args{inHierarchical}) : 'false');

	my $xml	= $self->_ucsm_request(	'
334
					'" inHierarchical="' . $args{inHierarchical} .
					'" cookie="' . $self->{cookie} . '" />'
				) or return;
	return $xml;
}

sub resolve_children {
	my ($self,%args)= @_;

	unless (defined $args{dn}) {
		$self->{error}	= 'No dn specified';
		return
	}

	$args{inHierarchical}	= ( defined $args{inHierarchical} ? _isInHierarchical($args{inHierarchical}) : 'false' );

	my $xml	= $self->_ucsm_request(	'
351
					'" cookie="' . $self->{cookie} .
					'" inDn="' . $args{dn} .
					'">'
				) or return;

	return $xml
}

sub resolve_class_filter {
	my($self,%args)	= @_;

	$args{inHierarchical}	= (defined $args{inHierarchical} ? _isInHierarchical($args{inHierarchical}) : 'false');

	my $filter	= $self->_createFilter(%args) or return;

	my $xml		= $self->_ucsm_request('' .
				$filter . '', $args{classId}) or return;

	return $xml
}

sub get_cluster_status {
	my $self= shift;

	my $xml	= $self->resolve_dn(dn => 'sys') or return;

	return (defined $xml->{outConfig}->{topSystem} ? $xml->{outConfig}->{topSystem} : undef)
}

sub version {
	my $self= shift;
	my $xml	= $self->resolve_dn(dn => 'sys/mgmt/fw-system') or return;
	return (defined $xml->{outConfig}->{firmwareRunning}->{version} ? $xml->{outConfig}->{firmwareRunning}->{version} : undef)
}

sub mgmt_entity {
	my ($self, $id) = @_;
	return ( defined $self->{mgmt_entity}->{$id} ? $self->{mgmt_entity}->{$id} : $self->mgmt_entity($id) )
}

sub get_mgmt_entity {
	my ($self, $id)	= @_;
	return $self->get_mgmt_entities($id)
}

sub get_mgmt_entities {
        my ($self, $id) = @_;
	return $self->_get_child_objects(id => $id, type => 'mgmtEntity', class => 'Cisco::UCS::MgmtEntity', attr => 'mgmt_entity');
}

sub get_primary_mgmt_entity {
	my $self	= shift;

	my $xml		= $self->resolve_class_filter(classId => 'mgmtEntity', leadership => 'primary') or return;

	return (defined $xml->{outConfigs}->{mgmtEntity} ? $xml->{outConfigs}->{mgmtEntity} : undef)
}

sub get_subordinate_mgmt_entity {
	my $self= shift;

	my $xml	= $self->resolve_class_filter(classId => 'mgmtEntity', leadership => 'subordinate') or return;

	return (defined $xml->{outConfigs}->{mgmtEntity} ? $xml->{outConfigs}->{mgmtEntity} : undef);
}

sub service_profile {
	my ($self, $id)=@_;
	return ( defined $self->{service_profile}->{$id} ? $self->{service_profile}->{$id} : $self->get_service_profile($id) )
}

sub get_service_profile {
	my ($self, $id)	= @_;
	return $self->get_service_profiles($id)
}

sub get_service_profiles {
	my ($self, $id)	=@_;
	return $self->_get_child_objects(id => $id, type => 'lsServer', class => 'Cisco::UCS::ServiceProfile',
					uid => 'name', attr => 'service_profile', class_filter => { classId => 'lsServer' });
}

sub interconnect {
	my ($self, $id)	= @_;
	return ( defined $self->{interconnect}->{$id} ? $self->{interconnect}->{$id} : $self->get_interconnect($id) )
}

sub get_interconnect {
	my ($self, $id)=@_;
	return $self->get_interconnects($id)
}

sub get_interconnects {
	my ($self, $id)	=@_;
	return $self->_get_child_objects(id => $id, type => 'networkElement', class => 'Cisco::UCS::Interconnect', attr => 'interconnect');
}

sub blade {
	my ($self, $id)	= @_;
	return ( defined $self->{blade}->{$id} ? $self->{blade}->{$id} : $self->get_blade($id) )
}

sub get_blade {
	my ($self, $id)=@_;
	return $self->get_blades($id)
}

sub get_blades {
	my ($self, $id, %args)	=@_;
	return $self->_get_child_objects(id => $id, type => 'computeBlade', class => 'Cisco::UCS::Blade', attr => 'blade',
					uid => 'serverId', class_filter => { classId => 'computeBlade' });
}

sub chassis {
	my ($self, $id)	= @_;
	return ( defined $self->{chassis}->{$id} ? $self->{chassis}->{$id} : $self->get_chassis($id) )
}

sub get_chassis {
	my ($self, $id)=@_;
	return $self->get_chassiss($id)
}

sub get_chassiss {
	my ($self, $id)	=@_;
	return $self->_get_child_objects(id => $id, type => 'equipmentChassis', class => 'Cisco::UCS::Chassis', attr => 'chassis');
}

sub full_state_backup {
	my ( $self, %args ) = @_;

	$args{backup_type}= 'full-state';

	return ( $self->_backup( %args ) );
}
sub all_config_backup {
	my ( $self, %args ) = @_;

	$args{backup_type}= 'config-all';

	return ( $self->_backup( %args ) );
}

sub system_config_backup {
	my ( $self, %args ) = @_;

	$args{backup_type}= 'config-system';

	return ( $self->_backup( %args ) );
}

sub logical_config_backup {
	my ( $self, %args ) = @_;

	$args{backup_type}= 'config-logical';

	return ( $self->_backup( %args ) );
}

sub _backup {
	my ( $self, %args ) = @_;

	unless( defined $args{backup_type} 	and
		defined $args{backup_proto}	and
		defined $args{backup_host}	and
		defined $args{backup_target}	and
		defined $args{backup_passwd}	and
		defined $args{backup_username} )
	{
		$self->{error} = 'Bad argument list';
		return
	}

	$args{admin_state}		= ( defined $args{admin_state} ? $args{admin_state} : 'enabled' );
	$args{preserve_pooled_values}	= ( defined $args{preserve_pooled_values} ? $args{preserve_pooled_values} : 'yes' );

	unless ( $args{backup_type} =~ /(config-all|full-state|config-system|config-logical)/i ) {
		$self->{error} = "Bad backup type ($args{backup_type})";
		return
	}

	unless ( $args{backup_proto} =~ /^((t|s)?ftp)|(scp)$/i ) {
		$self->{error} = "Bad backup proto' ($args{backup_proto})";
		return
	}

	my $address	= $self->get_cluster_status->{address};

	my $data = <<"XML";





          proto="$args{backup_proto}" pwd="$args{backup_passwd}" remoteFile="$args{backup_target}"
          rn="backup-$args{backup_host}" type="$args{backup_type}"
          user="$args{backup_username}" policyOwner="local">





XML

	my $xml 	= $self->_ucsm_request( $data ) or return;

	if ( defined $xml->{'errorCode'} ) {
		my $self->{error} = ( defined $xml->{'errorDescr'}
					? $xml->{'errorDescr'}
					: "Unspecified error"
				);
		return
	}

	return 1;
}

1;

__END__