File Coverage

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

Criterion	Covered	Total	%
statement	24	74	32.4
branch	0	16	0.0
condition	0	9	0.0
subroutine	8	10	80.0
pod	1	2	50.0
total	33	111	29.7

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

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

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

our $VERSION = '0.12';

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 ) = @_;
    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+)?/}{/};

    # Sanitize the path and try it.
    $path = $base . canonpath( URI::Escape::uri_unescape($path) );

    my $fh = IO::File->new();
    if ( -f $path && $fh->open($path) ) {
        my $mtime = ( stat $path )[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($path);

        # 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__