view release on metacpan or  search on metacpan

lib/Catalyst/View/Reproxy.pm  view on Meta::CPAN

package Catalyst::View::Reproxy;

use strict;
use warnings;

use base qw/Catalyst::View/;

use Fcntl;
use File::MimeInfo qw//;
use File::MMagic;
use HTTP::Request;
use HTTP::Response;
use LWP::UserAgent;
use NEXT;

__PACKAGE__->mk_accessors(qw/mmagic/);

=head1 NAME

Catalyst::View::Reproxy - Reproxing View for lighty and perlbal.

=head1 VERSION

Version 0.05

=cut

our $VERSION = '0.05';

=head1 SYNOPSIS

In your view class

	package MyApp::View::MyReproxy;

  use base qw/Catalyst::View::Reproxy/;

  __PACKAGE__->config(
    perlbal => 1
  );

In your controller class

  sub index: Private {
    my ($self, $c) = @_;

    $c->forward('View::MyReproxy', {});
  }

=head1 METHODS

=head2 new($c, $arguments)

Constructor

=over 2

=item config, arguments

=over 2

=item lighttpd

If the frontend web server is lighttpd, the value would be 1. (default 0)

=item perlbal

If the frontend web server is perlbal, the value would be 1. (default 0)

=item mime_magic

lib/Catalyst/View/Reproxy.pm  view on Meta::CPAN

        }
    }
    else {
        unless ( -e $file ) {
            $c->response->status(404);
            $c->log->error("File not found");
            return;
        }

        my $content;
        my $content_length = -s $file;

        sysopen( SENDFILE, $file, O_RDONLY );
        sysread( SENDFILE, $content, -s $file );

        unless ( $c->response->content_type ) {
            if ( $self->mmagic ) {
                $c->response->content_type(
                    $self->mmagic->checktype_contents($content) );
            }
            else {
                $c->response->content_type(
                    File::MimeInfo::mimetype(*SENDFILE) );
            }
        }

        close(SENDFILE);

        $c->response->content_length( -s $file );
        $c->response->body($content);
    }

    $self->process_extra_headers( $c, $arguments );
}

=head2 process_url($c, $url, $arguments)

processing urls.

=cut

sub process_url {
    my ( $self, $c, $url, $arguments ) = @_;

    if ( $self->config->{perlbal} ) {
        $c->response->header( 'X-REPROXY-URL', join( " ", @$url ) );

        my $expected_size = $c->stash->{reproxy_expected_size};

        if ( defined $expected_size ) {
            $c->response->header( 'X-REPROXY_EXPECTED_SIZE', $expected_size );
        }
    }
    else {
        my $rand_url = $url->[ int( rand( scalar @{$url} ) ) ];

        my $ua = LWP::UserAgent->new;
        $ua->timeout( int $self->config->{timeout} )
          if ( $self->config->{timeout} );

        my $req = HTTP::Request->new( GET => $rand_url );
        $req->header( 'Accept' => '*' );
        my $res = $ua->request($req);

        if ( $res->is_success ) {
            my $content = $res->content;

            unless ( $c->response->content_type ) {
                if ( $self->mmagic ) {
                    $c->response->content_type(
                        $self->mmagic->checktype_contents($content) );
                }
                else {
                    $c->response->content_type( $res->header('Content-Type') );
                }
            }

            $c->response->content_length( $res->header('Content-Length') );
            $c->response->body( $res->content );
        }
        else {
            $c->response->status(403);
            $c->log->error("Request $url is not success");
            return;
        }
    }

    $self->process_extra_headers( $c, $arguments );
}

=head2 header_name($header)

Translating http header name.

=cut

sub header_name {
    my ( $self, $header ) = @_;

    my $header_name = $header;
    $header_name =~ s/_/-/g;
    $header_name =
      join( "-" => map { ucfirst lc $_ } split( /-/, $header_name ) );

    return $header_name;
}

=head2 process_extra_headers($c, $arguments)

Setting extra http response headers.

=cut

sub process_extra_headers {
    my ( $self, $c, $arguments ) = @_;

    if ( $arguments->{extra_headers} ) {
        foreach my $header ( keys %{ $arguments->{extra_headers} } ) {
            $c->response->header( $self->header_name($header),
                $arguments->{extra_headers}->{$header} );
        }