File Coverage

blib/lib/STF/Dispatcher/PSGI.pm

Criterion	Covered	Total	%
statement	151	166	90.9
branch	62	84	73.8
condition	9	16	56.2
subroutine	20	20	100.0
pod	6	10	60.0
total	248	296	83.7

package STF::Dispatcher::PSGI;
use strict;
our $VERSION = '1.12';
use Carp ();
use HTTP::Date ();
use Plack::Request;
use Plack::Middleware::HTTPExceptions;
use Scalar::Util ();
use STF::Dispatcher::PSGI::HTTPException;
use Class::Accessor::Lite
    rw => [ qw(impl nosniff_header) ]
;
use constant +{
    STF_REPLICATION_HEADER            => 'X-STF-Replication-Count',
    STF_REPLICATION_HEADER_DEPRECATED => 'X-Replication-Count',
    STF_RECURSIVE_DELETE_HEADER       => 'X-STF-Recursive-Delete',
    STF_CONSISTENCY_HEADER            => "X-STF-Consistency",
    # XXX This below is should be deprecated. don't use
    STF_FORCE_MASTER_HEADER           => "X-STF-Force-MasterDB",
    STF_DELETED_OBJECTS_HEADER        => "X-STF-Deleted-Objects",
    STF_MOVE_OBJECT_HEADER            => "X-STF-Move-Destination",
    STF_DEFAULT_REPLICATION_COUNT     => 2,
};

sub new {
    my ($class, %args) = @_;

    my $impl = $args{impl} or
        Carp::croak( "Required parameter 'impl' not specified" );
    foreach my $method (qw(create_bucket get_bucket delete_bucket create_object get_object delete_object delete_bucket modify_object rename_object is_valid_object)) {
        $impl->can( $method ) or
            Carp::croak("$impl does not implement $method");
    }

    bless { nosniff_header => 1, %args }, $class;
}

sub to_app {
    my $self = shift;
    my $app = sub { $self->handle_psgi(@_) };
    $app = Plack::Middleware::HTTPExceptions->wrap( $app );
    if ($self->nosniff_header) {
        require Plack::Middleware::Header;
        $app = Plack::Middleware::Header->wrap( $app,
            set => [ 'X-Content-Type-Options' => 'nosniff' ]
        );
    }
    $app;
}

sub handle_psgi {
    my ($self, $env) = @_;

    my $guard = $self->impl->start_request( $env );

    my $req = Plack::Request->new($env);
    my $res;
    my $method = $env->{REQUEST_METHOD};
    if ($method =~ /^(?:GET|HEAD)$/) {
        $res = $self->get_object( $req );
    } elsif ($method eq 'PUT') {
        my $cl = $env->{CONTENT_LENGTH} || 0;
        if ( $cl == 0 ) {
            $res = $self->create_bucket( $req );
        } else {
            $res = $self->create_object( $req );
        }
    } elsif ($method eq 'DELETE') {
        $res = $self->delete_object( $req );
    } elsif ($method eq 'POST') {
        $res = $self->modify_object( $req );
    } elsif ($method eq 'MOVE') {
        $res = $self->rename_object( $req );
    } else {
        $res = $req->new_response(400, [ "Content-Type" => "text/plain" ], [ "Bad Request" ]);
    }

    return $res->finalize();
}

sub parse_names {
    my ($self, $path) = @_;
    if ( $path !~ m{^/([^/]+)(?:/(.+)$)?} ) {
        return ();
    }
    return ($1, $2);
}

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

    my ($bucket_name, $object_name) = $self->parse_names( $req->path );
    if ( $object_name ) {
        return $req->new_response( 400, [], [ "Bad bucket name $bucket_name/$object_name" ] );
    }

    my $bucket = $self->impl->get_bucket( {
        bucket_name => $bucket_name,
        request     => $req,
    } );
    if ($bucket) {
        return $req->new_response( 204, [], [] );
    }

    $bucket = $self->impl->create_bucket( {
        bucket_name => $bucket_name,
        request     => $req,
    } );
    if (! $bucket) {
        return $req->new_response( 500, [], [ "Failed to create bucket" ] );
    }

    return $req->new_response( 201, [], [ "Created bucket" ] );
}

