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

package App::Docker::Client;

=head1 NAME

App::Docker::Client - Simple and plain Docker client!

=head1 VERSION

Version 0.010300

=cut

our $VERSION = '0.010300';

use 5.16.0;
use strict;
use warnings;
use AnyEvent;
use AnyEvent::Socket 'tcp_connect';
use AnyEvent::HTTP;
use LWP::UserAgent;
use JSON;
use LWP::Protocol::http::SocketUnixAlt;

=head2 new

Constructor

=cut

sub new {
    my $class = shift;
    my $self  = {@_};
    $self->{_scheme_postfixes} = { file => ':', http => '://', https => '://', };
    $self->{_valid_codes}      = { 200  => 1,   201  => 1,     204   => 1 };
    bless $self, $class;
    return $self;
}

=head1 SUBROUTINES/METHODS

=head2 with_valid_code

=cut

sub with_valid_code {
    my ( $self, $code ) = @_;
    return if $code !~ m/^(\d{3})$/;
    $self->{_valid_codes}->{$code} = 1;
    return $self;
}

=head2 without_valid_code

=cut

sub without_valid_code {
    my ( $self, $code ) = @_;
    return if $code !~ m/^(\d{3})$/;
    $self->{_valid_codes}->{$code} = 0;
    return $self;
}

=head2 show_progress

=cut

sub show_progress {
    my ( $self, $show_progress ) = @_;
    $self->{show_progress} = $show_progress ? $show_progress == 0 ? () : 1 : 1;
    return $self;
}

=head2 attach

=cut

sub attach {
    my ( $self, $path, $query, $input, $output ) = @_;
    my $cv       = AnyEvent->condvar;
    my $callback = sub {
        my ( $fh, $headers ) = @_;

        $fh->on_error( sub { $cv->send } );
        $fh->on_eof( sub   { $cv->send } );

        my $out_hndl = AnyEvent::Handle->new( fh => $output );
        $fh->on_read(
            sub {
                my ($handle) = @_;
                $handle->unshift_read(
                    sub {
                        my ($h) = @_;
                        my $length = length $h->{rbuf};
                        $out_hndl->push_write( $h->{rbuf} );
                        substr $h->{rbuf}, 0, $length, '';
                    }
                );
            }
        );

        my $in_hndl = AnyEvent::Handle->new( fh => $input );
        $in_hndl->on_read(
            sub {
                my ($h) = @_;
                $h->push_read(
                    line => sub {
                        my ( $h2, $line, $eol ) = @_;
                        $fh->push_write( $line . $eol );
                    }
                );
            }
        );
        $in_hndl->on_eof( sub { $cv->send } );
    };

    http_request(
        POST => $self->uri( $path, %$query )->as_string,
        (
            want_body_handle => 1,
            (
                $self->ssl_opts
                ? (
                    tls_ctx => {
                        verify          => 1,
                        verify_peername => "https",
                        ca_file         => $self->{ssl_opts}->{SSL_ca_file},
                        cert_file       => $self->{ssl_opts}->{SSL_cert_file},
                        key_file        => $self->{ssl_opts}->{SSL_key_file},
                    }
                  )
                : ()
            ),
        ),
        $callback
    );
    return $cv;
}

=head2 authority

Getter/Setter for internal hash key authority.

=cut

sub authority {
    return $_[0]->{authority} || '/var/run/docker.sock' unless $_[1];
    $_[0]->{authority} = $_[1];
    return $_[0]->{authority};
}

=head2 scheme

Getter/Setter for internal hash key scheme.

=cut

sub scheme {
    return $_[0]->{scheme} || 'http' unless $_[1];
    $_[0]->{scheme} = $_[1];
    return $_[0]->{scheme};
}

=head2 ssl_opts

Getter/Setter for internal hash key ssl_opts.

=cut

sub ssl_opts {
    return $_[0]->{ssl_opts} unless $_[1];
    $_[0]->{ssl_opts} = $_[1];
    return $_[0]->{ssl_opts};
}

=head2 json

Getter/Setter for internal hash key json.

=cut

