File Coverage

blib/lib/Test/HTTP/log-server

Criterion	Covered	Total	%
statement	105	159	66.0
branch	47	88	53.4
condition	6	10	60.0
subroutine	11	13	84.6
pod			n/a
total	169	270	62.5

# Thanks to merlyn for nudging me and giving me this snippet!
use strict;
use HTTP::Daemon 6.05;
use URI;
use CGI;
use HTTP::Request::AsCGI;
use Getopt::Long;
use Socket();
use Time::HiRes 'sleep';
our $VERSION = '0.74';

$|++;

GetOptions(
    'e=s' => \my $expression,
    'f=s' => \my $url_filename,
    's=s' => \my $request_pause,
);

if( ! defined $request_pause ) {
    $request_pause = 1;
}

# HTTP::Daemon(IO::Socket::IP) sets $@ in case of error
my $d = HTTP::Daemon->new or die "Couldn't create HTTP::Daemon: $@";

my $url = URI->new( $d->url );
if( $d->sockdomain == Socket::AF_INET ) {
    $url->host('127.0.0.1');
} elsif ($d->sockdomain == Socket::AF_INET6 ) {
    $url->host('[::1]');
} else {
    die "Unexpected sockdomain: " . $d->sockdomain;
};

{
    my $fh;
    if( $url_filename ) {
        open $fh, '>', $url_filename
            or die "Couldn't write URL to tempfile '$url_filename': $!";
    } else {
        $fh = \*STDOUT;
    };
    print {$fh} "$url\n";
    close $fh unless $url_filename;
}

my ($filename,$logfile) = @ARGV[0,1];
if ($filename) {
  open DATA, "< $filename"
    or die "Couldn't read page '$filename' : $!\n";
};
#open LOG, ">", $logfile
#  or die "Couldn't create logfile '$logfile' : $!\n";
my $log;
my $body = join "", ;

sub debug($) {
  my $message = $_[0];
  $message =~ s!\n!\n#SERVER:!g;
  warn "#SERVER: $message"
    if $ENV{TEST_HTTP_VERBOSE};
};

my $multi_param = eval { CGI->can('multi_param') } ? 'multi_param' : 'param';

sub respond_200 {
    my( $location, $r ) = @_;
    my $context = HTTP::Request::AsCGI->new( $r )->setup;
    my $q = CGI->new();

    # Make sticky form fields
    my ($filename, $filetype, $filecontent, $query,$botcheck_query,$query2,$session,%cat);
    $query = defined $q->param('query') ? $q->param('query') : "(empty)";
    $botcheck_query = defined $q->param('botcheck_query') ? $q->param('botcheck_query') : "(empty)";
    $query2 = defined $q->param('query2') ? $q->param('query2') : "(empty)";
    $session = defined $q->param('session') ? $q->param('session') : 1;
    my @cats = $q->$multi_param('cat');
    %cat = map { $_ => 1 } ( @cats ? @cats : qw( cat_foo cat_bar ));
    my @categories = map { $cat{$_} ? "checked" : "" } qw( cat_foo cat_bar cat_baz );
    my $headers = CGI::escapeHTML( $r->headers->as_string );
    my $rbody = sprintf $body,$headers, $location,
                     $filename, $filetype, $filecontent,
                     $session,$query,$botcheck_query,$query2,@categories,
                     ;
    my $res = HTTP::Response->new(200, "OK", [
          'Set-Cookie' => $q->cookie(-name => 'log-server-httponly',-value=>'supersecret', -discard => 1, -httponly=>1),
          'Set-Cookie' => $q->cookie(-name => 'log-server',-value=>'shazam2', -discard=>1,),
          'Cache-Control' => 'no-cache',
          'Pragma' => 'no-cache',
          'Max-Age' => 0,
          'Connection' => 'close',
          'Content-Length' => length($rbody),
      ], $rbody);
    $res->content_type('text/html; charset=ISO-8859-1');
    debug "Request " . ($r->uri->path || "/");
    $res
}

