File Coverage

blib/lib/App/Docker/Client.pm
Criterion Covered Total %
statement 63 142 44.3
branch 10 38 26.3
condition 5 7 71.4
subroutine 20 32 62.5
pod 16 16 100.0
total 114 235 48.5


line stmt bran cond sub pod time code
1             package App::Docker::Client;
2              
3             =head1 NAME
4              
5             App::Docker::Client - Simple and plain Docker client!
6              
7             =head1 VERSION
8              
9             Version 0.010300
10              
11             =cut
12              
13             our $VERSION = '0.010300';
14              
15 3     3   60125 use 5.16.0;
  3         10  
16 3     3   16 use strict;
  3         4  
  3         67  
17 3     3   12 use warnings;
  3         20  
  3         124  
18 3     3   3119 use AnyEvent;
  3         14432  
  3         94  
19 3     3   1552 use AnyEvent::Socket 'tcp_connect';
  3         68439  
  3         259  
20 3     3   2153 use AnyEvent::HTTP;
  3         50062  
  3         291  
21 3     3   2440 use LWP::UserAgent;
  3         131483  
  3         109  
22 3     3   2264 use JSON;
  3         27796  
  3         10  
23 3     3   1928 use LWP::Protocol::http::SocketUnixAlt;
  3         110307  
  3         3312  
