File Coverage

blib/lib/Net/Proxmox/VE.pm

Criterion	Covered	Total	%
statement	36	158	22.7
branch	0	92	0.0
condition	0	30	0.0
subroutine	12	22	54.5
pod	10	10	100.0
total	58	312	18.5

#!/bin/false
# vim: softtabstop=2 tabstop=2 shiftwidth=2 ft=perl expandtab smarttab
# PODNAME: Net::Proxmox::VE
# ABSTRACT: Pure perl API for Proxmox virtualisation

use strict;
use warnings;

package Net::Proxmox::VE;
$Net::Proxmox::VE::VERSION = '0.38';

use Carp qw( croak );
use HTTP::Headers;
use HTTP::Request::Common qw(GET POST DELETE);
use JSON::MaybeXS qw(decode_json);
use LWP::UserAgent;

# done
use Net::Proxmox::VE::Pools;
use Net::Proxmox::VE::Storage;
use Net::Proxmox::VE::Access;
use Net::Proxmox::VE::Cluster;

# wip
use Net::Proxmox::VE::Nodes;


sub action {

    my $self = shift or return;
    my %params = @_;

    unless (%params) {
        croak 'new requires a hash for params';
    }
    croak 'path param is required' unless $params{path};

    $params{method} ||= 'GET';
    $params{post_data} ||= {};

    # Check its a valid method

    croak "invalid http method specified: $params{method}"
      unless $params{method} =~ m/^(GET|PUT|POST|DELETE)$/;

    # Strip prefixed / to path if present
    $params{path} =~ s{^/}{};

    # Collapse duplicate slashes
    $params{path} =~ s{//+}{/};

    unless ( $params{path} eq 'access/domains'
        or $self->check_login_ticket )
    {
        print "DEBUG: invalid login ticket\n"
          if $self->{params}->{debug};
        return unless $self->login();
    }

    my $url = $self->url_prefix . '/api2/json/' . $params{path};

    # Grab the useragent
    my $ua = $self->{ua};

    # Set up the request object
    my $request = HTTP::Request->new();
    $request->uri($url);
    $request->header( 'Cookie' => 'PVEAuthCookie=' . $self->{ticket}->{ticket} )
      if defined $self->{ticket};

    my $response;

    # all methods other than get require the prevention token
    # (ie anything that makes modification)
    unless ( $params{method} eq 'GET' ) {
        $request->header(
            'CSRFPreventionToken' => $self->{ticket}->{CSRFPreventionToken} );
    }

    if ( $params{method} =~ m/^(PUT|POST)$/ ) {
        $request->method( $params{method} );
        my $content = join '&', map { $_ . '=' . $params{post_data}->{$_} }
          sort keys %{ $params{post_data} };
        $request->content($content);
        $response = $ua->request($request);
    }
    elsif ( $params{method} =~ m/^(GET|DELETE)$/ ) {
        $request->method( $params{method} );
        if ( %{$params{post_data}} ) {
            my $qstring = join '&', map { $_ . '=' . $params{post_data}->{$_} }
                sort keys %{ $params{post_data} };
            $request->uri( "$url?$qstring" );
        }
        $response = $ua->request($request);
    }
    else {

        # this shouldnt happen
        croak 'this shouldnt happen';
    }

    if ( $response->is_success ) {
        print "DEBUG: successful request: " . $request->as_string . "\n"
          if $self->{params}->{debug};

        # my $content = $response->decoded_content;
        my $data    = decode_json( $response->decoded_content );

        if ( ref $data eq 'HASH'
            && exists $data->{data} )
        {
            if ( ref $data->{data} eq 'ARRAY' ) {

                return wantarray
                  ? @{ $data->{data} }
                  : $data->{data};

            }

            return $data->{data}

        }

        # just return true
        return 1

    }
    else {
        croak "WARNING: request failed: "  . $request->as_string . "\n" .
              "WARNING: response status: " . $response->status_line . "\n";
    }
    return

}


sub api_version {
    my $self = shift or return;
    return $self->action( path => '/version', method => 'GET' );
}


sub api_version_check {
    my $self = shift or return;

    my $data = $self->api_version;

    if ( ref $data eq 'HASH' && $data->{version} ) {
        my ($version) = $data->{version} =~ m/^(\d+)/;
        return 1 if $version > 2.0;
    }

    return;
}


sub debug {
    my $self = shift or return;
    my $d = shift;

    if ($d) {
        $self->{params}->{debug} = 1;
    }
    elsif ( defined $d ) {
        $self->{params}->{debug} = 0;
    }

    return 1 if $self->{params}->{debug};
    return

}


sub delete {
    my $self = shift or return;
    my @path = @_    or return;    # using || breaks this

    if ( $self->nodes ) {
        return $self->action( path => join( '/', @path ), method => 'DELETE' );
    }
    return
}


sub get {
    my $self = shift or return;
    my $post_data;
    $post_data = pop
        if ref $_[-1];
    my @path = @_    or return;    # using || breaks this

    # Calling nodes method here would call get method itself and so on
    # Commented out to avoid an infinite loop
    #if ( $self->nodes ) {
        return $self->action( path => join( '/', @path ), method => 'GET', post_data => $post_data );
    #}
    return;
}


sub new {

    my $c     = shift;
    my @p     = @_;
    my $class = ref($c) || $c;

    my %params;

    if ( scalar @p == 1 ) {

        croak 'new() requires a hash for params'
          unless ref $p[0] eq 'HASH';

        %params = %{ $p[0] };

    }
    elsif ( scalar @p % 2 != 0 ) {    # 'unless' is better than != but anyway
        croak 'new() called with an odd number of parameters'

    }
    else {
        %params = @p
          or croak 'new() requires a hash for params';
    }

    my $host     = delete $params{host}     || croak 'host param is required';
    my $password = delete $params{password} || croak 'password param is required';
    my $port     = delete $params{port}     || 8006;
    my $username = delete $params{username} || 'root';
    my $realm    = delete $params{realm}    || 'pam';
    my $debug    = delete $params{debug};
    my $timeout  = delete $params{timeout}  || 10;
    my $ssl_opts = delete $params{ssl_opts};
    croak 'unknown parameters to new: ' . join(', ', keys %params) if keys %params;

    my $self->{params} = {
            host => $host,
            password => $password,
            port => $port,
            username => $username,
            realm => $realm,
            debug => $debug,
            timeout => $timeout,
            ssl_opts => $ssl_opts,
    };

    $self->{'ticket'}           = undef;
    $self->{'ticket_timestamp'} = undef;
    $self->{'ticket_life'}      = 7200;    # 2 Hours

    my %lwpUserAgentOptions;
    if ($ssl_opts) {
        $lwpUserAgentOptions{ssl_opts} = $ssl_opts;
    }

    my $ua = LWP::UserAgent->new( %lwpUserAgentOptions );
    $ua->timeout($timeout);
    $self->{ua} = $ua;

    bless $self, $class;
    return $self

}


sub post {

    my $self      = shift or return;
    my $post_data;
    $post_data = pop
        if ref $_[-1];
    my @path = @_    or return;    # using || breaks this

    if ( $self->nodes ) {

        return $self->action(
            path      => join( '/', @path ),
            method    => 'POST',
            post_data => $post_data
          )

    }
    return
}


sub put {

    my $self = shift or return;
    my $post_data;
    $post_data = pop
        if ref $_[-1];
    my @path = @_    or return;    # using || breaks this

    if ( $self->nodes ) {

        return $self->action(
            path      => join( '/', @path ),
            method    => 'PUT',
            post_data => $post_data
          )

    }
    return
}



sub url_prefix {

    my $self = shift or return;

    # Prepare prefix for request
    my $url_prefix = sprintf( 'https://%s:%s',
        $self->{params}->{host},
        $self->{params}->{port} );

    return $url_prefix

}


1;

__END__