sub create_object {
    my ($self, $req) = @_;

    # find the appropriate bucket
    my ($bucket_name, $object_name) = $self->parse_names( $req->path );
    my $bucket = $self->impl->get_bucket( {
        bucket_name => $bucket_name,
        request     => $req
    } );

    if (! $bucket) {
        # XXX Should be 403?
        return $req->new_response(500, ["Content-Type" => "text/plain"], [ "Failed to find bucket" ] );
    }
    if (! $object_name) {
        return $req->new_response(400, [], ["Could not extract object name"]);
    }

    # try to find a suffix
    my ($suffix) = ( $req->path =~ /\.([a-zA-Z0-9]+)$/ );
    $suffix ||= 'dat';

    my $input = $req->input;
    my $code;
    if ( $code = $input->can('rewind') ) {
        $code->( $input );
    } elsif ( $code = $input->can('seek') ) {
        $code->( $input, 0, 0 );
    }

    my %ext_args;
    if ($req->content_type) {
        $ext_args{content_type} = $req->content_type;
    }

    my $object = $self->impl->create_object( {
        bucket      => $bucket,
        consistency => $req->header( STF_CONSISTENCY_HEADER ) || 0,
        object_name => $object_name,
        size        => $req->content_length || 0,
        suffix      => $suffix,
        input       => $input,
        replicas    => $req->header( STF_REPLICATION_HEADER ) ||
                       $req->header( STF_REPLICATION_HEADER_DEPRECATED ) ||
                       STF_DEFAULT_REPLICATION_COUNT || 0,
        request     => $req,
        %ext_args
    } );
    if (! $object) {
        return $req->new_response( 500, [], [ "Failed to create object" ] );
    }
    return $req->new_response( 201, [], [ "Created " . $req->path ] );
}

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

    # find the appropriate bucket
    my ($bucket_name, $object_name) = $self->parse_names( $req->path );
    my $bucket = $self->impl->get_bucket( {
        bucket_name => $bucket_name,
        request     => $req
    } );
    if (! $bucket) {
        if ( ! $object_name ) {
            return $req->new_response(404, ["Content-Type" => "text/plain"], [ "No such bucket" ] );
        } else {
            return $req->new_response(500, ["Content-Type" => "text/plain"], [ "Failed to find bucket" ] );
        }
    }

    # if there's no object_name, then this is a request to delete
    # the bucket, not an object
    if ( ! $object_name ) {
        my $ret = $self->impl->delete_bucket( {
            bucket    => $bucket,
            recursive => $req->header( STF_RECURSIVE_DELETE_HEADER ) || 0,
            request   => $req,
        } );
        if (! $ret) {
            return $req->new_response(500, ["Content-Type" => "text/plain"], ["Failed to delete bucket" ]);
        }

        return $req->new_response( 204, [], [] );
    }

    my $is_valid = $self->impl->is_valid_object( {
        bucket      => $bucket,
        object_name => $object_name,
        request     => $req,
    });
    if (! $is_valid) {
        return $req->new_response(404, [], [ "No such object" ]);
    }

    if ($self->impl->delete_object( {
        bucket      => $bucket,
        object_name => $object_name,
        request     => $req,
    } )) {
        return $req->new_response( 204, [], [] );
    } else {
        return $req->new_response( 500, [ "Content-Type" => "text/plain" ], [ "Failed to delete object" ] );
    }
}

sub get_object {
    my ($self, $req) = @_;
    # find the appropriate bucket
    my ($bucket_name, $object_name) = $self->parse_names( $req->path );
    my $bucket = $self->impl->get_bucket( {
        bucket_name => $bucket_name,
        request     => $req
    } );
    if (! $bucket) {
        return $req->new_response(404, ["Content-Type" => "text/plain"], [ "Failed to find bucket" ] );
    }

    my $object = $self->impl->get_object( {
        bucket       => $bucket,
        object_name  => $object_name,
        request      => $req,
        force_master => $req->header( STF_FORCE_MASTER_HEADER ) || 0,
    } );
    if (! $object) {
        return $req->new_response( 404, [], [ "Failed to get object" ] );
    }

    my @headers;
    if ( my $ct = $object->can('content_type') ) {
        push @headers, "Content-Type", $object->content_type;
    }
    if ( my $lm = $object->can('modified_on') ) {
        push @headers, "Last-Modified", HTTP::Date::time2str($object->modified_on);
    }

    return $req->new_response( 200,
        \@headers,
        [ $req->method eq 'HEAD' ? '' : $object->content ]
    );
}