24              
25             =head2 new
26              
27             Constructor
28              
29             =cut
30              
31             sub new {
32 2     2 1 3022 my $class = shift;
33 2         6 my $self = {@_};
34 2         12 $self->{_scheme_postfixes} = { file => ':', http => '://', https => '://', };
35 2         11 $self->{_valid_codes} = { 200 => 1, 201 => 1, 204 => 1 };
36 2         3 bless $self, $class;
37 2         5 return $self;
38             }
39              
40             =head1 SUBROUTINES/METHODS
41              
42             =head2 with_valid_code
43              
44             =cut
45              
46             sub with_valid_code {
47 0     0 1 0 my ( $self, $code ) = @_;
48 0 0       0 return if $code !~ m/^(\d{3})$/;
49 0         0 $self->{_valid_codes}->{$code} = 1;
50 0         0 return $self;
51             }
52              
53             =head2 without_valid_code
54              
55             =cut
56              
57             sub without_valid_code {
58 0     0 1 0 my ( $self, $code ) = @_;
59 0 0       0 return if $code !~ m/^(\d{3})$/;
60 0         0 $self->{_valid_codes}->{$code} = 0;
61 0         0 return $self;
62             }
63              
64             =head2 show_progress
65              
66             =cut
67              
68             sub show_progress {
69 0     0 1 0 my ( $self, $show_progress ) = @_;
70 0 0       0 $self->{show_progress} = $show_progress ? $show_progress == 0 ? () : 1 : 1;
    0          
71 0         0 return $self;
72             }
73              
74             =head2 attach
75              
76             =cut
77              
78             sub attach {
79 0     0 1 0 my ( $self, $path, $query, $input, $output ) = @_;
80 0         0 my $cv = AnyEvent->condvar;
81             my $callback = sub {
82 0     0   0 my ( $fh, $headers ) = @_;
83              
84 0         0 $fh->on_error( sub { $cv->send } );
  0         0  
85 0         0 $fh->on_eof( sub { $cv->send } );
  0         0  
86              
87 0         0 my $out_hndl = AnyEvent::Handle->new( fh => $output );
88             $fh->on_read(
89             sub {
90 0         0 my ($handle) = @_;
91             $handle->unshift_read(
92             sub {
93 0         0 my ($h) = @_;
94 0         0 my $length = length $h->{rbuf};
95 0         0 $out_hndl->push_write( $h->{rbuf} );
96 0         0 substr $h->{rbuf}, 0, $length, '';
97             }
98 0         0 );
99             }
100 0         0 );
101              
102 0         0 my $in_hndl = AnyEvent::Handle->new( fh => $input );
103             $in_hndl->on_read(
104             sub {
105 0         0 my ($h) = @_;
106             $h->push_read(
107             line => sub {
108 0         0 my ( $h2, $line, $eol ) = @_;
109 0         0 $fh->push_write( $line . $eol );
110             }
111 0         0 );
112             }
113 0         0 );
114 0         0 $in_hndl->on_eof( sub { $cv->send } );
  0         0  
115 0         0 };
116              
117             http_request(
118             POST => $self->uri( $path, %$query )->as_string,
119             (
120             want_body_handle => 1,
121             (
122             $self->ssl_opts
123             ? (
124             tls_ctx => {
125             verify => 1,
126             verify_peername => "https",
127             ca_file => $self->{ssl_opts}->{SSL_ca_file},
128             cert_file => $self->{ssl_opts}->{SSL_cert_file},
129             key_file => $self->{ssl_opts}->{SSL_key_file},
130             }
131             )
132 0 0       0 : ()
133             ),
134             ),
135             $callback
136             );
137 0         0 return $cv;
138             }
139              
140             =head2 authority
141              
142             Getter/Setter for internal hash key authority.
143              
144             =cut
145              
146             sub authority {
147 4 100 100 4 1 33 return $_[0]->{authority} || '/var/run/docker.sock' unless $_[1];
148 1         3 $_[0]->{authority} = $_[1];
149 1         3 return $_[0]->{authority};
150             }
151              
152             =head2 scheme
153              
154             Getter/Setter for internal hash key scheme.
155              
156             =cut
157              
158             sub scheme {
159 5 100 100 5 1 467 return $_[0]->{scheme} || 'http' unless $_[1];
160 1         3 $_[0]->{scheme} = $_[1];
161 1         3 return $_[0]->{scheme};
162             }
163              
164             =head2 ssl_opts
165              
166             Getter/Setter for internal hash key ssl_opts.
167              
168             =cut
169              
170             sub ssl_opts {
171 0 0   0 1 0 return $_[0]->{ssl_opts} unless $_[1];
172 0         0 $_[0]->{ssl_opts} = $_[1];
173 0         0 return $_[0]->{ssl_opts};
174             }
175              
176             =head2 json
177              
178             Getter/Setter for internal hash key json.
179              
180             =cut
181              
182             sub json {
183 3 50 33 3 1 188 return $_[0]->{json} || JSON->new->utf8() unless $_[1];
184 0         0 $_[0]->{json} = $_[1];
185 0         0 return $_[0]->{json};
186             }
187              
188             =head2 user_agent
189              
190             Getter/Setter for internal hash key UserAgent.
191              
192             =cut
193              
194             sub user_agent {
195 2     2 1 795 my ( $self, $user_agent ) = @_;
196 2 50       5 if ($user_agent) {
197 0         0 $self->{UserAgent} = $user_agent;
198 0         0 return $self->{UserAgent};
199             }
200 2 50       13 return $self->{UserAgent} if $self->{UserAgent};
201              
202 0 0       0 if ( -S $self->authority() ) {
203 0         0 LWP::Protocol::implementor( http => 'LWP::Protocol::http::SocketUnixAlt' );
204             }
205             $self->{UserAgent} = LWP::UserAgent->new(
206             (
207 0 0       0 $self->{show_progress} ? ( show_progress => 1 ) : (),
    0          
208             $self->ssl_opts ? ( ssl_opts => $self->ssl_opts ) : (),
209             )
210             );
211 0         0 return $self->{UserAgent};
212              
213             }
214              
215             =head2 get
216              
217             =cut
218              
219             sub get {
220 1     1 1 2 my ( $self, $path, $options, $callback ) = @_;
221 1         2 return $self->_hande_response( $self->user_agent->get( $self->uri( $path, %$options ) ) );
222             }
223              
224             =head2 delete
225              
226             =cut
227              
228             sub delete {
229 0     0 1 0 my ( $self, $path, $options, $callback ) = @_;
230 0         0 return $self->_hande_response( $self->user_agent->delete( $self->uri( $path, %$options ) ) );
231             }
232              
233             =head2 request
234              
235             =cut
236              
237             sub request {
238 0     0 1 0 my ( $self, $request, $callback ) = @_;
239 0         0 return $self->_hande_response( $self->user_agent->request( $request, $callback ) );
240             }
241              
242             =head2 post
243              
244             =cut
245              
246             sub post {
247 0     0 1 0 my ( $self, $path, $query, $body, $options, $callback ) = @_;
248 0 0       0 return $self->request( $self->_http_request( $path, $query ), $callback ) unless $body;
249 0 0       0 return $self->request( $self->_handle_json( $path, $query, $body ), $callback )
250             unless ($options);
251 0         0 return $self->request( $self->_handle_custom( $path, $query, $body, $options ), $callback );
252             }
253              
254             =head2 uri
255              
256             Creating a new URI object.
257              
258             Internal varibales:
259            
260             * scheme
261            
262             * authority
263              
264             Given varibales:
265            
266             * path
267            
268             * query options
269              
270             =cut
271              
272             sub uri {
273 1     1 1 3 my ( $self, $path, %opts ) = @_;
274 1         5 require URI;
275             my $uri =
276             URI->new(
277 1         5 $self->scheme() . $self->{_scheme_postfixes}->{ lc $self->scheme() } . $self->authority() . '/' . $path );
278 1         4835 $uri->query_form(%opts);
279 1         65 return $uri;
280             }
281              
282             =head2 to_hashref
283              
284             Getter/Setter for internal hash key ua.
285              
286             =cut
287              
288             sub to_hashref {
289 1     1 1 2 my ( $self, $content ) = @_;
290 1 50       4 return if !$content;
291 1         14 my $data = eval { $self->json->decode($content) };
  1         4  
292 1 50       8 return $@ ? $content : $data;
293 0         0 require Carp;
294 0         0 Carp::cluck;
295 0         0 Carp::croak "JSON ERROR: $@";
296             }
297              
298             {
299              
300             =head2 post
301              
302             =cut
303              
304             sub _handle_json {
305 0     0   0 my ( $self, $path, $query, $body ) = @_;
306 0         0 my $req = $self->_http_request( $path, $query );
307 0         0 $req->content_type('application/json');
308 0         0 my $json = $self->json->encode($body);
309 0         0 $json =~ s/"(false|true)"/$1/g;
310 0         0 $req->content($json);
311 0         0 return $req;
312             }
313              
314             =head2 post
315              
316             =cut
317              
318             sub _handle_custom {
319 0     0   0 my ( $self, $path, $query, $body, $options ) = @_;
320 0         0 my $req = $self->_http_request( $path, $query );
321 0         0 $req->content_type( $options->{content_type} );
322             $req->content_length(
323 3     3   1613 do { use bytes; length $body }
  3         24  
  3         12  
  0         0  
  0         0  
324             );
325 0         0 $req->content($body);
326 0         0 return $req;
327             }
328              
329             =head2 _http_request
330              
331             create HTTP::Request by uri params
332              
333             =cut
334              
335             sub _http_request {
336 0     0   0 my ( $self, $path, $query ) = @_;
337 0         0 require HTTP::Request;
338 0         0 return HTTP::Request->new( POST => $self->uri( $path, %$query ) );
339             }
340              
341             =head2 _hande_response
342              
343             =cut
344              
345             sub _hande_response {
346 1     1   20499 my ( $self, $response ) = @_;
347 1         4 $self->_error_code( $response->code, $response->message, $response->content );
348 1         3 my $content = $response->content();
349 1         26 return $self->to_hashref($content);
350             }
351              
352             =head2 _error_code
353              
354             Simple error handler returns undef if everything is ok dies on error.
355              
356             =cut
357              
358             sub _error_code {
359 1     1   27 my ( $self, $code, $message, $content ) = @_;
360 1 50       7 return $code if $self->{_valid_codes}->{$code};
361 0           require Carp;
362 0           Carp::cluck;
363 0           Carp::croak "FAILURE: $code - " . qq~$message\n$content~;
364             }
365             }
366              
367             1; # End of App::Docker::Client
368              
369             __END__