From 362a19d8b48cd83f3b48585e0c69d51553354e40 Mon Sep 17 00:00:00 2001 From: Marius Gavrilescu Date: Sun, 20 Sep 2015 00:52:07 +0300 Subject: [PATCH] Initial commit --- Changes | 4 + MANIFEST | 7 + Makefile.PL | 21 ++ README | 30 ++ lib/WebService/Scaleway.pm | 611 +++++++++++++++++++++++++++++++++++++ t/compile.t | 6 + t/real.t | 59 ++++ 7 files changed, 738 insertions(+) create mode 100644 Changes create mode 100644 MANIFEST create mode 100644 Makefile.PL create mode 100644 README create mode 100644 lib/WebService/Scaleway.pm create mode 100644 t/compile.t create mode 100644 t/real.t diff --git a/Changes b/Changes new file mode 100644 index 0000000..da989f8 --- /dev/null +++ b/Changes @@ -0,0 +1,4 @@ +Revision history for Perl extension WebService::Scaleway. + +0.001 2015-09-20T00:52+03:00 + - Initial release diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..d7499ea --- /dev/null +++ b/MANIFEST @@ -0,0 +1,7 @@ +Changes +Makefile.PL +MANIFEST +README +t/compile.t +t/real.t +lib/WebService/Scaleway.pm diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..4d4cb84 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,21 @@ +use 5.014000; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'WebService::Scaleway', + VERSION_FROM => 'lib/WebService/Scaleway.pm', + ABSTRACT_FROM => 'lib/WebService/Scaleway.pm', + AUTHOR => 'Marius Gavrilescu ', + MIN_PERL_VERSION => '5.14.0', + LICENSE => 'perl', + SIGN => 1, + PREREQ_PM => { + qw/JSON::MaybeXS 0/, + }, + META_MERGE => { + dynamic_config => 0, + resources => { + repository => 'https://git.ieval.ro/?p=webservice-scaleway.git', + } + } +); diff --git a/README b/README new file mode 100644 index 0000000..d8a914c --- /dev/null +++ b/README @@ -0,0 +1,30 @@ +WebService-Scaleway version 0.001 +================================= + +Scaleway is an IaaS provider that offers bare metal ARM cloud servers. +WebService::Scaleway is a Perl interface to the Scaleway API. + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + +* JSON::MaybeXS + +COPYRIGHT AND LICENCE + +Copyright (C) 2015 by Marius Gavrilescu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.20.2 or, +at your option, any later version of Perl 5 you may have available. + + diff --git a/lib/WebService/Scaleway.pm b/lib/WebService/Scaleway.pm new file mode 100644 index 0000000..d4ea8b6 --- /dev/null +++ b/lib/WebService/Scaleway.pm @@ -0,0 +1,611 @@ +package WebService::Scaleway; + +use 5.014000; +use strict; +use warnings; + +our $VERSION = '0.001'; + +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 => $_[1] }; + _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__ + +=encoding utf-8 + +=head1 NAME + +WebService::Scaleway - Perl interface to Scaleway cloud server provider API + +=head1 SYNOPSIS + + use WebService::Scaleway; + my $token = ...; # API token here + my $sw = WebService::Scaleway->new($token); + my $org = $sw->organizations; + + # Create an IP, a volume, and use them for a new Debian Jessie server + my $ip = $sw->create_ip($org); + my $vol = $sw->create_volume('testvol', $org, 'l_ssd', 50_000_000_000); + my ($debian) = grep { $_->name =~ /debian jessie/i } $sw->images; + my $srv = $sw->create_server('testsrv', $org, $debian, {1 => {%$vol}}); + + # Change the server name + $srv->{name} = 'Debian'; + $sw->update_server($srv); + + # Boot the server + $sw->perform_server_action($srv, 'poweron'); + say "The server is now booting. To access it, do ssh root@", $ip->address; + +=head1 DESCRIPTION + +Scaleway is an IaaS provider that offers bare metal ARM cloud servers. +WebService::Scaleway is a Perl interface to the Scaleway API. + +=head2 Constructors + +WebService::Scaleway objects are defined by their authentication +token. There are two consructors: + +=over + +=item WebService::Scaleway->B(I<$auth_token>) + +Construct a WebService::Scaleway object from a given authentication +token. + +=item WebService::Scaleway->B(I<$email>, I<$password>) + +Construct a WebService::Scaleway object from an authentication token +obtained by logging in with the given credentials. + +=back + +=head2 Listing resources + +These methods return a list of all resources of a given type +associated to your account. Each resource is a blessed hashref with +Ced accessors (for example C<< $resource->{name} >> can be +written as C<< $resource->name >>) and that stringifies to the ID of +the resource: C<< $resource->id >>. + +There is no difference between B() and +B(). + +=over + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B + +=item $self->B + +Official documentation: L. + +=item $self->B(I<$group_id>) + +=item $self->B(I<$group_id>) + +Official documentation: L. + +=back + +=head2 Retrieving resources + +These methods take the id of a resource and return the resource as a +blessed hashref as described in the previous section. + +There is no difference between B(I<$id>) and +B(I<$id>). + +=over + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$group_id>, I<$rule_id>) + +=item $self->B(I<$group_id>, I<$rule_id>) + +Official documentation: L. + +=back + +=head2 Deleting resources + +These methods take the id of a resource and delete it. They do not +return anything. + +=over + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$id>) + +Official documentation: L. + +=item $self->B(I<$group_id>, I<$rule_id>) + +Official documentation: L. + +=back + +=head2 Modifying resources + +These methods take a hashref representing a resource that already +exists and update it. The value of C<< $resource->{id} >> is used for +identifying this resource on the remote end. Both blessed and +unblessed hashrefs are accepted. The updated resource is returned as a +blessed hashref as described in L. + +=over + +=item $self->B(I<$resource>) + +Official documentation: L. + +=item $self->B(I<$resource>) + +Official documentation: L. + +=item $self->B(I<$resource>) + +Official documentation: L. + +=item $self->B(I<$resource>) + +Official documentation: L. + +=item $self->B(I<$resource>) + +Official documentation: L. + +=item $self->B(I<$group_id>, I<$resource>) + +Official documentation: L. + +=back + +=head2 Creating resources + +These methods take either a hash that is passed directly to the API or +a method-specific list of positional parameters. They create a new +resource and return it as a blessed hashref as described in +L. + +When using positional parameters, you can pass a resource in blessed +hashref format where a resource ID is expected. The function will call +C<< ->id >> on the resouce automatically. + +Most of these methods require an organization ID. You can obtain it +with the B method described above. + +=over + +=item $self->B(I<\%data>) + +=item $self->B(I<$email>, I<$password>, [I<$expires>]) + +Authenticates a user against their username and password and returns +an authentication token. If I<$expires> (default: false) is true, the +token will expire. + +This method is called internally by the two-argument constructor. + +Official documentation: L. + +=item $self->B(I<\%data>) + +=item $self->B(I<$name>, I<$organization>, I<$image>, I<$volumes>, [I<$tags>]) + +Creates and returns a new server. + +I<$name> is the server name. I<$organization> is the organization ID. +I<$image> is the image ID. I<$volumes> is a "sparse array" (hashref +from indexes to volumes, indexed from 1) of volumes. I<$tags> is an +optional arrayref of tags. + +Note that the volumes must be unblessed hashrefs. If I<$vol> is a +volume, you can use this idiom: C<< $volumes = {1 => {%$vol}} >>. + +Official documentation: L. + +=item $self->B(I<\%data>) + +=item $self->B(I<$name>, I<$organization>, I<$volume_type>, I<$size>) + +Creates and returns a new volume. I<$volume_type> currently must be +C. I<$size> is the size in bytes. + +Official documentation: L. + +=item $self->B(I<\%data>) + +=item $self->B(I<$name>, I<$organization>, I<$volume_id>) + +Creates and returns a snapshot of the volume I<$volume_id>. + +Official documentation: L. + +=item $self->B(I<\%data>) + +=item $self->B(I<$name>, I<$organization>, I<$root_volume>, I<$arch>) + +Creates and returns an image from the volume I<$root_volume>. I<$arch> +is the architecture of the image (currently must be C<"arm">). + +Official documentation: L. + +=item $self->B(I<\%data>) + +=item $self->B(I<$organization>) + +Official documentation: L. + +=item $self->B(I<\%data>) + +=item $self->B(I<$name>, I<$organization>, I<$description>) + +Official documentation: L. + +=item $self->B(I<$group_id>) + +=item $self->B(I<$group_id>, I<$organization>, I<$action>, I<$direction>, I<$ip_range>, I<$protocol>, [<$dest_port_from>]) + + +Official documentation: L. + +=back + +=head2 Miscellaneous methods + +These are methods that don't fit any previous category. Any use of +"blessed hashref" refers to the concept described in L. Wherever a resource ID is expected, you can instead pass +a resource as a blessed hashref and the method will call C<< ->id >> +on it for you. + +=over + +=item $self->B(I<$server_id>) + +=item $self->B(I<$server_id>) + +Returns a list of strings representing possible actions you can +perform on the given server. Example actions are powering on/off a +server or rebooting it. + +Official documentation: L + +=item $self->B(I<$server_id>, I<$action>) + +Performs an action on a server. I<$action> is one of the strings +returned by B. The function returns a blessed hashref +with information about the task. + +This is not very useful, as this module does not currently offer any +function for tracking tasks. + +Official documentation: L + +=item $self->B(I<$token_id>) + +This method takes the ID of an expirable token, extends its expiration +date by 30 minutes, and returns the new token as a blessed hashref. + +Official documentation: L + +=item $self->B + +This method can only be called from a Scaleway server. It returns +information about the server as a blessed hashref. + +Official documentation: L + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Marius Gavrilescu, Emarius@ieval.roE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2015 by Marius Gavrilescu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.20.2 or, +at your option, any later version of Perl 5 you may have available. + + +=cut diff --git a/t/compile.t b/t/compile.t new file mode 100644 index 0000000..5e1faef --- /dev/null +++ b/t/compile.t @@ -0,0 +1,6 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 1; +BEGIN { use_ok('WebService::Scaleway') }; diff --git a/t/real.t b/t/real.t new file mode 100644 index 0000000..07b9d2c --- /dev/null +++ b/t/real.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use WebService::Scaleway; + +use Test::More; + +BEGIN { + plan skip_all => 't/api_key file missing' unless -f 't/api_key'; + plan tests => 7; +} + +open my $akf, '<', 't/api_key'; +my $token = <$akf>; +chomp $token; +close $akf; +my $sw = WebService::Scaleway->new($token); + +my $org = $sw->organizations; +my $user = $sw->user($org->users->[0]->{id}); +note 'This token belongs to ', $user->fullname, ' <', $user->email, '>'; + +my $ip = $sw->create_ip($org); +note "Created new ip $ip with address ", $ip->address; +is $sw->ip($ip)->address, $ip->address, 'get_ip'; +my @ips = $sw->ips; +ok grep ({$_->address eq $ip->address} @ips), 'list_ips'; + +my $vol = $sw->create_volume('testvol', $org, 'l_ssd', 50_000_000_000); +note "Created new volume $vol with name ", $vol->name; +is $sw->volume($vol)->name, $vol->name, 'get_volume'; +my @vols = $sw->volumes; +ok grep ({$_->name eq $vol->name} @vols), 'list_volumes'; + +my ($debian) = grep { $_->name =~ /debian jessie/i } $sw->images; +my $srv = $sw->create_server('mysrv', $org, $debian, {1 => {%$vol}}); +note "Created new server $srv with name ", $srv->name; +is $sw->server($srv)->name, $srv->name, 'get_server'; +$srv->{name} = 'testsrv'; +$sw->update_server($srv); +is $sw->server($srv)->name, $srv->name, 'update_server'; +my @srvs = $sw->servers; +ok grep ({$_->name eq $srv->name} @srvs), 'list_servers'; +note "This server can: ", join ' ', $sw->server_actions($srv); + +## Snapshots are quite expensive +#my $snp = $sw->create_snapshot('mysnap', $org, $vol); +#note "Created new snapshot $snp with name ", $snp->name; +#is $sw->snapshot($snp)->name, $snp->name, 'get_snapshot'; +#$snp->{name} = 'testsnap'; +#$sw->update_snapshot($snp); +#is $sw->snapshot($snp)->name, $snp->name, 'update_snapshot'; + +sleep 20; + +$sw->delete_server($srv); +$sw->delete_ip($ip); +$sw->delete_volume($vol); -- 2.39.2