package Net::OpenStack::Client::Request; $Net::OpenStack::Client::Request::VERSION = '0.1.4'; use strict; use warnings; use base qw(Exporter); use Readonly; Readonly our @SUPPORTED_METHODS => qw(DELETE GET PATCH POST PUT); Readonly our @METHODS_REQUIRE_OPTIONS => qw(PATCH POST PUT); our @EXPORT = qw(mkrequest); our @EXPORT_OK = qw(parse_endpoint @SUPPORTED_METHODS @METHODS_REQUIRE_OPTIONS $HDR_X_AUTH_TOKEN); use overload bool => '_boolean'; Readonly our $HDR_ACCEPT => 'Accept'; Readonly our $HDR_ACCEPT_ENCODING => 'Accept-Encoding'; Readonly our $HDR_CONTENT_TYPE => 'Content-Type'; Readonly our $HDR_X_AUTH_TOKEN => 'X-Auth-Token'; Readonly our $HDR_X_SUBJECT_TOKEN => 'X-Subject-Token'; Readonly my %DEFAULT_HEADERS => { $HDR_ACCEPT => 'application/json, text/plain', $HDR_ACCEPT_ENCODING => 'identity, gzip, deflate, compress', $HDR_CONTENT_TYPE => 'application/json', }; =head1 NAME Net::OpenStack::Client::Request is an request class for Net::OpenStack. Boolean logic is overloaded using C<_boolean> method (as inverse of C). =head2 Public functions =over =item mkrequest A C factory =cut sub mkrequest { return Net::OpenStack::Client::Request->new(@_); } =item parse_endpoint Parse C and look for templates and parameters. Return (possibly modified) endpoint, arrayref of template names and arrayref of parameter names. If C is passed, report an error and return; else die on failure. =cut sub parse_endpoint { my ($origendpoint, $logger) = @_; # strip parameters my ($endpoint, $paramtxt) = $origendpoint =~ /^([^?]+)(?:\?([^?]+))?$/; # List of key names that have to be passed my (@templates, @params); foreach my $template ($endpoint =~ m#\{([^/]+)}#g) { # only add once; order is not that relevant push(@templates, $template) if (!grep {$_ eq $template} @templates); }; foreach my $kv (split(/&/, $paramtxt || '')) { if ($kv =~ m/^([^=]+)=/) { push(@params, $1); } else { # invalid my $msg = "invalid parameter kv $kv for origendpoint $origendpoint"; if ($logger) { $logger->error($msg); return; } else { die $msg; } } } return $endpoint, \@templates, \@params; } =pod =back =head2 Public methods =over =item new Create new request instance from options for command C and REST HTTP C. The C is the URL to use (can be templated with C) Options =over =item tpls: template names and values =item opts: optional arguments =item error: an error (no default) =item service: service name =item version: service version =item result: result path for the response =back =cut sub new { my ($this, $endpoint, $method, %opts) = @_; my $class = ref($this) || $this; my $self = { endpoint => $endpoint, tpls => $opts{tpls} || {}, params => $opts{params} || {}, opts => $opts{opts} || {}, paths => $opts{paths} || {}, raw => $opts{raw}, rest => $opts{rest} || {}, # options for rest error => $opts{error}, # no default service => $opts{service}, version => $opts{version}, result => $opts{result}, }; if (grep {$method eq $_} @SUPPORTED_METHODS) { $self->{method} = $method; } else { $self->{error} = "Unsupported method $method"; } bless $self, $class; return $self; }; =item endpoint Parses the endpoint attribute, look for any templates, and replace them with values from C attribute hashref. Any parameters defined in the endpoint are removed, and only those that are present in the C attribute are readded with the values from the attribute. The data can contain more keys than what is required for templating, those keys and their values will be ignored. This does not modify the endpoint attribute. Return templated endpoint on success or undef on failure. If host is defined, try to make a full URL =over =item if you provide only fqdn, make a https:///v =item if you provide URL, check for version suffix, return / =back =cut sub endpoint { my ($self, $host) = @_; # reset error attribute $self->{error} = undef; my ($endpoint, $templates, $params) = parse_endpoint($self->{endpoint}); foreach my $template (@$templates) { my $pattern = '\{' . $template . '\}'; if (exists($self->{tpls}->{$template})) { $endpoint =~ s#$pattern#$self->{tpls}->{$template}#g; } else { $self->{error} = "Missing template $template data to replace endpoint $self->{endpoint}"; return; } } my @fparams; foreach my $param (sort @$params) { if (exists($self->{params}->{$param})) { push(@fparams, "$param=".$self->{params}->{$param}); } } if (@fparams) { $endpoint =~ s/\/+$//; $endpoint .= '?'.join('&', @fparams); } if ($host) { my $url = $host; my $version_suffix = "v$self->{version}"; $version_suffix =~ s/^v+/v/; if ($host !~ m/^http/) { $url = "https://$url/$version_suffix"; } elsif ($host !~ m#/v[\d.]+/?$#) { $url .= "/$version_suffix"; } $url =~ s#/+$##; $endpoint =~ s#^/+##; $endpoint = "$url/$endpoint"; } return $endpoint; } =item opts_data Generate hashref from options, to be used for JSON encoding. If C attribute is defined, ignore all options and return it. Returns empty hasref, even if no options existed. =cut sub opts_data { my ($self) = @_; my $root; if ($self->{raw}) { # ignore all options passed $root = $self->{raw}; } else { $root = {}; foreach my $key (sort keys %{$self->{opts}}) { my @paths = @{$self->{paths}->{$key}}; my $lastpath = pop(@paths); my $here = $root; foreach my $path (@paths) { # build tree $here->{$path} = {} if !exists($here->{$path}); $here = $here->{$path}; } # no intermediate variable with value $here->{$lastpath} = $self->{opts}->{$key}; } } return $root; } =item headers Return headers for the request. Supported options: =over =item token: authentication token stored in X-Auth-Token =item headers: hashref with headers to add that take precedence over the defaults. Headers with an undef value will be removed. =back =cut sub headers { my ($self, %opts) = @_; my $headers = {%DEFAULT_HEADERS}; while (my ($hdr, $value) = each %{$opts{headers} || {}}) { if (defined($value)) { $headers->{$hdr} = $value; } else { delete $headers->{$hdr}; } } $headers->{$HDR_X_AUTH_TOKEN} = $opts{token} if defined $opts{token}; return $headers; } =item is_error Test if this is an error or not (based on error attribute). =cut sub is_error { my $self = shift; return $self->{error} ? 1 : 0; } # Overloaded boolean, inverse of is_error sub _boolean { my $self = shift; return ! $self->is_error(); } =pod =back =cut 1;