Blobs.pm

#!perl

use strict;
use warnings;

package BlobMachine::Resource::Blobs;
use parent 'BlobMachine::Resource';

use HTTP::Headers::ActionPack::DateHeader;
use List::Util ();
use File::Temp ();
use IO::Digest ();
use JSON::XS ();

sub content_types_accepted {
    my ($self) = @_;
    $self->_trace();
    return [ { '*/*' => 'from_binary' } ];
}

sub content_types_provided {
    return [
        { 'text/plain'       => 'to_text' },
        { 'text/csv'         => 'to_csv' },
        { 'application/json' => 'to_json' },
    ];
}

sub allowed_methods {
    return [ qw( GET HEAD POST PUT ) ];
}

sub post_is_create { 1 }
sub create_path_after_handler { 1 }

# Allow resource if PUT method, POST method or request Accept header is text/plain
sub resource_exists {
    my ($self) = @_;
    $self->_trace();
    return 1 if $self->request->method eq 'PUT';
    return 1 if $self->request->method eq 'POST';
    # KLUDGE: Why can't I use $self->request->content_type here? It's always empty
    my $mt = $self->request->env->{'web.machine.context'}->{'Content-Type'};
    $self->_log_debug("Content-Type (WM): " . $mt->type);
    return 1 if $mt->match('text/plain');
    my $blobs = $self->blobs;
    return @$blobs ? 1 : 0;
}

sub last_modified {
    my ($self) = @_;
    $self->_trace();
    my $blobs = $self->blobs;
    my $last_modified = 0;
    foreach my $blob (@$blobs) {
        $last_modified = List::Util::max($last_modified, $blob->[2]); # mtime
    }
    return if $last_modified <= 0;
    return HTTP::Headers::ActionPack::DateHeader->new_from_string(
        scalar localtime($last_modified)
    );
}

sub from_binary {
    my ($self) = @_;
    $self->_trace();
    return 1;
}

sub _process_input {
    my ($self) = @_;
    return if $self->{'_input_processed'};
    my $temp_dir = $self->_temp_dir;
    my $fh = $self->request->body;
    my $temp_fh = File::Temp->new( DIR => $temp_dir, UNLINK => 0 );
    my $digest = IO::Digest->new( $temp_fh, 'SHA1' );
    my $bytes_read = 0;
    while ( $fh->read(my $buffer, 65536) ) {
        $bytes_read += length $buffer;
        print $temp_fh $buffer;
    }
    my $sha1 = $digest->hexdigest;
    $temp_fh->close();
    $self->{'sha1'} = $sha1;
    $self->{'temp_fh'} = $temp_fh;
    $self->{'_input_processed'} = 1;
    return 1;
}

sub is_conflict {
    my ($self) = @_;
    $self->_trace();
    $self->_process_input();
    my $data_dir = $self->_data_dir;
    my $temp_fh = $self->{'temp_fh'};
    my $sha1 = $self->{'sha1'};
    my $data_file = "$data_dir/$sha1";
    if ( -e $data_file ) {
        $self->_log_info("EXISTS: $data_file (removing " . $temp_fh->filename . ")");
        $temp_fh->unlink_on_destroy(1);
        return 1;
    }
    return 0;
}

sub create_path {
    my ($self) = @_;
    $self->_trace();
    $self->_process_input();
    my $data_dir = $self->_data_dir;
    my $temp_fh = $self->{'temp_fh'};
    my $sha1 = $self->{'sha1'};
    my $data_file = "$data_dir/$sha1";
    if ( -e $data_file ) {
        $self->_log_info("EXISTS: $data_file (removing " . $temp_fh->filename . ")");
        $temp_fh->unlink_on_destroy(1);
    }
    else {
        $self->_log_info("ADD: $data_file (from " . $temp_fh->filename . ")");
        rename $temp_fh->filename, $data_file;
    }
    delete $self->{'temp_fh'};
    return $sha1;
}

#sub process_post {
#    my ($self) = @_;
#    return 1;
#}

sub to_text {
    my ($self) = @_;
    $self->_trace();
    return "Use Accept: text/csv or application/json request header to list all blob metadata.\n"
         . "Use PUT (or POST) request method to create new blobs.\n";
}

sub to_csv {
    my ($self) = @_;
    $self->_trace();
    my $blobs = $self->blobs;
    return join("\n",
        map { join ";", @$_ }
        [ "sha1", "size", "mtime" ],
        @$blobs
    ) . "\n";
}

sub to_json {
    my ($self) = @_;
    $self->_trace();
    my $blobs = $self->blobs;
    return JSON::XS->new->pretty->encode([
        map { +{ 'sha1' => $_->[0], 'size' => $_->[1], 'mtime' => $_->[2] } }
        @$blobs
    ]) . "\n";
}

sub blobs {
    my ($self) = @_;
    $self->_trace();
    $self->{'blobs'} = $self->_build_blobs() unless defined $self->{'blobs'};
    return $self->{'blobs'};
}

