File Coverage

blib/lib/Net/STF/Client.pm

Criterion	Covered	Total	%
statement	52	127	40.9
branch	4	40	10.0
condition	3	17	17.6
subroutine	15	19	78.9
pod	5	7	71.4
total	79	210	37.6

package Net::STF::Client;
use strict;
use Net::STF::Bucket;
use Net::STF::Object;
use Carp ();
use Furl::HTTP;
use HTTP::Status ();
use MIME::Base64 ();
use Scalar::Util ();
use URI ();
use Class::Accessor::Lite
    rw => [ qw(
        furl
        agent_name
        repl_count
        url
        error
        username
        password
    ) ]
;

our $VERSION = '1.01';

sub new {
    my $class = shift;

    # Grr, allow hashrefs
    if (@_ == 1 && ref $_[0] eq 'HASH') {
        @_ = %{$_[0]};
    }

    # Only exists to provide back compat with non-published version.
    # You shouldn't be using this
    if ( @_ == 2 && ! ref $_[0] && ref $_[1] eq 'HASH' ) {
        # Net::STF style
        @_ = ( url => $_[0], %{$_[1]} );
    }

    my $self = bless {
        agent_name => join( '/', $class, $VERSION ),
        repl_count => 3,
        @_
    }, $class;

    if (! $self->furl ) {
        $self->furl(Furl::HTTP->new( agent => $self->agent_name ));
    }

    return $self;
}

sub _url_is_object {
    # Make sure the URL contains more than one level in its path.
    # Otherwise, you may end up getting stuff like
    #   DELETE http://stf.example.com/foo/
    # instead of
    #   DELETE http://stf.example.com/foo/bar
    # The former deletes the BUCKET, whereas the latter deletes the object.

    # XXX regex copied from URI.pm

    my (undef, undef, $path) =
        $_[0] =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
    if ($path =~ m{^/+[^/]+(?:/+[\./]*)?$}) {
        Carp::croak("Invalid object URL given -> $_[0]");
    }
    1;
}

sub _qualify_url {
    my ($self, $url) = @_;

    my $prefix = $self->url;
    if (! $prefix) {
        return $url;
    }

    return URI->new($url)->abs($prefix)->canonical;
}

sub get_object {
    my ($self, $url, $opts) = @_;

    $self->error(undef);

    $url = $self->_qualify_url($url);

    my %furlopts = (
        method => 'GET',
        url => $url,
    );
    my @res = $self->send_request( \%furlopts, $opts );
    if ( ! HTTP::Status::is_success( $res[1] ) ) {
        $self->error( $res[2] );
        return;
    }
    return Net::STF::Object->new(
        url => $url,
        content => $res[4]
    );
}

sub send_request {
    my ($self, $furlopts, $opts) = @_;

    $furlopts->{headers} ||= [];

    my ($username, $password) = ( $self->username, $self->password );
    if (defined $username && defined $password ) {
        push @{ $furlopts->{headers} },
            ( 'Authorization' => "Basic " . MIME::Base64::encode("$username:$password", "") );
    }

    if ( $opts->{headers} ) {
        push @{$furlopts->{headers}}, @{$opts->{headers}};
    }
    foreach my $key ( qw(write_file write_code) ) {
        if (my $value = $opts->{$key}) {
            $furlopts->{$key} = $value;
        }
    }
    return $self->furl->request( %$furlopts );
}

sub put_object {
    my ($self, $url, $content, $opts) = @_;

    $self->error(undef);

    $url = $self->_qualify_url($url);
    _url_is_object($url);

    if (! defined $content ) {
        Carp::croak( "No content provided" );
    }

    if ( ref $content eq 'SCALAR' ) {
        # raw string passed
        $content = $$content;
    } elsif ( Scalar::Util::openhandle( $content ) ) {
        # make sure we're at the beginning of the file
        seek $content, 0, 0;
    } else {
        # assume it's a file.
        open my $fh, '<', $content
            or die "Failed to open file $content: $!";
        $content = $fh;
        seek $content, 0, 0;
    }

    my @hdrs;
    push @hdrs,
        ("X-STF-Replication-Count", ($opts->{repl_count} || $self->repl_count));
    if (my $consistency = $opts->{consistency}) {
        push @hdrs, "X-STF-Consistency", $consistency;
    }


    my %furlopts = (
        method  => 'PUT',
        url     => $url,
        headers => \@hdrs,
        content => $content,
    );
    my @res = $self->send_request( \%furlopts, $opts );
    if (! HTTP::Status::is_success($res[1])) {
        $self->error( $res[2] );
        return;
    }

    # if you don't want a result, then we don't create an object
    return if !defined wantarray;

    return Net::STF::Object->new(
        url     => $url,
#        content => $res[4]
    );
}

sub delete_object {
    my ($self, $url, $opts) = @_;

    $self->error(undef);

    $url = $self->_qualify_url($url);
    _url_is_object($url);

    my %furlopts = (
        method => 'DELETE',
        url    => $url,
    );
    my @res = $self->send_request( \%furlopts, $opts );
    if ( ! HTTP::Status::is_success( $res[1] ) ) {
        $self->error( $res[2] );
        return;
    }
    return 1;
}

sub create_bucket {
    my ($self, $url, $opts) = @_;

    $self->error(undef);

    $url = $self->_qualify_url($url);

    my %furlopts = (
        method => 'PUT',
        url    => $url,
        headers => [
            'Content-Length' => 0,
        ],
    );
    my @res = $self->send_request( \%furlopts, $opts );
    if (! HTTP::Status::is_success( $res[1] ) ) {
        $self->error( $res[2] );
        return;
    }

    return Net::STF::Bucket->new(
        client => $self,
        name   => ( URI->new($url)->path =~ m{^/([^/]+)} )[0],
    );
}

sub delete_bucket {
    my ($self, $url, $opts) = @_;

    $self->error(undef);

    my @hdrs;
    if ( $opts->{recursive} ) {
        push @hdrs, "X-STF-Recursive-Delete" => "true";
    }

    $url = $self->_qualify_url($url);

    my %furlopts = (
        method  => 'DELETE',
        headers => \@hdrs,
        url     => $url,
    );

    my @res = $self->send_request( \%furlopts, $opts );
    if (! HTTP::Status::is_success( $res[1] ) ) {
        $self->error( $res[2] );
        return;
    }

    return 1;
}

1;

__END__