test http server via Net::Server::HTTP for static files

http-server-test.pl

#!/usr/bin/perl

=head1 NAME

http-server-test.pl

=head1 DESCRIPTION

test http server via Net::Server::HTTP for static files

=head1 SYNOPSIS

    http-server-test.pl [--host=localhost] [--port=8000] [--document-root=./]
    Options:
        --host, -s          server host (default - localhost)
        --port, -p          server port (default - 8000)
        --document-root, -d document root (default - current dir)
        --access-log, -a    log to this file
        --help, -h          help
        --version, -v       print version

=cut

package Net::Server::HTTP::LightForStaticFiles;

use strict;
use warnings;

use base qw(Net::Server::HTTP);
use URI::Escape;
use Data::Dumper;

our $VERSION = 0.01;

# perl -MMojolicious::Types -MData::Dumper -E 'say Dumper(Mojolicious::Types->new()->types())'
our %MIME_TYPES = (
    'tar'  => 'application/x-tar',
    'css'  => 'text/css',
    'ico'  => 'image/x-icon',
    'bin'  => 'application/octet-stream',
    'xsl'  => 'text/xml',
    'woff' => 'application/x-font-woff',
    'txt'  => 'text/plain',
    'json' => 'application/json',
    'html' => 'text/html;charset=UTF-8',
    'xml'  => 'text/xml',
    'jpg'  => 'image/jpeg',
    'atom' => 'application/atom+xml',
    'gz'   => 'application/gzip',
    'mp3'  => 'audio/mpeg',
    'png'  => 'image/png',
    'pdf'  => 'application/pdf',
    'htm'  => 'text/html;charset=UTF-8',
    'zip'  => 'application/zip',
    'js'   => 'application/x-javascript',
    'jpeg' => 'image/jpeg',
    'rss'  => 'application/rss+xml',
    'gif'  => 'image/gif',
    'svg'  => 'image/svg+xml'
);

our %CONFIG;
our $CRLF = "\r\n";

# ------------------------------------------------------------------------------
sub run {
    my $self = shift;
    my %params = @_;

    for my $config_name (qw/document_root access_log/) {
        $CONFIG{$config_name} = $params{$config_name} if defined $params{$config_name}
    }

    $self->SUPER::run(@_);
}

# ------------------------------------------------------------------------------
sub process_http_request {
    my $self = shift;

    my $document_root = $CONFIG{document_root} || ".";
    my $method = $ENV{REQUEST_METHOD};
    my $path = $ENV{PATH_INFO};
    my $file_name = $document_root . uri_unescape($path);
    $file_name =~ s/\.\././g;
    my $user_agent = $ENV{HTTP_USER_AGENT} || '-';
    my $status_code = 200;
    my $content_type = $MIME_TYPES{html};
    my $content;

    # Response
    if (-e $file_name) {

        if (! -r $file_name) {
            $status_code = 403;
            $content = '<h1 style="font-size: 500%;">403 Forbidden.</h1>';
        } elsif (-f $file_name) {
            my ($ext) = $file_name =~ /\.([a-z]+)$/i;

            if ($ext && $MIME_TYPES{lc $ext}) {
                $content_type = $MIME_TYPES{lc $ext};
            } else {
                open my $F, '-|', 'file', '--brief', '--mime-type', $file_name or die "error on exec 'file $file_name': $!\n";
                $content_type = join('', <$F>);
                $content_type =~ s/\s+//g;
                close $F;

                $content_type //= $MIME_TYPES{bin};
            }

        } elsif (-d $file_name && ! -e "$file_name/index.html") {
            $content = "<h1>Directory listing:</h1>\n";
            $content .= join("<br>\n",
                map {my $size = -s $_;
                     s/^\.//;
                     s|//|/|g;
                     qq|<a href="$_">$_</a> - $size|
                }
                sort
                glob("$file_name/*")
            );
        } elsif (-d $file_name && -e "$file_name/index.html" && -r "$file_name/index.html") {
            $file_name = "$file_name/index.html";
        } else {
            $status_code = 500;
            $content = '<h1 style="font-size: 500%;">500 Error.</h1>';
        }

    } else {
        $status_code = 404;
        if (-f "$document_root/404.html" && -r "$document_root/404.html") {
            $file_name = "$document_root/404.html";
        } else {
            $content = '<h1 style="font-size: 500%;">404 Not found.</h1>';
        }
    }

    if (! defined $content && defined $file_name) {
        open my $F, '<', $file_name or die "error open $file_name: $!\n";
        binmode $F, ':raw';
        local $/;
        $content = <$F>;
        close $F;
    }

    # out header and content
    $self->{http_status} = $status_code;
    print "Content-type: $content_type$CRLF$CRLF";
    print $content;

    # logging
    my $time = localtime() . "";
    my $log_line = "[$time] $method $path ($content_type) - $status_code\n";
    if (defined $CONFIG{access_log}) {
        open my $FH, '>>', $CONFIG{access_log} or die "Error open file: $!\n";
        print $FH $log_line;
        close $FH;
    } else {
        print STDERR $log_line;
    }
}

# ------------------------------------------------------------------------------
sub send_status {
    my ($self) = @_;

    my $status = $self->{http_status};
    my $msg = $status == 200 ? 'OK' : '-';

    print "HTTP/1.0 $status $msg$CRLF";
    print "Date: " . gmtime() . " GMT$CRLF";
    print "Server: " . $self->server_revision() . $CRLF;
    print "Connection: close$CRLF";
}

1;

# ------------------------------------------------------------------------------
package main;

use strict;
use warnings;

use Getopt::Long;
use Pod::Usage;

our $VERSION = 0.01;

# ------------------------------------------------------------------------------
sub main {
    my $host = 'localhost';
    my $port = 8000;
    my $document_root = '.';
    my $access_log;

    GetOptions(
        "host|s=s" => \$host
        , "port|p=i" => \$port
        , "document-root|d=s" => \$document_root
        , "access-log|a=s" => \$access_log
        , "help|h" => sub {
            pod2usage(-exitval => 0, -verbose => 99, -sections => [qw/NAME DESCRIPTION SYNOPSIS/]);
        }
        , "version|v" => sub {
            print "$VERSION\n";
            exit 0;
        }
    );

    print STDERR qq|Start HTTP server at http://$host:$port/ for documents in "$document_root"...\n|;

    Net::Server::HTTP::LightForStaticFiles->run(
        port => $port
        , host => $host
        , server_type => 'Fork'
        , log_level => 0
        , document_root => $document_root
        , access_log => $access_log
    );
}

# ------------------------------------------------------------------------------
main();