sub json {
    return $_[0]->{json} || JSON->new->utf8() unless $_[1];
    $_[0]->{json} = $_[1];
    return $_[0]->{json};
}

=head2 user_agent

Getter/Setter for internal hash key UserAgent.

=cut

sub user_agent {
    my ( $self, $user_agent ) = @_;
    if ($user_agent) {
        $self->{UserAgent} = $user_agent;
        return $self->{UserAgent};
    }
    return $self->{UserAgent} if $self->{UserAgent};

    if ( -S $self->authority() ) {
        LWP::Protocol::implementor( http => 'LWP::Protocol::http::SocketUnixAlt' );
    }
    $self->{UserAgent} = LWP::UserAgent->new(
        (
            $self->{show_progress} ? ( show_progress => 1 ) : (),
            $self->ssl_opts ? ( ssl_opts => $self->ssl_opts ) : (),
        )
    );
    return $self->{UserAgent};

}

=head2 get

=cut

sub get {
    my ( $self, $path, $options, $callback ) = @_;
    return $self->_hande_response( $self->user_agent->get( $self->uri( $path, %$options ) ) );
}

=head2 delete

=cut

sub delete {
    my ( $self, $path, $options, $callback ) = @_;
    return $self->_hande_response( $self->user_agent->delete( $self->uri( $path, %$options ) ) );
}

=head2 request

=cut

sub request {
    my ( $self, $request, $callback ) = @_;
    return $self->_hande_response( $self->user_agent->request( $request, $callback ) );
}

=head2 post

=cut

sub post {
    my ( $self, $path, $query, $body, $options, $callback ) = @_;
    return $self->request( $self->_http_request( $path, $query ), $callback ) unless $body;
    return $self->request( $self->_handle_json( $path, $query, $body ), $callback )
      unless ($options);
    return $self->request( $self->_handle_custom( $path, $query, $body, $options ), $callback );
}

=head2 uri

Creating a new URI object.

Internal varibales:

 * scheme

 * authority

Given varibales:

 * path

 * query options

=cut

sub uri {
    my ( $self, $path, %opts ) = @_;
    require URI;
    my $uri =
      URI->new(
        $self->scheme() . $self->{_scheme_postfixes}->{ lc $self->scheme() } . $self->authority() . '/' . $path );
    $uri->query_form(%opts);
    return $uri;
}

=head2 to_hashref

Getter/Setter for internal hash key ua.

=cut

sub to_hashref {
    my ( $self, $content ) = @_;
    return if !$content;
    my $data = eval { $self->json->decode($content) };
    return $@ ? $content : $data;
    require Carp;
    Carp::cluck;
    Carp::croak "JSON ERROR: $@";
}

{

=head2 post

=cut

    sub _handle_json {
        my ( $self, $path, $query, $body ) = @_;
        my $req = $self->_http_request( $path, $query );
        $req->content_type('application/json');
        my $json = $self->json->encode($body);
        $json =~ s/"(false|true)"/$1/g;
        $req->content($json);
        return $req;
    }

=head2 post

=cut

    sub _handle_custom {
        my ( $self, $path, $query, $body, $options ) = @_;
        my $req = $self->_http_request( $path, $query );
        $req->content_type( $options->{content_type} );
        $req->content_length(
            do { use bytes; length $body }
        );
        $req->content($body);
        return $req;
    }

=head2 _http_request

create HTTP::Request by uri params

=cut

    sub _http_request {
        my ( $self, $path, $query ) = @_;
        require HTTP::Request;
        return HTTP::Request->new( POST => $self->uri( $path, %$query ) );
    }

=head2 _hande_response

=cut

    sub _hande_response {
        my ( $self, $response ) = @_;
        $self->_error_code( $response->code, $response->message, $response->content );
        my $content = $response->content();
        return $self->to_hashref($content);
    }

=head2 _error_code

Simple error handler returns undef if everything is ok dies on error.

=cut

    sub _error_code {
        my ( $self, $code, $message, $content ) = @_;
        return $code if $self->{_valid_codes}->{$code};
        require Carp;
        Carp::cluck;
        Carp::croak "FAILURE: $code - " . qq~$message\n$content~;
    }
}

1;    # End of App::Docker::Client

__END__