File Coverage

lib/Consul/Simple.pm

Criterion	Covered	Total	%
statement	123	125	98.4
branch	22	32	68.7
condition	11	17	64.7
subroutine	16	17	94.1
pod	4	4	100.0
total	176	195	90.2

package Consul::Simple;
$Consul::Simple::VERSION = '1.142390';
use strict;use warnings;
use LWP::UserAgent;
use HTTP::Response;
use HTTP::Request::Common;
use MIME::Base64;
use JSON;
use Data::Dumper;

sub new {
    my $class = shift;
    my $self = {};
    bless ($self,$class);
    my %args;
    {   my @args = @_;
        die 'Consul::Simple::new: even number of arguments required'
            if scalar @args % 2;
        %args = @args;
    }
    $self->{consul_server} = $args{consul_server} || 'localhost';
    $self->{kvPrefix} = $args{kvPrefix} || '/';
    $self->{kvPrefix} =~ s/\/\//\//g;
    $self->{kvPrefix} =~ s/\/\//\//g;
    $self->{kvPrefix} =~ s/\/\//\//g;
    if($self->{kvPrefix} !~ /^\//) {
        $self->{kvPrefix} = '/' . $self->{kvPrefix};
    }
    if($self->{kvPrefix} !~ /\/$/) {
        $self->{kvPrefix} = $self->{kvPrefix} . '/';
    }
    {   my %ua_args = ();
        $ua_args{ssl_opts} = $args{ssl_opts} if $args{ssl_opts};
        $self->{ua} = LWP::UserAgent->new(%ua_args);
    }

    $self->{proto} = $args{proto} || 'http';
    $self->{consul_port} = $args{port} || 8500;
    $self->{constructor_args} = \%args;
    $self->{warning_handler} = $args{warning_handler} || sub {
        my $warnstr = shift;
        my %args = @_;
        print STDERR "[WARN]: $warnstr\n";
    };
    return $self;
}

sub _warn {
    my $self = shift;
    $self->{warning_handler}->(@_);
}

sub _do_request {
    my $self = shift;
    my $req = shift;
    my %req_args = @_;
    my $ret;
    my $tries = $self->{constructor_args}->{retries} || 5;
    my $timeout = $self->{constructor_args}->{timeout} || 2;
    while($tries--) {
        eval {
            local $SIG{ALRM} = sub { die "timed out\n"; };
            alarm $timeout;
            $ret = $self->{ua}->request($req, %req_args);
        };
        alarm 0;
        last if $ret and $ret->is_success;
        my $err;
        if($@) {
            $err = $@;
        } else {
            $err = 'http request failed with ' . $ret->status_line;
        }
        $self->_warn("request failed: $err", response => $ret);
        sleep 1;
    }
    return $ret;
}

sub KVGet {
    my $self = shift;
    my $key = shift or die 'Consul::Simple::KVGet: key required as first argument';
    my %args;
    {   my @args = @_;
        die 'Consul::Simple::KVGet: even number of arguments required'
            if scalar @args % 2;
        %args = @args;
    }
    my @entries = ();
    eval {
        my $url = $self->_mk_kv_url($key);
        $url .= '?recurse' if $args{recurse};
        my $res = $self->_do_request(GET $url);
        my $content = $res->content;
        my $values = JSON::decode_json($content);
        @entries = @$values;
    };
    my @ret = ();
    foreach my $entry (@entries) {
        #The returned entry Value is always base64 encoded
        $entry->{Value} = MIME::Base64::decode_base64($entry->{Value});

        #the idea below is to try to JSON decode it.  If that works,
        #return the JSON decoded value.  Otherwise, return it un-decoded
        my $value;
        eval {
            $value = JSON::decode_json($entry->{Value});
        };
        $value = $entry->{Value} unless $value;
        $entry->{Value} = $value;
        push @ret, $entry;
    }

    return @ret;
}


sub KVPut {
    my $self = shift;
    my $key = shift or die 'Consul::Simple::KVPut: key required as first argument';
    my $value = shift or die 'Consul::Simple::KVPut: value required as second argument';
    if(ref $value) {
        $value = JSON::encode_json($value);
    }
    my %args;
    {   my @args = @_;
        die 'Consul::Simple::KVPut: even number of arguments required'
            if scalar @args % 2;
        %args = @args;
    }
    my $res = $self->_do_request(PUT $self->_mk_kv_url($key), Content => $value);
    return $res;
}

sub _mk_kv_url {
    my $self = shift;
    my $key = shift;
    return $self->{proto} . '://' . $self->{consul_server} . ':' . $self->{consul_port} . '/v1/kv' . $self->{kvPrefix} . $key;
}

sub KVDelete {
    my $self = shift;
    my $key = shift or die 'Consul::Simple::KVDelete: key required as first argument';
    my %args;
    {   my @args = @_;
        die 'Consul::Simple::KVPut: even number of arguments required'
            if scalar @args % 2;
        %args = @args;
    }
    my $res = $self->_do_request(
        HTTP::Request::Common::_simple_req(
            'DELETE',
            $self->_mk_kv_url($key)
        )
    );
    return $res;
}
1;

__END__