File Coverage

blib/lib/Limper/SendFile.pm

Criterion	Covered	Total	%
statement	14	49	28.5
branch	0	22	0.0
condition	0	9	0.0
subroutine	5	9	55.5
pod	0	4	0.0
total	19	93	20.4

package Limper::SendFile;
$Limper::SendFile::VERSION = '0.005';
use base 'Limper';
use 5.10.0;
use strict;
use warnings;

package		# newline because Dist::Zilla::Plugin::PkgVersion and PAUSE indexer
  Limper;

use Time::Local 'timegm';

push @Limper::EXPORT, qw/public send_file/;
push @Limper::EXPORT_OK, qw/mime_types parse_date/;

my %mime_types = map { chomp; split /\t/; } ();

sub mime_types { \%mime_types }

my $public = './public/';

sub public {
    if (defined wantarray) { $public } else { ($public) = @_ }
}

# parse whatever crappy date a client might give
my @months = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
sub parse_date {
    my ($d, $m, $y, $h, $n, $s) = $_[0] =~ qr/^(?:\w+), (\d\d)[ -](\w+)[ -](\d\d(?:\d\d)?) (\d\d):(\d\d):(\d\d) GMT$/;
    ($m, $d, $h, $n, $s, $y) = $_[0] =~ qr/^(?:\w+) (\w+) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d{4})$/ unless defined $d;
    return 0 unless defined $d;
    timegm( $s, $n, $h, $d, (grep { $months[$_] eq $m } 0..$#months)[0], $y + (length $y == 2 ? 1900 : 0) );
}

# support If-Modified-Since and If-Unmodified-Since
hook after => sub {
    my ($request, $response) = @_;
    if ($request->{method} // '' eq 'GET' and substr($response->{status} // 200, 0, 1) == 2 and exists $response->{headers}{'Last-Modified'}) {
        for my $since (grep { /if-(?:un)?modified-since/ } keys %{$request->{headers}}) {
            next if $since eq 'if-modified-since' and ($response->{status} // 200) != 200;
            if (parse_date($request->{headers}{$since}) >= parse_date($response->{headers}{'Last-Modified'})) {
                $response->{body} = '';
                $response->{status} = $since eq 'if-modified-since' ? 304 : 412;
            }
        }
    }
};

sub send_file {
    my $file = $_[0] // request->{uri};

    $file =~ s{^/}{$public/};
    if ($file =~ qr{/\.\./}) {
        status 403;
        return 'Forbidden';
    }
    if (-e $file and -r $file) {
        if (-f $file) {
            if (!exists response->{headers}{'Content-Type'} and my ($ext) = $file =~ /\.(\w+)$/) {
                headers 'Content-Type' => $mime_types{$ext} if exists $mime_types{$ext};
            }
            open my $fh, '<', $file;
            headers 'Last-Modified' => rfc1123date((stat($fh))[9]);
            join '', map { $_ } (<$fh>);
        } elsif (-d $file) {
            opendir(my $dh, $file);
            my @files = sort grep { !/^\./ } readdir $dh;
            my $path = request->{uri};
            $path .= '/' unless $path =~ m|/$|;
            @files = map { "$_" } @files;
            headers 'Content-Type' => 'text/html';
            join "\n", 'Directory listing of ' . request->{uri} . '', @files, '';
        } else {
            status 500;
            $Limper::reasons->{500};
        }
    } else {
        status 404;
        'This is the void';
    }
}

1;

=for Pod::Coverage

=head1 NAME

Limper::SendFile - add static content support to Limper

=head1 VERSION

version 0.005

=head1 SYNOPSIS

  # order is important:
  use Limper::SendFile;
  use Limper;

  # some other routes

  get qr{^/} => sub {
      send_file;        # sends request->{uri} by default
  };

  limp;

=head1 DESCRIPTION

B extends L to also return actual files. Because sometimes that's needed.

=head1 EXPORTS

The following are all additionally exported by default:

  public send_file

Also exportable:

  mime_types parse_date

=head1 FUNCTIONS

=head2 send_file

Sends either the file name given, or the value of C<< request->{uri} >> if no file name given.

The following as the last defined route will have B look for the file as a last resort:

  get qr{^/} => sub { send_file }

B will be set by file extension if known and header has not already been defined.
Default is B.

=head2 public

Get or set the public root directory. Default is B<./public/>.

  my $public = public;

  public '/var/www/langlang.us/public_html';

=head1 ADDITIONAL FUNCTIONS

=head2 parse_date

Liberally parses whatever date a client might give, returning a Unix timestamp.

  # these all return 784111777
  my $date = parse_date("Sun, 06 Nov 1994 08:49:37 GMT");
  my $date = parse_date("Sunday, 06-Nov-94 08:49:37 GMT");
  my $date = parse_date("Sun Nov  6 08:49:37 1994");

=head2 mime_types

Returns a B of file extension / content-type pairs.

=head1 HOOKS

=head2 after

An B hook is created to support B and B, comparing to B.
This runs for all defined routes, not just those using B.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014 by Ashley Willis [e-mail]

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.12.4 or,
at your option, any later version of Perl 5 you may have available.

=head1 SEE ALSO

L

L

L

=cut

__DATA__