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


line stmt bran cond sub pod time code
1             package WebService::Scaleway;
2              
3 2     2   21128 use 5.014000;
  2         7  
4 2     2   10 use strict;
  2         2  
  2         49  
5 2     2   9 use warnings;
  2         7  
  2         105  
6              
7             our $VERSION = '0.001';
8              
9 2     2   10 use Carp qw/croak/;
  2         3  
  2         133  
10 2     2   1230525 use HTTP::Tiny;
  2         122153  
  2         86  
11 2     2   1583 use JSON::MaybeXS;
  2         24050697  
  2         199  
12 2     2   22 use Scalar::Util qw/blessed/;
  2         4  
  2         1887  
13              
14             my $ht = HTTP::Tiny->new(
15             agent => "WebService-Scaleway/$VERSION ",
16             verify_SSL => 1,
17             );
18              
19             # Instance of WebService::Scaleway with no API key
20             # Used to create tokens from email/password
21             my $dummy = '';
22             $dummy = bless \$dummy, __PACKAGE__;
23              
24 6     6   29 sub _account ($) { "https://account.scaleway.com$_[0]"}
25 12     12   51 sub _api ($) { "https://api.scaleway.com$_[0]" }
26              
27             sub _request {
28 0     0   0 my ($self, $method, $url, $opts) = @_;
29 0   0     0 $opts->{headers} //= {};
30 0 0       0 $opts->{headers}{'X-Auth-Token'} = $$self if $$self;
31 0         0 $opts->{headers}{'Content-Type'} = 'application/json';
32 0         0 my $ret = $ht->request($method, $url, $opts);
33 0 0       0 die 'Request to Scaleway API server was unsuccessful: ' . $ret->{status} . ' ' . $ret->{reason} . '; ' . $ret->{content} unless $ret->{success};
34              
35 0 0       0 decode_json $ret->{content} if $ret->{status} != 204;
36             }
37              
38 0     0   0 sub _get { shift->_request(GET => @_) }
39 0     0   0 sub _post { shift->_request(POST => @_) }
40 0     0   0 sub _patch { shift->_request(PATCH => @_) }
41 0     0   0 sub _put { shift->_request(PUT => @_) }
42 0     0   0 sub _delete { shift->_request(DELETE => @_) }
43              
44             sub _tores {
45 0     0   0 my @ret = map { bless $_, 'WebService::Scaleway::Resource' } @_;
  0         0  
46 0 0       0 wantarray ? @ret : $ret[0]
47             }
48              
49             sub new {
50 0     0 1 0 my ($class, $token) = @_;
51 0 0       0 $token = $dummy->create_token(@_[1..$#_])->id if @_ > 2;
52              
53 0         0 bless \$token, $class
54             }
55              
56             BEGIN {
57 2     2   21 my @account_res = qw/token organization user/;
58 2         10 my @api_res = qw/server volume snapshot image ip security_group/;
59              
60             my %res = (
61 6         188 map ({ $_ => _account "/${_}s" } @account_res),
62 2         7 map { $_ => _api "/${_}s" } @api_res);
  12         28  
63              
64 2         16 my %create_parms = (
65             token => [qw/email password expires/],
66             server => [qw/name organization image volumes tags/],
67             volume => [qw/name organization volume_type size/],
68             snapshot => [qw/name organization volume_id/],
69             image => [qw/name organization root_volume arch/],
70             ip => [qw/ organization/],
71             security_group => [qw/name organization description/],
72             );
73              
74             sub dynsub {
75 2     2   19 no strict 'refs';
  2         7  
  2         1628  
76 90     90 0 122 my $sub = pop;
77 90         814 *$_ = $sub for @_
78             }
79              
80 2         10 for my $res (keys %res) {
81             dynsub $res, "get_$res", sub {
82 0     0   0 local *__ANON__ = $res;
83 0         0 _tores shift->_get("$res{$res}/$_[0]")->{$res}
84 18         89 };
85              
86             dynsub $res.'s', "list_$res".'s', sub {
87 0     0   0 local *__ANON__ = $res.'s';
88 0         0 my @ret = _tores @{shift->_get($res{$res})->{$res.'s'}};
  0         0  
89 0 0       0 wantarray ? @ret : $ret[0]
90 18         92 };
91              
92             dynsub "delete_$res", sub {
93 0     0   0 local *__ANON__ = "delete_$res";
94 0         0 shift->_delete("$res{$res}/$_[0]")
95 18         104 };
96              
97             dynsub "create_$res", sub {
98 0     0   0 local *__ANON__ = "create_$res";
99 0         0 my $self = shift;
100 0         0 my $content = $_[0];
101 0 0 0     0 if (blessed $content || ref $content ne 'HASH') {
102 0 0       0 croak "create_$res does not understand positional parameters, pass a hashref instead\n" unless $create_parms{$res};
103 0         0 my @parms = @{$create_parms{$res}};
  0         0  
104             $content = { map {
105 0 0       0 $parms[$_] => (blessed $_[$_] ? $_[$_]->id : $_[$_]) } 0 .. $#_ };
  0         0  
106             }
107 0         0 _tores $self->_post($res{$res}, { content => encode_json $content })->{$res}
108 18         85 };
109              
110             dynsub "update_$res", sub {
111 0     0   0 local *__ANON__ = "update_$res";
112 0 0       0 my $data = blessed $_[1] ? {%{$_[1]}} : $_[1];
  0         0  
113 0         0 shift->_put("$res{$res}/".$data->{id}, { content => encode_json $data })
114 18         119 };
115             }
116             }
117              
118             sub security_group_rule {
119             _tores shift->_get(_api "/security_groups/$_[0]/rules/$_[1]")->{rule}
120 0     0 1   }
121              
122             sub security_group_rules {
123 0     0 1   _tores @{shift->_get(_api "/security_groups/$_[0]/rules")->{rules}}
  0            
124             }
125              
126             BEGIN {
127 2     2   7 *get_security_group_rule = \&security_group_rule;
128 2         607 *list_security_group_rule = \&security_group_rules;
129             }
130              
131             sub delete_security_group_rule {
132 0     0 1   shift->_delete(_api "/security_groups/$_[0]/rules/$_[1]")
133             }
134              
135             sub create_security_group_rule {
136 0     0 1   my $self = shift;
137 0           my $grp = shift;
138 0           my $content = $_[0];
139 0 0         unless (ref $content eq 'HASH') {
140 0           my @parms = qw/organization action direction ip_range protocol dest_port_from/;
141 0           $content = { map { $parms[$_] => $_[$_] } 0 .. $#_ };
  0            
142             }
143 0           $self->_post(_api "/security_groups/$grp/rules", { content => encode_json $content })
144             }
145              
146             sub update_security_group_rule {
147 0 0   0 1   my $data = blessed $_[2] ? {%{$_[2]}} : $_[2];
  0            
148 0           shift->_put (_api "/security_groups/$_[0]/rules/".$data->{id}, { content => encode_json $data })
149             }
150              
151             sub server_actions {
152 0     0 1   @{shift->_get(_api "/servers/$_[0]/action")->{actions}}
  0            
153             }
154              
155 2     2   342 BEGIN { *list_server_actions = \&server_actions }
156              
157             sub perform_server_action {
158 0     0 1   my $content = encode_json { action => $_[1] };
159 0           _tores shift->_post(_api "/servers/$_[0]/action", { content => $content })->{task};
160             }
161              
162             sub refresh_token {
163             _tores shift->_patch(_account "/tokens/$_[0]")->{token}
164 0     0 1   }
165              
166             sub server_metadata {
167 0     0 1   _tores $dummy->_get('http://169.254.42.42/conf?format=json')
168             }
169              
170             package # hide from PAUSE
171             WebService::Scaleway::Resource;
172              
173 2     2   11 use overload '""' => sub { shift->id };
  2     0   4  
  2         22  
  0         0  
174              
175             our $AUTOLOAD;
176             sub AUTOLOAD {
177 0     0     my ($self) = @_;
178 0           my ($attr) = $AUTOLOAD =~ m/::([^:]*)$/s;
179 0 0         die "No such attribute: $attr" unless exists $self->{$attr};
180 0           $self->{$attr}
181             }
182              
183             sub can {
184 0     0     my ($self, $sub) = @_;
185 0     0     exists $self->{$sub} ? sub { shift->{$sub} } : undef
186 0 0         }
187              
188       0     sub DESTROY {} # Don't call AUTOLOAD on destruction
189              
190             1;
191             __END__