The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -Ilib -I.
# Include lib of the project dir and the project dir itself
# (assuming that this task has been started from the project dir)

=pod

=head1 YAWF-Webserver

This is a simple webserver for testing projects.

Point your browser to http://127.0.0.1:8000/ to get access to the
development version of your project. It reloads changed modules on
every request.

The request log, debug output and errors go to STDOUT.

WARNING: This server is ONLY FOR DEVELOPMENT, it has nearly no security
features and can't handle more than one request at the same time!

=cut

sub read_config {
open my $cfgfile, 'test_httpd.cfg';
$Port = <$cfgfile>;
$wwwroot = <$cfgfile>;
close $cfgfile;
chomp $Port;
chomp $wwwroot;
$Port ||= 8000;
$wwwroot ||= '.';
}

{

    package MyWebServer;

    use HTTP::Server::Simple::CGI;
    use base qw(HTTP::Server::Simple::CGI);

    use YAWF;
    use YAWF::Request;

    sub setup {
        my $self = shift;
        my %Data = @_;
        for ( keys(%Data) ) {
            $self->{$_} = $Data{$_};
        }
        $self->setup_environment_from_metadata(@_);
        return 1;
    }

    sub headers {
        my $self = shift;
        $self->{headers} = { @{ $_[0] } };
        HTTP::Server::Simple::CGI->headers(@_);
    }

    sub handle_request {
        my $self = shift;
        my $cgi  = shift;

        print STDERR "*** " . $self->{path} . " ***\n";

        if ( $self->{path} =~ /\.(ico|png|gif|jpe?g|css|js)$/ ) {

            # Static files don't go through the request handler
            &main::read_config unless defined($wwwroot);

            my $file = $main::wwwroot . $self->{path};    # Path should start with '/'
            $file = '' if $self->{path} =~ /\.\./;     # Simple security check

            if ( open( fh, $file ) ) {
                print "HTTP/1.1 200 OK\r\n" . "Content-type: ";
                if    ( $self->{path} =~ /\.png$/ )   { print "image/png"; }
                elsif ( $self->{path} =~ /\.gif$/ )   { print "image/gif"; }
                elsif ( $self->{path} =~ /\.jpe?g$/ ) { print "image/jpeg"; }
                else                                  { print "text/plain"; }
                print "\r\n\r\n";

                print <fh>;
                close fh;
            }
            else {
                print "HTTP/1.1 404 Not found\r\n"
                  . "Content-type: text/plain\r\n\r\nError opening $file: $!\n";
                print STDERR "Error opening $file: $!\n";
            }
        }
        elsif ( fork == 0 ) {

            eval {

                my $domain = $self->{headers}->{Host};
                $domain =~ s/\:\d+$//;

                require YAWF::Request;
                my $job = YAWF::Request->new(
                    domain       => $domain,
                    uri          => $self->{path},
                    args_GET     => $self->{query_string},
                    method       => $self->{method},
                    headers      => $self->{headers},
                    remote_ip    => $self->{peeraddr},
                    documentroot => '.',
                    CGI          => $cgi,
                    error        => sub {
                        print STDERR scalar( localtime(time) )
                          . ' HTTPD-ERROR '
                          . join( ' ', @_ ) . "\n";
                    },
                    send_status => sub { print "HTTP/1.1 $_[0] OK\n"; },
                    send_header => sub { print "$_[0]: $_[1]\n"; },
                    send_body   => sub { print "\n"; print @_; },
                );
                $job->run or print "WARNING: Job returned with zero value!\n";

            };

            if ($@) {
                print
                  "HTTP/1.1 200 OK\r\n\r\n<h1>Error</h1><tt>\n$@\n</tt>\r\n";
            }

            exit;

        }

        return 1;
    }

}

# start the server on port 8000
&read_config;
my $pid = MyWebServer->new($Port)->run();