#!/usr/local/bin/perl -T -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.7 2004/03/20 08:41:47 andrew Exp $
# ========================================================================
require 5.005;
use strict;

=head1 NAME

htserver - basic debugging HTTP server

=head1 SYNOPSIS

    % htserver [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 a file with the same basename as this script, but with a .in extension,
exists in the current directory, that file is sent as-is to the client
(e.g. you must include all relevant response headers in that file). By
default, if no such file exists, the server just closes the connection
immediately after reading the response headers. In a typical client this
will result in a "connection closed" error.

=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 $RESPONSE);
$ME = $FindBin::Script;
$RESPONSE = join '.', $ME, 'in';

use vars qw($PORT);
$PORT = shift || 8000;
$PORT = $1 if $PORT =~ /(\d+)/;    # untaint port number

use vars qw($CRLF);
$CRLF = "\015\012";

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


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

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

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",
        $name, inet_ntoa($iaddr), $port;

    my $begin = [ gettimeofday ];
    my $content_length = 0;
    while(<CLIENT>) {
        s/[$CRLF]+$//;
        print STDERR '     ', $_, "\n";
        if(/^\s*Content\-Length\:\s*(\d+)\s*$/i) {
            $content_length = $1;
        }
        last unless $_;
    }
    if($content_length) {
        my $buffer = undef;
        my $bytes = read CLIENT, $buffer, $content_length;
        if($bytes && defined $buffer) {
            $buffer =~ s/^\s+//;
            $buffer =~ s/\s+$//;
            print STDERR '     ', $buffer, "\n\n";
        }
    }

    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 {
    close SERVER;
    printf STDERR "==== server exiting at %s ====\n", scalar(localtime);
}

exit 0;


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