SERVERLOOP: {
  my $quitserver;
  while (my $c = $d->accept) {
    debug "New connection";
    while (my $r = $c->get_request) {
      debug "Request:\n" . $r->as_string;
      my $location = ($r->uri->path || "/");
      my ($link1,$link2) = ('','');
      if ($location =~ m!^/link/([^/]+)/(.*)$!) {
        ($link1,$link2) = ($1,$2);
      };
      my $res;
      if ($location eq '/get_server_log') {
        $res = HTTP::Response->new(200, "OK", undef, $log);
        $log = '';
      } elsif ( $location eq '/quit_server') {
        debug "Quitting";
        $res = HTTP::Response->new(200, "OK", [Connection => 'close'], "quit");
        $quitserver = 1;
      } else {
        eval $expression
            if $expression;
        warn "eval: $@" if $@;
        $log .= "Request:\n" . $r->as_string . "\n";
        if ($location =~ m!^/redirect/(.*)$!) {
            $res = HTTP::Response->new(302);
            $res->header('location', $url . $1);

        } elsif ($location =~ m!^/local/(.*)$!) {
            my $rbody= do { open my $fh, '<', $1; binmode $fh; local $/; <$fh> };
            $res = HTTP::Response->new(200, "OK", [
                  'Cache-Control' => 'no-cache',
                  'Pragma' => 'no-cache',
                  'Max-Age' => 0,
                  'Connection' => 'close',
                  'Content-Length' => length($rbody),
            ], $rbody);

        } elsif ($location =~ m!^/download/([\w.-]+)$!) {
            my $rbody= do { open my $fh, '<', $0; binmode $fh; local $/; <$fh> };
            $res = HTTP::Response->new(200, "OK", [
                  'Cache-Control' => 'no-cache',
                  'Pragma' => 'no-cache',
                  'Max-Age' => 0,
                  'Connection' => 'close',
                  'Content-Length' => length($rbody),
				  'Content-Disposition' => qq{attachment; filename=$1;},
            ], $rbody);

        } elsif ($location =~ m!^/error/notfound/(.*)$! or $location =~ m!^/favicon.ico!) {
            $res = HTTP::Response->new(404, "Not found", [Connection => 'close']);
        } elsif ($location =~ m!^/error/timeout/(\d+)$!) {
            sleep $1;
            $res = HTTP::Response->new(599, "Timeout reached", [Connection => 'close']);

        } elsif ($location =~ m!^/error/close/(\d+)$!) {
            sleep $1;
            $res = undef;

        } elsif ( $location =~ m!^/chunks!) {
            my $count = 5;
            $res = HTTP::Response->new(200, "OK", undef, sub {
               sleep 1;
               my $buf = 'x' x 16;
               return $buf if $count-- > 0;
               return undef; # done
            });

        } elsif ($location =~ m!^/error/after_headers$!) {
            my $count = 2;
            $res = HTTP::Response->new(200, "OK", undef, sub {
               sleep 1;
               my $buf = 'x' x 16;
               return $buf if $count-- > 0;
               die "Planned error after headers";
            });

        } elsif ($location =~ m!^/large/bzip/16M$!) {
            my $headers = HTTP::Headers->new(
                Content_Type => "application/xml",
                Content_Encoding => 'bzip2,bzip2,bzip2', # say my name three times
            );
            # 16M bzip thrice-encoded, see gen-bzipbomb.pl
            $body = join "",
                "BZh11AY&SY\tPFN\0\0'\177\377\355\e\177v\363\267|\344?\226]pVbW\25\313|F",
                "]h0\30\303\305i\272CF9fS\260\0\271\b\32\32h\323\32414\304ddbh4\304h4\304z\231\6h",
                "#\32\2154\310\365=\4`\32 fQ\341O)\371Q\6L\0\230\0\t\200#L#\0\0\0\4\311\246&\203",
                "\0#\0\0\0\0\203&\322a11\240\0&\21\200\320\232`\1\0310\4\323\0#4\20d\300L\4d`\34",
                "\370I\21o\f\304\0\205b\344\365u\326\334O\301\0054}\306\274\215\246\240\351\247\240",
                "M\252\333Je)\25\217\231\230\00046\236)\4(R\301\370\363\371\350\277\b0\26\275\16&",
                "W\260\2\2151\272\177\301\366}\327b\213\374\t\264g~\245\203\225\220\2660,\226\213",
                "\247\246l\351\303\304\300\$z0Hg\272;\31\226B\244\266\376\301\364\355I~\222\273",
                "\226*S\"\3\263\360\200Iv\241}|\344\227q\1I\6\217I\30\302\2\261\207\224h\305\16\17",
                "\324\1779\1\247\\R{\335\$pM8cL\"\201\311 \374\364P\274\227p\237\300\320`\36pJ\264",
                "\21\277\305\334\221N\24\$\2T\21\223\200"
                ;
            $res = HTTP::Response->new(200, "OK", $headers, $body);

        } elsif ($location =~ m!^/large/gzip/16M$!) {
            my $headers = HTTP::Headers->new(
                Content_Type => "application/xml",
                Content_Encoding => 'gzip,gzip,gzip', # say my name three times
            );
            # 16M bzip thrice-encoded, see gen-gzipbomb.pl
            $body = join "",
                "\37\213\b\0\0\0\0\0\0\377\223\357\346`\0\203\377o/l\344mr`h}h\235\321\341",
                "- T^\300^\225-\276p\307\221Km\242>/b\31\237%\260>\346\220S7\2760\243&\376\363",
                "\277_[\373\325\336|\252\356\334\230#\265\177\275\1771\27\304\f\206\3\363\275_",
                "\357]Ww\361\351\355\247o\370\241b\26\aj\336\316?\34\242\224\27a\347\24\270",
                "\336\236\201\1\0!\203w\217s\0\0\0",
                ;
            $res = HTTP::Response->new(200, "OK", $headers, $body);

        } elsif ($location =~ m!^/content/(.*)$!) {
            my $headers = HTTP::Headers->new(
                Content_Type => "text/html",
            );
		    (my $html = $1) =~ s!%([a-fA-F0-9]{2})!chr(hex($1))!ge;
            $body = join "",
                "",
                "$html",
                "",
                ;
            $res = HTTP::Response->new(200, "OK", $headers, $body);

        } elsif ($location =~ m!^/basic_auth/([^/]+)/([^/]+)$!) {
            my ($user, $pass) = $r->authorization_basic;
            my( $ex_user, $ex_pass ) = ($1,$2);
            if(     $user eq $ex_user
                and $pass eq $ex_pass) {
                $res = respond_200( $location, $r );

            } else {
                debug "# User : '$user' Password : '$pass'\n";
                $res = HTTP::Response->new(401, "Auth Required", undef,
                                            "auth required ($user/$pass)");
                $res->www_authenticate("Basic realm=\"testing realm\"");
            };

        } else {
            $res = respond_200( $location, $r );
        };
      };
      debug "Response:\n" . $res->as_string
          if $res;
      eval {
        $c->send_response($res)
            if $res;
      };
      if (my $err = $@) {
          debug "Server raised error: $err";
          if ($err !~ /^Planned error\b/) {
              warn $err;
          };
          $c->close;
      };
      if (! $res) {
          $c->close;
      };
      last if $quitserver;
    }
    sleep $request_pause;
    undef($c);
    last SERVERLOOP
      if $quitserver;
  };
  undef $d;
};
END { debug "Server $$ stopped" };

# The below  tag should stop the browser from requesting a favicon.ico, but we still see it...
__DATA__