#!/usr/bin/perl
#
# /root/bin/testsvr.pl
#
#   Why does HTTP::Daemon not close its socket?
#

use     strict;
use     warnings;
use     UNIVERSAL   qw(isa);

use     File::Basename;
use     Getopt::Long;
use     HTTP::Daemon;
use     HTTP::Status;
use     LWP::Simple;
use     POSIX;

# Time-related constants:
use     constant    MINUTE  => 60;
use     constant    QUARTER => 15 * MINUTE;
use     constant    HOUR    => 60 * MINUTE;

# Default values for arguments:
my  $cycle   =    3;            #!< HTTP service loop timeout
my  $port    = 9876;            #!< port on which to serve pages

# Global variables:
my  $quit    = undef;
my  $script  = basename($0);

###########################################################################
sub logErr  # $format, @args
# Send error data to STDERR or system error log.
#
    {
    printf STDERR @_;
    print  STDERR "\n";
    }

###########################################################################
sub logInfo # $format, @args
# Send info data to STDOUT or system error log.
#
    {
    my  $retn = $_[0] =~ /\r$/;

    printf STDOUT @_;
    print  STDOUT "\n"
        unless $retn;
    }

###########################################################################
sub service     # $server
# Basic service loop or HTTP daemon.
#
    {
    my  $server = shift;
    
    while (! $quit)
        {
        my  $connect = $server->accept;

        # Timeout waiting for page request:
        next
            unless defined $connect;
        
        my  $request = $connect->get_request;
        
        if (! $request)
            {
            logErr("* Unable to get request from connection:");
            logErr("  %s", $connect->reason);
            }
        
        elsif ($request->method ne 'GET' && $request->method ne 'POST')
            {
            $connect->send_error(RC_FORBIDDEN, 'Not a GET or PUT request');
            }
        
        elsif ($request->url->path eq '/quit')
            {
            logInfo("  Server Terminating");
            $connect->send_error(RC_FORBIDDEN, 'Server quit!');
            $quit = 1;
            }
        
        else
            {
            $connect->send_error(RC_FORBIDDEN, 'Server has been gutted!');
            }
        
        $connect->force_last_request;
        $connect->close;
        undef $connect;
        }
    }

###########################################################################
###########################################################################
#
# Main program:
#

###########################################################################
# Process command line arguments:

my  $help;

unless (GetOptions('help'       => \$help,
                   'port=i'     => \$port,
                   'cycle=i'    => \$cycle) && ! $help)
    {
    my  $indent = ' ' x length($script);
    
    die <<USAGE
    Usage:  $indent [--port=<portnum>]  # port number for server
            $indent [--cycle=<seconds>] # HTTP server loop timeout
            $indent [--help]            # show this message
USAGE
    }

logInfo("%s Starting", $script);
logInfo("    Port:    %d", $port);
logInfo("    Cycle:   %d", $cycle);

###########################################################################
# Get rid of existing server(s):

while (my $page = get("http://localhost:$port/quit"))
    {
    logInfo("  Server Killed");
    sleep 1;    # otherwise we occasionally try to start too fast
    }

###########################################################################
# Create HTTP demon:

eval
    {
    my  $server;
    my  $begin = time;

    until ($quit)
        {
        sleep 1;    # don't try the creation too quickly
        
        $server = new HTTP::Daemon(LocalPort => $port);

        last
            if isa $server, 'HTTP::Daemon';

        die "Unable to create server object:\n  $!\n"
            unless $! =~ /Address.*in\s+use/i;

        my  $secs = time - $begin;
        my  $mins = $secs / MINUTE;

        die "\nTimeout waiting for port $port\n"
            if $secs > 2 * MINUTE;

        $secs %= MINUTE;

        my  $fh = select(STDOUT); $| = 1; select($fh);

        logInfo("  Wait for port $port (%d:%02d)\r", $mins, $secs);

        sleep 5;
        }
    
    logInfo("                                                \r");
    logInfo("  Server Created");

    $server->timeout($cycle);
    service($server);
    $server->close;
    undef $server;

    logInfo("  Server Terminated");
    };

logErr("  Server Error:"),
logErr("    %s", $@)
    if $@;

###########################################################################
# Shutdown:

logInfo("%s Finished", $script);