File Coverage

blib/lib/WebService/Scaleway.pm

Criterion	Covered	Total	%
statement	45	114	39.4
branch	0	28	0.0
condition	0	5	0.0
subroutine	15	42	35.7
pod	10	11	90.9
total	70	200	35.0

package WebService::Scaleway;

use 5.014000;
use strict;
use warnings;

our $VERSION = '0.001001';

use Carp qw/croak/;
use HTTP::Tiny;
use JSON::MaybeXS;
use Scalar::Util qw/blessed/;

my $ht = HTTP::Tiny->new(
	agent      => "WebService-Scaleway/$VERSION ",
	verify_SSL => 1,
);

# Instance of WebService::Scaleway with no API key
# Used to create tokens from email/password
my $dummy = '';
$dummy = bless \$dummy, __PACKAGE__;

sub _account ($) { "https://account.scaleway.com$_[0]"}
sub _api     ($) { "https://api.scaleway.com$_[0]" }

sub _request {
	my ($self, $method, $url, $opts) = @_;
	$opts->{headers} //= {};
	$opts->{headers}{'X-Auth-Token'} = $$self if $$self;
	$opts->{headers}{'Content-Type'} = 'application/json';
	my $ret = $ht->request($method, $url, $opts);
	die 'Request to Scaleway API server was unsuccessful: ' . $ret->{status} . ' ' . $ret->{reason} . '; ' . $ret->{content} unless $ret->{success};

	decode_json $ret->{content} if $ret->{status} != 204;
}

sub _get    { shift->_request(GET    => @_) }
sub _post   { shift->_request(POST   => @_) }
sub _patch  { shift->_request(PATCH  => @_) }
sub _put    { shift->_request(PUT    => @_) }
sub _delete { shift->_request(DELETE => @_) }

sub _tores {
	my @ret = map { bless $_, 'WebService::Scaleway::Resource' } @_;
	wantarray ? @ret : $ret[0]
}

sub new {
	my ($class, $token) = @_;
	$token = $dummy->create_token(@_[1..$#_])->id if @_ > 2;

	bless \$token, $class
}

BEGIN {
	my @account_res = qw/token organization user/;
	my @api_res = qw/server volume snapshot image ip security_group/;

	my %res = (
		map ({ $_ => _account "/${_}s" } @account_res),
		map  { $_ => _api     "/${_}s" } @api_res);

	my %create_parms = (
		token          => [qw/email password expires/],
		server         => [qw/name organization image volumes tags/],
		volume         => [qw/name organization volume_type size/],
		snapshot       => [qw/name organization volume_id/],
		image          => [qw/name organization root_volume arch/],
		ip             => [qw/     organization/],
		security_group => [qw/name organization description/],
	);

	sub dynsub {
		no strict 'refs';
		my $sub = pop;
		*$_ = $sub for @_
	}

	for my $res (keys %res) {
		dynsub $res, "get_$res", sub {
			local *__ANON__ = $res;
			_tores shift->_get("$res{$res}/$_[0]")->{$res}
		};

		dynsub $res.'s', "list_$res".'s', sub {
			local *__ANON__ = $res.'s';
			my @ret = _tores @{shift->_get($res{$res})->{$res.'s'}};
			wantarray ? @ret : $ret[0]
		};

		dynsub "delete_$res", sub {
			local *__ANON__ = "delete_$res";
			shift->_delete("$res{$res}/$_[0]")
		};

		dynsub "create_$res", sub {
			local *__ANON__ = "create_$res";
			my $self = shift;
			my $content = $_[0];
			if (blessed $content || ref $content ne 'HASH') {
				croak "create_$res does not understand positional parameters, pass a hashref instead\n" unless $create_parms{$res};
				my @parms = @{$create_parms{$res}};
				$content = { map {
					$parms[$_] => (blessed $_[$_] ? $_[$_]->id : $_[$_]) } 0 .. $#_ };
			}
			_tores $self->_post($res{$res},        { content => encode_json $content })->{$res}
		};

		dynsub "update_$res", sub {
			local *__ANON__ = "update_$res";
			my $data = blessed $_[1] ? {%{$_[1]}} : $_[1];
			shift->_put("$res{$res}/".$data->{id}, { content => encode_json $data })
		};
	}
}

sub security_group_rule {
	_tores shift->_get(_api "/security_groups/$_[0]/rules/$_[1]")->{rule}
}

sub security_group_rules {
	_tores @{shift->_get(_api "/security_groups/$_[0]/rules")->{rules}}
}

BEGIN {
	*get_security_group_rule  = \&security_group_rule;
	*list_security_group_rule = \&security_group_rules;
}

sub delete_security_group_rule {
	shift->_delete(_api "/security_groups/$_[0]/rules/$_[1]")
}

sub create_security_group_rule {
	my $self = shift;
	my $grp = shift;
	my $content = $_[0];
	unless (ref $content eq 'HASH') {
		my @parms = qw/organization action direction ip_range protocol dest_port_from/;
		$content = { map { $parms[$_] => $_[$_] } 0 .. $#_ };
	}
	$self->_post(_api "/security_groups/$grp/rules",        { content => encode_json $content })
}

sub update_security_group_rule {
	my $data = blessed $_[2] ? {%{$_[2]}} : $_[2];
	shift->_put (_api "/security_groups/$_[0]/rules/".$data->{id}, { content => encode_json $data })
}

sub server_actions {
	@{shift->_get(_api "/servers/$_[0]/action")->{actions}}
}

BEGIN { *list_server_actions = \&server_actions }

sub perform_server_action {
	my $content = encode_json { action => $_[2] };
	_tores shift->_post(_api "/servers/$_[0]/action", { content => $content })->{task};
}

sub refresh_token {
	_tores shift->_patch(_account "/tokens/$_[0]")->{token}
}

sub server_metadata {
	_tores $dummy->_get('http://169.254.42.42/conf?format=json')
}

package # hide from PAUSE
  WebService::Scaleway::Resource;

use overload '""' => sub { shift->id };

our $AUTOLOAD;
sub AUTOLOAD {
	my ($self) = @_;
	my ($attr) = $AUTOLOAD =~ m/::([^:]*)$/s;
	die "No such attribute: $attr" unless exists $self->{$attr};
	$self->{$attr}
}

sub can {
	my ($self, $sub) = @_;
	exists $self->{$sub} ? sub { shift->{$sub} } : undef
}

sub DESTROY {} # Don't call AUTOLOAD on destruction

1;
__END__