File Coverage

blib/lib/Apache2/UploadProgress.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Apache2::UploadProgress;

use strict;
use warnings;
use bytes;

use Apache2::Const       -compile => qw( OK DECLINED NOT_FOUND M_POST RSRC_CONF TAKE1 );
use Apache2::Filter      qw[];
use Apache2::Module      qw[];
use Apache2::RequestRec  qw[];
use Apache2::RequestIO   qw[];
use Apache2::Response    qw[];
use Apache2::ServerUtil  qw[];
use APR::Const           -compile => qw( SUCCESS );
use APR::Brigade         qw[];
use APR::Bucket          qw[];
use APR::Table           qw[];
use Cache::FastMmap      qw[];
use File::Spec           qw[];
use HTTP::Headers::Util  qw[split_header_words];
use Time::HiRes          qw[sleep];

our $VERSION = 0.2;

our $CACHE = Cache::FastMmap->new(
    share_file => $ENV{UPLOADPROGRESS_SHARE_FILE} || File::Spec->catfile( File::Spec->tmpdir, 'Apache2-UploadProgress' ),
    init_file  => 1,
    raw_values => 1,
    page_size  => $ENV{UPLOADPROGRESS_PAGE_SIZE} || '64k',
    num_pages  => $ENV{UPLOADPROGRESS_NUM_PAGES} || '89',
) or die qq/Failed to create a new instance of Cache::FastMmap. Reason: '$!'/;

our $DIRECTIVES = [
    {
        name         => 'UploadProgressBaseURI',
        req_override => Apache2::Const::RSRC_CONF,
        args_how     => Apache2::Const::TAKE1,
        errmsg       => 'Absolute or relative URI to extras without trailing forward slash',
    }
];

our ( $TEMPLATES, $MIMES, $HAS_BASEURI );

if ( $ENV{MOD_PERL} ) {

    Apache2::Module::add( __PACKAGE__, $DIRECTIVES );

    if (    Apache2::ServerUtil::restart_count() > 1
         && Apache2::Module::loaded('mod_alias.c')
         && Apache2::Module::loaded('mod_mime.c') ) {

        my $config = [
            sprintf( 'Alias /UploadProgress %s/extra', substr( __FILE__, 0, -3 ) ),
            '',
            'SetHandler default-handler',
            Apache2::Module::loaded('mod_expires.c')
              ? ( 'ExpiresActive On', 'ExpiresDefault "access plus 1 day"')
              : (),
            '',
            '',
            'SetHandler modperl',
            'PerlResponseHandler Apache2::UploadProgress->progress',
            ''
        ];

        Apache2::ServerUtil->server->add_config($config);

        $HAS_BASEURI = 1;
    }
}

$TEMPLATES->{html} = <<'EOF';

    PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">


  UploadProgress





  Upload Progress



EOF

$TEMPLATES->{json} = <<'EOF';
{"size":%d,"received":%d}
EOF

$TEMPLATES->{text} = <<'EOF';
size: %d
received: %d
EOF

$TEMPLATES->{yaml} = <<'EOF';
---
size: %d
received: %d
EOF

$TEMPLATES->{xml} = <<'EOF';

%s
    %d
    %d

EOF

$MIMES = {
    'application/x-json'    => sub { sprintf( $TEMPLATES->{json}, @_ ) },
    'application/x-yaml'    => sub { sprintf( $TEMPLATES->{yaml}, @_ ) },
    'application/xhtml+xml' => sub { sprintf( $TEMPLATES->{html}, @_ ) },
    'application/xml'       => \&xml_template,
    'text/html'             => sub { sprintf( $TEMPLATES->{html}, @_ ) },
    'text/plain'            => sub { sprintf( $TEMPLATES->{text}, @_ ) },
    'text/x-json'           => sub { sprintf( $TEMPLATES->{json}, @_ ) },
    'text/x-yaml'           => sub { sprintf( $TEMPLATES->{yaml}, @_ ) },
    'text/xml'              => \&xml_template,
};

sub xml_template {
    my ($size, $received, $r) = @_;
    my $xsl = '';
    my $xsd = '';
    if ( my $uri = Apache2::UploadProgress->base_uri($r) ) {
        $xsl = "\n";
        $xsd = ' xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation="${uri}/progress.xsd"';
    }
    return sprintf( $TEMPLATES->{xml}, $xsl, $xsd, $size, $received);
}


sub register_mime : method {
    my ( $class, $mime, $callback ) = @_;
    $MIMES->{ lc $mime } = $callback;
}

