The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# ABSTRACT: class for handling file content rendering

package Dancer2::Handler::File;
{
    $Dancer2::Handler::File::VERSION = '0.07';
}
use Carp 'croak';
use Moo;
use HTTP::Date;
use Dancer2::FileUtils 'path', 'open_file', 'read_glob_content';
use Dancer2::Core::MIME;
use Dancer2::Core::Types;
use File::Spec;

with 'Dancer2::Core::Role::Handler';
with 'Dancer2::Core::Role::StandardResponses';
with 'Dancer2::Core::Role::Hookable';

sub supported_hooks {
    qw(
      handler.file.before_render
      handler.file.after_render
    );
}

has mime => (
    is      => 'ro',
    isa     => InstanceOf ['Dancer2::Core::MIME'],
    default => sub { Dancer2::Core::MIME->new },
);

has encoding => (
    is      => 'ro',
    default => sub {'utf-8'},
);

has public_dir => ( is => 'rw', );

has regexp => (
    is      => 'ro',
    default => sub {'/**'},
);

sub BUILD {
    my ($self) = @_;

    if ( !defined $self->public_dir ) {
        my $public =
             $self->app->config->{public}
          || $ENV{DANCER_PUBLIC}
          || path( $self->app->location, 'public' );

        $self->public_dir($public);
    }
}

sub register {
    my ( $self, $app ) = @_;

    # don't register the handler if no valid public dir
    return if !-d $self->public_dir;

    $app->add_route(
        method => $_,
        regexp => $self->regexp,
        code   => $self->code( $app->prefix ),
    ) for $self->methods;
}

sub methods { ( 'head', 'get' ) }

sub code {
    my ( $self, $prefix ) = @_;

    sub {
        my $ctx  = shift;
        my $path = $ctx->request->path_info;

        if ( $path =~ /\0/ ) {
            return $self->response_400($ctx);
        }

        if ( $prefix && $prefix ne '/' ) {
            $path =~ s/^\Q$prefix\E//;
        }

        my @tokens = File::Spec->splitdir(
            join '',
            ( File::Spec->splitpath($path) )[ 1, 2 ]
        );
        if ( grep $_ eq '..', @tokens ) {
            return $self->response_403($ctx);
        }

        my $file_path = path( $self->public_dir, @tokens );
        $self->execute_hook( 'handler.file.before_render', $file_path );

        if ( !-f $file_path ) {
            $ctx->response->has_passed(1);
            return;
        }

        if ( !-r $file_path ) {
            return $self->response_403($ctx);
        }

        # Read file content as bytes
        my $fh = open_file( "<", $file_path );
        binmode $fh;
        my $content = read_glob_content($fh);

        # Assume m/^text/ mime types are correctly encoded
        my $content_type = $self->mime->for_file($file_path) || 'text/plain';
        if ( $content_type =~ m!^text/! ) {
            $content_type .= "; charset=" . ( $self->encoding || "utf-8" );
        }

        my @stat = stat $file_path;

        $ctx->response->header('Content-Type')
          or $ctx->response->header( 'Content-Type', $content_type );

        $ctx->response->header('Content-Length')
          or $ctx->response->header( 'Content-Length', $stat[7] );

        $ctx->response->header('Last-Modified')
          or $ctx->response->header(
            'Last-Modified',
            HTTP::Date::time2str( $stat[9] )
          );

        $ctx->response->content($content);
        $ctx->response->is_encoded(1);    # bytes are already encoded
        $self->execute_hook( 'handler.file.after_render', $ctx->response );
        return ( $ctx->request->method eq 'GET' ) ? $content : '';
    };
}

1;

__END__

=pod

=head1 NAME

Dancer2::Handler::File - class for handling file content rendering

=head1 VERSION

version 0.07

=head1 AUTHOR

Dancer Core Developers

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Alexis Sukrieh.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut