#!/usr/local/bin/perl -w
# ========================================================================
# htserver - basic debugging HTTP server
# Andrew Ho (andrew@zeuscat.com)
#
# This program contains embedded documentation in Perl POD (Plain Old
# Documentation) format. Search for the string "=head1" in this document
# to find documentation snippets, or use "perldoc" to read it; utilities
# like "pod2man" and "pod2html" can reformat as well.
#
# $Id: htserver,v 1.8 2009/02/17 07:59:58 andrew Exp $
# ========================================================================
require 5.005;
use strict;

=head1 NAME

htserver - basic debugging HTTP server

=head1 SYNOPSIS

    % htserver [-h] [-i file] [-o path] [[-p] port]

=head1 DESCRIPTION

Starts up a barebones, single process HTTP server on the port specified
on the command line (or a default port of 8000). The server outputs a
debug log to STDERR which includes all received HTTP headers; this is
useful for peeking at what headers an HTTP client is sending in its
request. Basic benchmarking information is also provided.

If the -i option is provided with a filename argument, that that file is
sent as-is to the client (e.g., you must include all relevant response
headers in that file). By default, the server looks for a file in the
current directory with the same basename as this script, but with a .in
extension (i.e., F<htserver.in>). If no file exists that can be served,
the server just closes the connection immediately after reading the
response headers. In a typical client this will result in a "connection
closed" error.

Writing output to files instead of to the terminal is supported if the
-o option is specified, with a filename or directory argument. If the
argument to -o is a filename, that file is overwritten on each incoming
request with the verbatim contents of the incoming request. If the
argument to -o is a directory, sequential numbered files with the same
basename as this script, but with a .out extension (i.e.,
F<htserver1.out>) are written for each incoming request.

=head1 AUTHOR

Andrew Ho E<lt>F<andrew@zeuscat.com>E<gt>

=cut


# ------------------------------------------------------------------------
# Libraries and globals

use Time::HiRes qw( gettimeofday tv_interval );
use FindBin;
use Socket;

use vars qw($ME $PORT $RESPONSE $REQUEST $HELP $USAGE $FULL_USAGE $CRLF);
$ME = $FindBin::Script;
$PORT = 8000;
$RESPONSE = join '.', $ME, 'in';
$USAGE = "usage: $ME [-h] [-i file] [-o path] [[-p] port]\n";
$FULL_USAGE = $USAGE . << "EndUsage";
    -h         display this help text and exit
    -i file    deliver this file as-is in HTTP response (default $RESPONSE)
    -o path    write incoming requests to this file or directory
    -p port    use this port (default $PORT);
EndUsage
$CRLF = "\015\012";


# ------------------------------------------------------------------------
# Parse command line

my $got_port = 0;
while(@ARGV) {
    local $_ = shift @ARGV;
    if(/^\-+h(?:elp)?/i) {
        print STDERR $FULL_USAGE;
        $HELP = 1;
        exit 0;
    } elsif(/^\-+i(?:nput)?/i) {
        unless(@ARGV) {
            print STDERR qq($ME: "-i" option requires an input file argument\n);
            print STDERR $USAGE;
            exit 1;
        }
        $RESPONSE = shift @ARGV;
        if(!defined($RESPONSE) || $RESPONSE eq '') {
            print STDERR qq($ME: malformed or empty input filename\n);
            exit 1;
        }
    } elsif(/^\-+o(?:utput)?/i) {
        unless(@ARGV) {
            print STDERR
                qq($ME: "-o" option requires an output path argument\n);
            print STDERR $USAGE;
            exit 1;
        }
        $REQUEST = shift @ARGV;
        if(!defined($REQUEST) || $REQUEST eq '') {
            print STDERR qq($ME: malformed or empty output path\n);
            exit 1;
        }
    } elsif(/^\-.*$/) {
        print STDERR qq($ME: unrecognized argument "$_"\n);
        print STDERR $USAGE;
        exit 1;
    } else {
        if($got_port) {
            print STDERR qq($ME: ignoring extra argument "$_"\n);
        } elsif(/^(\d+)$/) {
            $PORT = $1;
        } else {
            print STDERR qq($ME: malformed or empty port argument\n);
            print STDERR $USAGE;
            exit 1;
        }
    }
}


# ------------------------------------------------------------------------
# Set up network server

my $proto = getprotobyname('tcp');

socket(SERVER, PF_INET, SOCK_STREAM, $proto)    || die "socket error: $!";
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1) || die "setsockopt error: $!";

bind(SERVER, sockaddr_in($PORT, INADDR_ANY))    || die "bind error: $!";
listen(SERVER, SOMAXCONN)                       || die "listen error: $!";