sub _build_blobs {
    my ($self) = @_;
    $self->_trace();
    my $data_dir = $self->_data_dir;
    my @blobs;
    opendir(my $dh, $data_dir);
    while ( my $sha1 = readdir($dh) ) {
        my $sha1_file = "$data_dir/$sha1";
        my @st = stat($sha1_file);
        next unless -f _;
        push @blobs, [ $sha1, $st[7], $st[9] ]; # size, mtime
    }
    closedir($dh);
    return \@blobs;
}

1;

results.log

$ curl -v http://0:5000/blobs/ -d "test"
* Hostname was NOT found in DNS cache
*   Trying 0.0.0.0...
* Connected to 0 (127.0.0.1) port 5000 (#0)
> POST /blobs/ HTTP/1.1
> User-Agent: curl/7.35.0
> Host: 0:5000
> Accept: */*
> Content-Length: 4
> Content-Type: application/x-www-form-urlencoded
>
* upload completely sent off: 4 out of 4 bytes
* HTTP 1.0, assume close after body
< HTTP/1.0 201 Created **** THIS IS WHAT I WANT ****
< Date: Fri, 17 Jun 2016 07:28:33 GMT
< Server: HTTP::Server::PSGI
< Location: /blobs/a94a8fe5ccb19ba61c4c0873d391e987982fbbd3 **** THIS TOO ****
< Vary: Accept
< Content-Length: 0
< Content-Type: text/plain
< X-Web-Machine-Trace: b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,c3,c4,d4,e5,f6,g7,g8,h10,i12,l13,m16,n16,n11,p11
<
* Closing connection 0

$ curl -v http://0:5000/blobs/ -d "test"
* Hostname was NOT found in DNS cache
*   Trying 0.0.0.0...
* Connected to 0 (127.0.0.1) port 5000 (#0)
> POST /blobs/ HTTP/1.1
> User-Agent: curl/7.35.0
> Host: 0:5000
> Accept: */*
> Content-Length: 4
> Content-Type: application/x-www-form-urlencoded
>
* upload completely sent off: 4 out of 4 bytes
* HTTP 1.0, assume close after body
< HTTP/1.0 201 Created     **** I WAS EXPECTING SOMETHING INDICATING IT ALREADY EXISTS ****
< Date: Fri, 17 Jun 2016 07:28:38 GMT
< Server: HTTP::Server::PSGI
< Location: /blobs/a94a8fe5ccb19ba61c4c0873d391e987982fbbd3 **** THIS IS WHAT I EXPECT ****
< Vary: Accept
< Content-Length: 0
< Content-Type: text/plain
< X-Web-Machine-Trace: b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,c3,c4,d4,e5,f6,g7,g8,h10,i12,l13,m16,n16,n11,p11
<
* Closing connection 0

$ curl -v -X PUT http://0:5000/blobs/ -d "test2"
* Hostname was NOT found in DNS cache
*   Trying 0.0.0.0...
* Connected to 0 (127.0.0.1) port 5000 (#0)
> PUT /blobs/ HTTP/1.1
> User-Agent: curl/7.35.0
> Host: 0:5000
> Accept: */*
> Content-Length: 5
> Content-Type: application/x-www-form-urlencoded
>
* upload completely sent off: 5 out of 5 bytes
* HTTP 1.0, assume close after body
< HTTP/1.0 204 No Content **** I WAS EXPECTING 201 CREATED, SAME AS POST, ALSO MISSING LOCATION HEADER ****
< Date: Fri, 17 Jun 2016 07:28:51 GMT
< Server: HTTP::Server::PSGI
< Vary: Accept
< Content-Type: text/plain
< X-Web-Machine-Trace: b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,c3,c4,d4,e5,f6,g7,g8,h10,i12,l13,m16,n16,o16,o14,p11,o20
<
* Closing connection 0

$ curl -v -X PUT http://0:5000/blobs/ -d "test2"
* Hostname was NOT found in DNS cache
*   Trying 0.0.0.0...
* Connected to 0 (127.0.0.1) port 5000 (#0)
> PUT /blobs/ HTTP/1.1
> User-Agent: curl/7.35.0
> Host: 0:5000
> Accept: */*
> Content-Length: 5
> Content-Type: application/x-www-form-urlencoded
>
* upload completely sent off: 5 out of 5 bytes
* HTTP 1.0, assume close after body
< HTTP/1.0 204 No Content  **** I WAS EXPECTING SOMETHING THAT IT EXISTS AND A LOCATION HEADER ****
< Date: Fri, 17 Jun 2016 07:28:55 GMT
< Server: HTTP::Server::PSGI
< Vary: Accept
< Content-Type: text/plain
< X-Web-Machine-Trace: b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,c3,c4,d4,e5,f6,g7,g8,h10,i12,l13,m16,n16,o16,o14,p11,o20
<
* Closing connection 0