The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Net::Kubernetes::Role::APIAccess;
$Net::Kubernetes::Role::APIAccess::VERSION = '1.07';
# ABSTRACT: Role allowing direct access to the REST api

use Moose::Role;
require LWP::UserAgent;
require HTTP::Request;
use JSON::MaybeXS;
require Cpanel::JSON::XS;
require URI;
use MIME::Base64;
use syntax "try";

has url => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
    default  => 'http://localhost:8080',
);

has api_version => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
);

has server_version => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
    lazy     => 1,
    builder  => '_build_server_version',
);

has base_path => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
    lazy     => 1,
    builder  => '_create_default_base_path'
);

has password => (
    is       => 'ro',
    isa      => 'Str',
    required => 0,
);

has username => (
    is       => 'ro',
    isa      => 'Str',
    required => 0,
);

has ua => (
    is       => 'ro',
    isa      => 'LWP::UserAgent',
    required => 1,
    builder  => '_build_lwp_agent',
    lazy     => 1,
);

has token => (
    is       => 'ro',
    isa      => 'Str',
    required => 0
);

has 'json' => (
    is       => 'ro',
    isa      => JSON::MaybeXS::JSON,
    required => 1,
    lazy     => 1,
    builder  => '_build_json',
);

has 'ssl_cert_file' => (
    is       => 'rw',
    isa      => 'Str',
    required => 0,
);

has 'ssl_key_file' => (
    is       => 'rw',
    isa      => 'Str',
    required => 0,
);

has 'ssl_ca_file' => (
    is       => 'rw',
    isa      => 'Str',
    required => 0,
);

has 'ssl_verify' => (
    is       => 'rw',
    isa      => 'Str',
    default  => 1,
    required => 0,
);

has 'scale_timeout' => (
    is       => 'rw',
    isa      => 'Num',
    required => 0,
    default  => 5,
);

around BUILDARGS => sub {
    my $orig    = shift;
    my $class   = shift;
    my (%input) = @_;
    if (ref($input{token})) {
        if ($input{token}->can('getlines')) {
            $input{token} = join('', $input{token}->getlines);
        }
        elsif (ref($input{token}) eq 'GLOB') {
            my $fh = $input{token};
            $input{token} = do { local $/; <$fh> };
        }
    }
    elsif (exists $input{token} && -f $input{token}) {
        open(my $fh, '<', $input{token});
        $input{token} = do { local $/; <$fh> };
        close($fh);
    }
    if (!exists $input{api_version}) {
        if (exists $input{base_path}) {
            if ($input{base_path} =~ m{/api/(v[^/]+)}) {
                $input{api_version} = $1;
            }
        }
        else {
            $input{api_version} = 'v1';
        }
    }
    return $class->$orig(%input);
};

sub _create_default_base_path {
    my ($self) = @_;

    return '/api/' . $self->api_version;
}

sub path {
    my ($self) = @_;
    return $self->url . $self->base_path;
}

sub _build_server_version {
    my $self = shift;

    my ($version_info) = $self->send_request($self->create_request(GET => $self->url . '/version'));
    return "$version_info->{major}.$version_info->{minor}";

}

sub _build_lwp_agent {
    my $self = shift;

    my $ua;
    my %ua_args = (
        agent    => 'net-kubernetes-perl/1.06',
        ssl_opts => {
             verify_hostname => $self->ssl_verify,
        }
    );

    if ($self->ssl_cert_file) {
        for my $key (qw(SSL_cert_file SSL_key_file SSL_ca_file)) {
            my $method_name = lc($key);
            $ua_args{$key} = $self->$method_name;
        }
    }

    $ua = LWP::UserAgent->new(%ua_args);
    return $ua;
}

sub send_request {
    my ($self, $req) = @_;
    my ($res) = $self->ua->request($req);

    unless ($res->is_success) {
        my $message;
        try {
            my $obj = $self->json->decode($res->content);
            $message = $obj->{message};
        }
        catch($e) {
            $message = $res->message;
            } Net::Kubernetes::Exception->throw(
            code    => $res->code,
            message => $message
            );
    }

    return $self->json->decode($res->content);
}

sub _build_json {
    return JSON::MaybeXS->new->allow_blessed(1)->convert_blessed(1);
}

sub create_request {
    my ($self, @options) = @_;
    my $req = HTTP::Request->new(@options);
    if ($self->username && $self->password) {
        $req->header(Authorization => "Basic " . encode_base64($self->username . ':' . $self->password));
    }
    elsif ($self->token) {
        $req->header(Authorization => "Bearer " . $self->token);
    }
    return $req;
}

sub build_selector_from_hash {
    my ($self, $select_hash) = @_;
    my (@selectors);

    my %labels;
    my @expressions;
    if (ref($select_hash->{matchLabels}) || ref($select_hash->{matchExpressions})) {
        if ($select_hash->{matchLabels}) {
            %labels = %{$select_hash->{matchLabels}};
        }

        if ($select_hash->{matchExpressions}) {
            @expressions = @{$select_hash->{matchExpressions}};
        }
    }
    else {
        %labels = %$select_hash;
    }

    foreach my $label (keys %labels) {
        push @selectors, $label . '=' . $labels{$label};
    }
    foreach my $expression (@expressions) {
        my $operator = lc($expression->{operator});
        my $selector;
        if ($operator eq 'exists') {
            $selector = $expression->{key};
        }
        elsif ($operator eq 'doesnotexist') {
            $selector = "!$expression->{key}";
        }
        else {
            $selector = "$expression->{key} $operator (" . join(',', @{$expression->{values}}) . ")";
        }

        push @selectors, $selector;
    }

    return join(",", @selectors);
}

return 42;

__END__

=pod

=encoding UTF-8

=head1 NAME

Net::Kubernetes::Role::APIAccess - Role allowing direct access to the REST api

=head1 VERSION

version 1.07

=head1 AUTHOR

Dave Mueller <dave@perljedi.com>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2015 by Liquid Web Inc.

This is free software, licensed under:

  The MIT (X11) License

=head1 SEE ALSO

Please see those modules/websites for more information related to this module.

=over 4

=item *

L<Net::Kubernetes|Net::Kubernetes>

=back

=cut