# ------------------------------------------------------------------------
# Main loop

$SIG{INT} = sub { print STDERR "\n"; exit 0; };

printf STDERR "==== server started on port %d at %s ====\n",
    $PORT, scalar localtime;

my $i = 1;
my $get_output_functions = sub {
    my $filename = !defined($REQUEST) ? undef :
        (-d $REQUEST ? join '', $REQUEST, '/', $ME, $i++, '.out' : $REQUEST);
    if($filename && open(my $fh, '>', $filename)) {
        binmode $fh;
        my $bytes = 0;
        return(
            sub {
                $bytes += length($_[0]);
                print $fh $_[0];
            },
            sub {
                close $fh;
                printf STDERR "     wrote request to %s (%d %s)\n",
                    $filename, $bytes, $bytes == 1 ? 'byte' : 'bytes';
                $bytes = 0;
            },
        );
    } else {
        print STDERR "$ME: could not open $filename for writing: $!\n"
            if defined $filename;
        return(
            sub {
                local $_ = shift;
                s/^\s+//;
                s/\s+$//;
                print STDERR '    ', $_, "\n";
            },
            sub {},
        );
    }
};

for(my $paddr; $paddr = accept(CLIENT, SERVER); close CLIENT) {
    my($port, $iaddr) = sockaddr_in($paddr);
    my $name = gethostbyaddr($iaddr, AF_INET);

    printf STDERR "---- connection from %s (%s), port %d ----\n",
        defined($name) ? $name : 'unknown host', inet_ntoa($iaddr), $port;

    my($print, $close) = $get_output_functions->();
    my $begin = [ gettimeofday ];
    my $content_length = 0;
    my $chunked = 0;
    while(<CLIENT>) {
        if(/^\s*Content\-Length\:\s*(\d+)\s*$/i) {
            $content_length = $1;
        } elsif(/^\s*Transfer\-Encoding\:\s*chunked\s*$/i) {
            $chunked = 1;
        }
        $print->($_);
        last if /^\s*$/;
    }
    if($content_length) {
        my $buffer = undef;
        my $bytes = read CLIENT, $buffer, $content_length;
        if($bytes && defined $buffer) {
            $print->($buffer);
        }
    } elsif($chunked) {
        # Use and decode chunked Transfer-Encoding (see RFC 2616, 19.4.6)

        # Read first chunk size
        local $/ = $CRLF;
        my $chunk_size = <CLIENT>;
        $print->($chunk_size);
        $chunk_size =~ s/\s+$//;
        $chunk_size = hex $chunk_size;

        # Read loop
        while($chunk_size > 0) {
            my $buffer = ' ' x $chunk_size;
            my $bytes_read = read CLIENT, $buffer, $chunk_size;
            if($bytes_read != $chunk_size) {
                my $bytes = $bytes_read == 1 ? 'byte' : 'bytes';
                warn "$ME: read $bytes_read $bytes, but expected $chunk_size\n";
            }
            $print->($buffer);

            # Read next endline
            my $crlf = <CLIENT>;
            unless($crlf eq $CRLF) {
                warn qq($ME: received "$crlf", but expected CRLF);
            }
            $print->($crlf);

            # Read next chunk size (identical to code above)
            $chunk_size = <CLIENT>;
            $print->($chunk_size);
            last unless defined $chunk_size;
            $chunk_size =~ s/\s+$//;
            $chunk_size = hex $chunk_size;
        }

        # There can be more headers, or a CRLF here
        while(<CLIENT>) {
            $print->($_);
            last if $_ eq $CRLF;
        }
    }
    $close->();

    if(-f $RESPONSE && -r _ && open(IN, $RESPONSE)) {
        my $bytes = 0;
        my $in_header = 1;
        while(<IN>) {
            if($in_header) {
                s/[$CRLF]+$//;
                print CLIENT $_, $CRLF;
                $in_header = 0 unless $_;
                $bytes += length($_) + length($CRLF);
            } else {
                print CLIENT $_;
                $bytes += length($_);
            }
        }
        printf STDERR "     sent response (%d %s)\n", $bytes,
            $bytes == 1 ? 'byte' : 'bytes';
        close IN;
    }
    close CLIENT;
    my $elapsed = tv_interval($begin, [ gettimeofday ]);
    printf STDERR "---- connection closed (%0.3f ms) ----\n", $elapsed;
}


# ------------------------------------------------------------------------
# Clean up and exit

END {
    unless($HELP) {
        close SERVER;
        printf STDERR "==== server exiting at %s ====\n", scalar(localtime);
    }
}

exit 0;


# ========================================================================
__END__