File Coverage

blib/lib/HTTP/Server/Simple/Static.pm

Criterion	Covered	Total	%
statement	29	86	33.7
branch	0	18	0.0
condition	0	14	0.0
subroutine	10	12	83.3
pod	1	2	50.0
total	40	132	30.3

package HTTP::Server::Simple::Static;
use strict;
use warnings;

use v5.10;

use Cwd ();
use File::Spec::Functions qw(catfile);
use HTTP::Date ();
use IO::File     ();
use URI::Escape  ();

use base qw(Exporter);
our @EXPORT = qw(serve_static);

our $VERSION = '0.14';

my $line_end = "\015\012";

my $magic;

my @mime_types = (
    [ qr/\.htm(l)?$/ => 'text/html'  ],
    [ qr/\.txt$/     => 'text/plain' ],
    [ qr/\.css$/     => 'text/css'   ],
    [ qr/\.js$/      => 'application/javascript' ],
);

sub get_mimetype {
    my ($path) = @_;

    for my $type (@mime_types) {
        if ( $path =~ $type->[0] ) {
            return $type->[1];
        }
    }

    if ( !defined $magic ) {
        require File::LibMagic;
        $magic = File::LibMagic->new();
    }

    return $magic->checktype_filename($path);
}

sub serve_static {
    my ( $self, $cgi, $base ) = @_;
    $base //= q{.};

    my $realbase = Cwd::realpath($base);

    my $path = $cgi->url( -absolute => 1, -path_info => 1 );

    # Internet Explorer provides the full URI in the GET section
    # of the request header, so remove the protocol, domain name,
    # and port if they exist.
    $path =~ s{^https?://([^/:]+)(:\d+)?/}{/};

    $path = URI::Escape::uri_unescape($path);

    # The splitting of the URL path and then concatenating with the
    # base ensures the correct directory separators are used for the
    # file path.

    my @parts = split q{/+}, $path;
    my $fullpath = catfile( $realbase, @parts );

    # Sanitize the path and try it.

    my $realpath = Cwd::realpath($fullpath);
    if ( !$realpath || $realpath !~ m/^\Q$realbase\E/ ) {
        # directory traversal attack!
        return 0;
    }

    my $fh = IO::File->new();
    if ( -f $realpath && $fh->open($realpath) ) {
        my $mtime = ( stat $realpath )[9];
        my $now = time;

        # RFC-2616 Section 14.25 "If-Modified-Since":

	my $if_modified_since = $cgi->http('If-Modified-Since');
	if ($if_modified_since) {
	    $if_modified_since = HTTP::Date::str2time($if_modified_since);

	    if ( defined $if_modified_since &&     # parsed ok
		 $if_modified_since <= $now &&     # not in future
		 $mtime <= $if_modified_since ) {  # not changed

		print 'HTTP/1.1 304 Not Modified' . $line_end;
		print $line_end;

		return 1;
	    }
	}

	# Read the file contents and get the length in bytes

        binmode $fh;
        binmode $self->stdout_handle;

        my $content;
        {
            local $/;
            $content = <$fh>;
        }
        $fh->close;

        my $content_length;
        if ( defined $content ) {
            use bytes;    # Content-Length in bytes, not characters
            $content_length = length $content;
        }
        else {
            $content_length = 0;
            $content        = q{};
        }

	# Find MIME type

        my $mimetype = get_mimetype($realpath);

        # RFC-2616 Section 14.29 "Last-Modified":
        #
        # An origin server MUST NOT send a Last-Modified date which is
        # later than the server's time of message origination. In such
        # cases, where the resource's last modification would indicate
        # some time in the future, the server MUST replace that date
        # with the message origination date.

        if ( $mtime > $now ) {
            $mtime = $now;
        }

        my $last_modified = HTTP::Date::time2str($mtime);
        my $date = HTTP::Date::time2str($now);

        print 'HTTP/1.1 200 OK' . $line_end;
        print 'Date: ' . $date . $line_end;
        print 'Last-Modified: ' . $last_modified . $line_end;
        print 'Content-Type: ' . $mimetype . $line_end;
        print 'Content-Length: ' . $content_length . $line_end;
        print $line_end;

	if ( $cgi->request_method() ne 'HEAD' ) {
	    print $content;
	}

        return 1;
    }
    return 0;
}

1;
__END__