sub modify_object {
    my ($self, $req) = @_;

    my ($bucket_name, $object_name) = $self->parse_names( $req->path );
    my $bucket = $self->impl->get_bucket( {
        bucket_name => $bucket_name,
        request     => $req
    } );
    if (! $bucket) {
        return $req->new_response(500, ["Content-Type" => "text/plain"], [ "Failed to find bucket" ] );
    }

    my $is_valid = $self->impl->is_valid_object( {
        bucket      => $bucket,
        object_name => $object_name,
        request     => $req,
    });
    if (! $is_valid) {
        return $req->new_response(404, [], [ "No such object" ]);
    }

    my $ret = $self->impl->modify_object( {
        bucket      => $bucket,
        object_name => $object_name,
        replicas    => $req->header( STF_REPLICATION_HEADER ) ||
                       $req->header( STF_REPLICATION_HEADER_DEPRECATED ) ||
                       STF_DEFAULT_REPLICATION_COUNT || 0,
        request     => $req,
    } );

    if ($ret) {
        return $req->new_response(204, [], []);
    } else {
        return $req->new_response(500, ["Content-Type" => "text/plain"], [ "Failed to modify object" ]);
    }
}

sub rename_object {
    my ($self, $req) = @_;

    # source
    my ($bucket_name, $object_name) = $self->parse_names( $req->path );
    my $bucket = $self->impl->get_bucket( {
        bucket_name => $bucket_name,
        request     => $req
    } );
    if (! $bucket) {
       # XXX should be 403?
        return $req->new_response(500, ["Content-Type" => "text/plain"], [ "Failed to find source bucket" ] );
    }

    if (! $object_name) {
        my ($dest_bucket, $dest_object) = $self->parse_names( $req->header( STF_MOVE_OBJECT_HEADER ) );
        if (! $dest_bucket) {
            return $req->new_response(500, ["Content-Type" => "text/plain"], ["Destination bucket name was not specified"]);
        }
        if ($dest_object) {
            return $req->new_response(500, ["Content-Type" => "text/plain"], ["Destination contains object name"]);
        }

        my $ok = $self->impl->rename_bucket({
            bucket => $bucket,
            name   => $dest_bucket
        });
        if ($ok) {
            return $req->new_response(201, [], ["Moved"]);
        } else {
            return $req->new_response(500, [], ["Failed to rename bucket"]);
        }
    }

    my $is_valid = $self->impl->is_valid_object( {
        bucket      => $bucket,
        object_name => $object_name,
        request     => $req,
    });
    if (! $is_valid) {
        return $req->new_response(404, [], [ "No such source object" ]);
    }


    my $destination = $req->header( STF_MOVE_OBJECT_HEADER );
    my ($dest_bucket_name, $dest_object_name) = $self->parse_names( $destination );
    my $dest_bucket;
    if ( $dest_bucket_name eq $bucket_name ) {
        $dest_bucket = $bucket
    } else {
        $dest_bucket = $self->impl->get_bucket( {
            bucket_name => $dest_bucket_name,
            request     => $req
        } );
        if (! $dest_bucket) {
           # XXX should be 403?
            return $req->new_response(500, ["Content-Type" => "text/plain"], [ "Failed to find source bucket" ] );
        }
    }

    my $rv = $self->impl->rename_object( {
        source_bucket           => $bucket,
        source_object_name      => $object_name,
        destination_bucket      => $dest_bucket,
        destination_object_name => $dest_object_name,
    } );

    if (! $rv) {
        return $req->new_response( 500, [], [ "Failed to create object" ] );
    }
    return $req->new_response( 201, [], [ "Created " . $req->path ] );
}

1;

__END__