File Coverage

blib/lib/Net/Etcd/Role/Actions.pm
Criterion Covered Total %
statement 36 163 22.0
branch 0 56 0.0
condition 0 11 0.0
subroutine 12 24 50.0
pod 6 6 100.0
total 54 260 20.7


line stmt bran cond sub pod time code
1 9     9   62860 use utf8;
  9         14  
  9         50  
2              
3             package Net::Etcd::Role::Actions;
4              
5 9     9   285 use strict;
  9         15  
  9         129  
6 9     9   35 use warnings;
  9         12  
  9         150  
7              
8 9     9   52 use Moo::Role;
  9         26  
  9         69  
9 9     9   5292 use AE;
  9         41465  
  9         209  
10 9     9   42 use JSON;
  9         15  
  9         51  
11 9     9   846 use MIME::Base64;
  9         11  
  9         442  
12 9     9   46 use Types::Standard qw(InstanceOf);
  9         14  
  9         71  
13 9     9   7661 use AnyEvent::HTTP;
  9         189263  
  9         538  
14 9     9   61 use Carp;
  9         18  
  9         366  
15 9     9   4309 use Data::Dumper;
  9         43892  
  9         434  
16              
17 9     9   57 use namespace::clean;
  9         11  
  9         60  
18              
19             =encoding utf8
20              
21             =head1 NAME
22              
23             Net::Etcd::Role::Actions
24              
25             =cut
26              
27             our $VERSION = '0.022';
28              
29             has etcd => (
30             is => 'ro',
31             isa => InstanceOf ['Net::Etcd'],
32             );
33              
34             =head2 json_args
35              
36             arguments that will be sent to the api
37              
38             =cut
39              
40             has json_args => ( is => 'lazy', );
41              
42             sub _build_json_args {
43 0     0     my ($self) = @_;
44 0           my $args;
45 0           for my $key ( keys %{$self} ) {
  0            
46 0 0         unless ( $key =~ /(?:etcd|cb|cv|hold|json_args|endpoint)$/ ) {
47 0           $args->{$key} = $self->{$key};
48             }
49             }
50 0           return to_json($args);
51             }
52              
53             =head2 cb
54              
55             AnyEvent callback must be a CodeRef
56              
57             =cut
58              
59             has cb => (
60             is => 'ro',
61             isa => sub {
62             die "$_[0] is not a CodeRef!" if ( $_[0] && ref( $_[0] ) ne 'CODE' );
63             },
64             );
65              
66             =head2 cv
67              
68             =cut
69              
70             has cv => ( is => 'ro', );
71              
72             =head2 init
73              
74             =cut
75              
76             sub init {
77 0     0 1   my ($self) = @_;
78 0           my $init = $self->json_args;
79 0 0         $init or return;
80 0           return $self;
81             }
82              
83             =head2 headers
84              
85             =cut
86              
87             has headers => (
88             is => 'lazy',
89             clearer => 1
90             );
91              
92             sub _build_headers {
93 0     0     my ($self) = @_;
94 0           my $headers;
95 0           my $token = $self->etcd->auth_token;
96 0           $headers->{'Content-Type'} = 'application/json';
97 0 0         unless ( $self->endpoint =~ m/authenticate/ ) {
98 0 0         $headers->{'Authorization'} = $token if $token;
99             }
100 0           return $headers;
101             }
102              
103             has tls_ctx => ( is => 'lazy', );
104              
105             sub _build_tls_ctx {
106 0     0     my ($self) = @_;
107 0           my $ca_file = $self->etcd->ca_file;
108 0           my $key_file = $self->etcd->key_file;
109 0           my $cert_file = $self->etcd->cert_file;
110 0           my $cacert = $self->etcd->cacert;
111 0           my $tls;
112 0 0         $tls->{ca_file} = $ca_file if $ca_file;
113 0 0         $tls->{key_file} = $key_file if $key_file;
114 0 0         $tls->{cert_file} = $cert_file if $cert_file;
115 0 0         $tls->{cacert} = $cacert if $cacert;
116              
117 0 0 0       if ( $ca_file || $key_file || $cert_file ) {
      0        
118 0           $tls->{verify} = 1;
119 0           return $tls;
120             }
121 0           return 'low';
122             }
123              
124             =head2 hold
125              
126             When set will not fire request.
127              
128             =cut
129              
130             has hold => ( is => 'ro' );
131              
132             =head2 response
133              
134             =cut
135              
136             has response => ( is => 'ro' );
137              
138             =head2 retry_auth
139              
140             When set will retry authentication request and update token
141              
142             =cut
143              
144             has retry_auth => (
145             is => 'ro',
146             default => 0
147             );
148              
149             =head2 request
150              
151             =cut
152              
153             has request => ( is => 'lazy', );
154              
155             sub _build_request {
156 0     0     my ($self) = @_;
157 0 0         if ( $self->{retry_auth} > 1 ) {
158 0           confess
159             "Error: Unable to authenticate, check your username and password";
160 0           $self->{retry_auth} = 0;
161 0           return;
162             }
163 0           $self->init;
164 0           my $cb = $self->cb;
165 0 0         my $cv = $self->cv ? $self->cv : AE::cv;
166 0           $cv->begin;
167              
168             http_request(
169             'POST',
170             $self->etcd->api_path . $self->{endpoint},
171             headers => $self->headers,
172             body => $self->json_args,
173             tls_ctx => $self->tls_ctx,
174             on_header => sub {
175 0     0     my ($headers) = @_;
176 0           $self->{response}{headers} = $headers;
177             },
178             want_body_handle => 1,
179             sub {
180 0     0     my ( $handle, $hdr ) = @_;
181             my $json_reader = sub {
182 0           my ( $handle, $json ) = @_;
183 0 0         return unless $json;
184 0           $self->{response}{content} = JSON::encode_json($json);
185 0 0         $cb->( $json, $hdr ) if $cb;
186 0           my $status = $hdr->{Status};
187 0           $self->check_hdr($status);
188 0           $cv->send;
189 0           };
190             my $chunk_reader = sub {
191 0           my ( $handle, $line ) = @_;
192 0 0         return unless $line;
193              
194             #read chunk size
195 0 0         $line =~ /^([0-9a-fA-F]+)/
196             or die 'bad chunk (incorrect length) -[' . $line . ']-';
197 0           my $len = hex $1;
198              
199             #read chunk
200             $handle->push_read(
201             chunk => $len,
202             sub {
203 0           my ( $handle, $chunk ) = @_;
204             $handle->push_read(
205             line => sub {
206 0 0         length $_[1]
207             and die 'bad chunk (missing last empty line)';
208             }
209 0           );
210 0           $self->{response}{content} = $chunk;
211 0 0         $cb->( $chunk, $hdr ) if $cb;
212 0           my $status = $hdr->{Status};
213 0           $self->check_hdr($status);
214 0           $cv->send;
215             }
216 0           );
217 0           };
218              
219 0 0 0       if ( ( $hdr->{'transfer-encoding'} || '' ) =~ /\bchunked\b/i ) {
220             $handle->on_read(
221 0           sub { $handle->push_read( line => $chunk_reader ) } );
  0            
222             }
223             else {
224             $handle->on_read(
225 0           sub { $handle->push_read( json => $json_reader ) } );
  0            
226             }
227              
228 0           $handle->on_eof( sub { $handle->destroy; $cv->end } );
  0            
  0            
229 0           $handle->on_error( sub { $handle->destroy; $cv->end } );
  0            
  0            
230             }
231 0           );
232 0           $cv->recv;
233 0           $self->clear_headers;
234              
235 0 0 0       if ( defined $self->{retry_auth} && $self->{retry_auth} ) {
236 0           my $auth = $self->etcd->auth()->authenticate;
237 0 0         if ( $auth->{response}{success} ) {
238 0           $self->{retry_auth} = 0;
239 0           $self->request;
240             }
241             }
242 0           return $self;
243             }
244              
245             =head2 get_value
246              
247             returns single decoded value or the first.
248              
249             =cut
250              
251             sub get_value {
252 0     0 1   my ($self) = @_;
253 0           local $@;
254 0           my $response = $self->response;
255 0           my $content;
256 0           eval { $content = from_json( $response->{content} ) };
  0            
257 0 0         return if $@;
258              
259             #print STDERR Dumper($content);
260 0           my $value = $content->{kvs}->[0]->{value};
261 0 0         $value or return;
262 0           return decode_base64($value);
263             }
264              
265             =head2 all
266              
267             returns list containing for example:
268              
269             {
270             'mod_revision' => '3',
271             'version' => '1',
272             'value' => 'bar',
273             'create_revision' => '3',
274             'key' => 'foo0'
275             }
276              
277             where key and value have been decoded for your pleasure.
278              
279             =cut
280              
281             sub all {
282 0     0 1   my ($self) = @_;
283 0           local $@;
284 0           my $response = $self->response;
285 0           my $content;
286 0           eval { $content = from_json( $response->{content} ) };
  0            
287 0 0         return if $@;
288 0           my $kvs = $content->{kvs};
289 0           for my $row (@$kvs) {
290 0           $row->{value} = decode_base64( $row->{value} );
291 0           $row->{key} = decode_base64( $row->{key} );
292             }
293 0           return $kvs;
294             }
295              
296             =head2 is_success
297              
298             Success is returned if the response is a 200
299              
300             =cut
301              
302             sub is_success {
303 0     0 1   my ($self) = @_;
304 0           my $response = $self->response;
305 0 0         if ( defined $response->{success} ) {
306 0           return $response->{success};
307             }
308 0           return;
309             }
310              
311             =head2 content
312              
313             returns JSON decoded content hash
314              
315             =cut
316              
317             sub content {
318 0     0 1   my ($self) = @_;
319 0           local $@;
320 0           my $response = $self->response;
321 0           my $content;
322 0           eval { $content = from_json( $response->{content} ) };
  0            
323 0 0         return if $@;
324 0 0         return $content if $content;
325 0           return;
326             }
327              
328             =head2 check_hdr
329              
330             check response header then define success and retry_auth.
331              
332             =cut
333              
334             sub check_hdr {
335 0     0 1   my ( $self, $status ) = @_;
336 0 0         my $success = $status == 200 ? 1 : 0;
337 0           $self->{response}{success} = $success;
338 0 0         $self->{retry_auth}++ if $status == 401;
339 0           return;
340             }
341              
342             1;