package LocalServer;

# start a fake webserver, fork, and connect to ourselves
use warnings;
use strict;

# this has to happen here because LWP::Simple creates a $ua
# on load so any time after this is too late.
BEGIN {
    delete @ENV{
        qw(
            HTTP_PROXY http_proxy CGI_HTTP_PROXY
            HTTPS_PROXY https_proxy HTTP_PROXY_ALL http_proxy_all
        )
    };
}

use Carp        qw( carp croak );
use File::Temp  ();
use LWP::Simple qw( get );
use Path::Tiny  qw( path );
use URI::URL    ();

=head1 SYNOPSIS

  use LWP::Simple qw(get);
  my $server = Test::HTTP::LocalServer->spawn;

  ok get $server->url, "Retrieve " . $server->url;

  $server->stop;

=head1 METHODS

=head2 C<Test::HTTP::LocalServer-E<gt>spawn %ARGS>

This spawns a new HTTP server. The server will stay running until C<< $server->stop >> is called.

Valid arguments are:

=over 4

=item *

C<< html => >> scalar containing the page to be served

=item *

C<< file => >> filename containing the page to be served

=item *

C<<  debug => 1 >> to make the spawned server output debug information

=item *

C<<  eval => >> string that will get evaluated per request in the server

Try to avoid characters that are special to the shell, especially quotes. A good idea for a slow
server would be

  eval => sleep+10

=back

All served HTML will have the first %s replaced by the current location.

The following entries will be removed from C<%ENV>:

    HTTP_PROXY
    http_proxy
    CGI_HTTP_PROXY
    HTTPS_PROXY
    https_proxy
    HTTP_PROXY_ALL
    http_proxy_all

=cut

sub spawn {
    my ( $class, %args ) = @_;
    my $self = {%args};
    bless $self, $class;

    local $ENV{TEST_HTTP_VERBOSE};
    $ENV{TEST_HTTP_VERBOSE} = 1
        if ( delete $args{debug} );

    $self->{delete} = [];
    if ( my $html = delete $args{html} ) {

        # write the html to a temp file
        my ( $fh, $tempfile ) = File::Temp::tempfile();
        binmode $fh;
        print $fh $html
            or die "Couldn't write tempfile $tempfile : $!";
        close $fh;
        push @{ $self->{delete} }, $tempfile;
        $args{file} = $tempfile;
    }
    my ( $fh, $logfile ) = File::Temp::tempfile();
    close $fh;
    push @{ $self->{delete} }, $logfile;
    $self->{logfile} = $logfile;
    my $web_page = delete $args{file} || q{};

    my $server_file = path('t/local/log-server')->absolute;
    my @opts;
    push @opts, "-e" => qq{"} . delete( $args{eval} ) . qq{"}
        if $args{eval};

    my $pid = open my $server,
        qq'$^X "$server_file" "$web_page" "$logfile" @opts|'
        or croak "Couldn't spawn local server $server_file : $!";
    my $url = <$server>;
    chomp $url;
    die "Couldn't read back local server url"
        unless $url;

    $self->{_server_url} = URI::URL->new($url);
    $self->{_fh}         = $server;
    $self->{_pid}        = $pid;

    $self;
}

=head2 C<< $server->port >>

This returns the port of the current server. As new instances will most likely run under a
different port, this is convenient if you need to compare results from two runs.

=cut

sub port {
    carp __PACKAGE__ . '::port called without a server'
        unless $_[0]->{_server_url};
    $_[0]->{_server_url}->port;
}

=head2 C<< $server->url >>

This returns the url where you can contact the server. This url is valid until the C<$server> goes
out of scope or you call C<< $server->stop >> or C<< $server->get_log >>.

=cut

sub url {
    $_[0]->{_server_url}->abs->as_string;
}

=head2 C<< $server->stop >>

This stops the server process by requesting a special url.

=cut

sub stop {
    my ($self) = @_;
    get( $self->quit_server );
    undef $self->{_server_url};
    if ( $self->{_fh} ) {
        close $self->{_fh};
        delete $self->{_fh};
    }
}

=head2 C<< $server->kill >>

This kills the server process via C<kill>. The log cannot be retrieved then.

=cut

sub kill {
    CORE::kill( 9 => $_[0]->{_pid} );
    undef $_[0]->{_server_url};
    undef $_[0]->{_pid};
}

=head2 C<< $server->get_log >>

This stops the server by calling C<stop> and then returns the output of the server process. This
output will be a list of all requests made to the server concatenated together as a string.

=cut

sub get_log {
    my ($self) = @_;

    my $log = get( $self->get_server_log );
    $self->stop;
    return $log;
}

sub DESTROY {
    $_[0]->stop if $_[0]->{_server_url};
    for my $file ( @{ $_[0]->{delete} } ) {
        unlink $file or warn "Couldn't remove tempfile $file : $!\n";
    }
}

=head1 URLs implemented by the server

=head2 302 redirect C<< $server->redirect($target) >>

This URL will issue a redirect to C<$target>. No special care is taken towards URL-decoding
C<$target> as not to complicate the server code. You need to be wary about issuing requests with
escaped URL parameters.

=head2 404 error C<< $server->error_notfound($target) >>

This URL will response with status code 404.

=head2 Timeout C<< $server->error_timeout($seconds) >>

This URL will send a 599 error after C<$seconds> seconds.

=head2 Timeout+close C<< $server->error_close($seconds) >>

This URL will send nothing and close the connection after C<$seconds> seconds.

=head2 Error in response content C<< $server->error_after_headers >>

This URL will send headers for a successfull response but will close the socket with an error after
2 blocks of 16 spaces have been sent.

=head2 Chunked response C<< $server->chunked >>

This URL will return 5 blocks of 16 spaces at a rate of one block per second in a chunked response.

=head2 Other URLs

All other URLs will echo back the cookies and query parameters.

=cut

my %urls = (
    'quit_server'         => 'quit_server',
    'get_server_log'      => 'get_server_log',
    'redirect'            => 'redirect/%s',
    'error_notfound'      => 'error/notfound/%s',
    'error_timeout'       => 'error/timeout/%s',
    'error_close'         => 'error/close/%s',
    'error_after_headers' => 'error/after_headers',
    'chunked'             => 'chunks',
);
for ( keys %urls ) {
    no strict 'refs';
    my $name = $_;
    *{$name} = sub {
        my $self = shift;
        $self->url . sprintf $urls{$name}, @_;
    };
}

=head1 EXPORT

None by default.

=head1 COPYRIGHT AND LICENSE

This library is free software; you can redistribute it and/or modify it under the same terms as
Perl itself.

Copyright (C) 2003-2011 Max Maischein

=head1 AUTHOR

Max Maischein, E<lt>corion@cpan.orgE<gt>

Please contact me if you find bugs or otherwise improve the module. More tests are also very
welcome !

=head1 SEE ALSO

L<WWW::Mechanize>,L<WWW::Mechanize::Shell>,L<WWW::Mechanize::Firefox>

=cut

1;