sub UploadProgressBaseURI {
    my ( $self, $parms, $uri ) = @_;
    $self->{UploadProgressBaseURI} = $uri;
}

sub config {
    my ( $class, $r ) = @_;
    return Apache2::Module::get_config( __PACKAGE__, $r->server, $r->per_dir_config );
}

sub base_uri {
    my ( $class, $r ) = @_;

    if ( $r ) {
        my $config = $class->config($r);
        return $config->{UploadProgressBaseURI} if $config->{UploadProgressBaseURI};
    }

    if ( $HAS_BASEURI ) {
        return '/UploadProgress';
    }

    return undef;
}

sub progress_id {
    my ( $class, $r ) = @_;

    return $r->headers_in->get('X-Upload-ID')
        || $r->headers_in->get('X-Progress-ID')                        # lighttpd compat
        || ( $r->unparsed_uri =~ m/\?([a-fA-F0-9]{32})$/ )[0]          # lighttpd compat
        || ( $r->unparsed_uri =~ m/(?:progress|upload)_id=([a-fA-F0-9]{32})/ )[0];
}

sub fetch_progress {
    my ( $class, $progress_id ) = @_;

    my $progress = $CACHE->get($progress_id)
      or return undef;

    return [ unpack( 'LL', $progress ) ];
}

sub store_progress {
    my ( $class, $progress_id, $progress ) = @_;

    return $CACHE->set( $progress_id => pack( 'LL', @$progress ) );
}

sub track_progress {
    my ( $class, $f, $bb, $mode, $block, $readbytes ) = @_;

    unless ( $f->ctx ) {

        my $ctx = [];

        $ctx->[0] = $class->progress_id( $f->r )
          or return Apache2::Const::DECLINED;

        $ctx->[1]->[0] = $f->r->headers_in->get('Content-Length') || 0;
        $ctx->[1]->[1] = 0;

        $f->ctx($ctx);

        $class->store_progress( @{ $f->ctx } );
    }

    my $rv = $f->next->get_brigade( $bb, $mode, $block, $readbytes );

    unless ( $rv == APR::Const::SUCCESS ) {
        return $rv;
    }

    $f->ctx->[1]->[1] += $bb->length;

    $class->store_progress( @{ $f->ctx } );

    return Apache2::Const::OK;
}

sub handler : method {
    my ( $class, $r ) = @_;

    $r->method_number == Apache2::Const::M_POST
      or return Apache2::Const::DECLINED;

    $class->progress_id($r)
      or return Apache2::Const::DECLINED;

    $r->add_input_filter( $class . '->track_progress' );

    return Apache2::Const::OK;
}

sub progress : method {
    my ( $class, $r ) = @_;

    my $progress_id = $class->progress_id($r)
      or return Apache2::Const::NOT_FOUND;

    my $progress = undef;
    my $tries    = 16; # wait a max of 4 seconds for the upload to start

    while ( $tries && !$progress ) {

        $progress = $class->fetch_progress($progress_id)
          or sleep(0.250);

        $tries--;
    }

    unless ( $progress ) {
        return Apache2::Const::NOT_FOUND;
    }

    my $content_type = 'text/xml';

    if ( my $accept_header = $r->headers_in->get('Accept') ) {

        my %accept  = ();
        my $counter = 0;

        foreach my $pair ( split_header_words($accept_header) ) {

            my ( $type, $qvalue ) = @{ $pair }[0,3];

            unless ( defined $qvalue ) {
                $qvalue = 1 - ( ++$counter / 1000 );
            }

            $accept{ $type } = sprintf( '%.3f', $qvalue );
        }

        foreach my $type ( sort { $accept{$b} <=> $accept{$a} } keys %accept ) {

            if ( exists $MIMES->{$type} ) {
                $content_type = $type;
                last;
            }
        }
    }

    $r->headers_out->set( 'Vary'          => 'Accept' );
    $r->headers_out->set( 'Pragma'        => 'no-cache' );
    $r->headers_out->set( 'Expires'       => 'Thu, 01 Jan 1970 00:00:00 GMT' );
    $r->headers_out->set( 'Cache-Control' => 'no-store, no-cache, must-revalidate, post-check=0, pre-check=0' );

    my $callback = $MIMES->{$content_type};
    my $content  = $callback->( @$progress, $r );

    $r->content_type($content_type);
    $r->set_content_length( length $content );
    $r->write($content);

    return Apache2::Const::OK;
}

1;

__END__