path: root/t/lib/TestServer.pm

package TestServer;

use strict;
use warnings;

use Encode ();
use Exporter qw(import);
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use IO::Socket::INET;
use JSON::PP ();
use POSIX ();
use Test::More ();

our @EXPORT_OK = qw(se_address csv_header csv_body json new_client);

my %REASON = (
    200 => 'OK',
    400 => 'Bad Request',
    404 => 'Not Found',
    429 => 'Too Many Requests',
    500 => 'Internal Server Error',
    502 => 'Bad Gateway',
    503 => 'Service Unavailable',
);

my $ENCODER = JSON::PP->new->canonical;

BEGIN {
    my $builder = Test::More->builder;
    binmode $builder->output,         ':encoding(UTF-8)';
    binmode $builder->failure_output, ':encoding(UTF-8)';
    binmode $builder->todo_output,    ':encoding(UTF-8)';
}

sub se_address {
    return {
        cep         => '01001000',
        logradouro  => "Pra\x{e7}a da S\x{e9}",
        complemento => "lado \x{ed}mpar",
        unidade     => '',
        bairro      => "S\x{e9}",
        localidade  => "S\x{e3}o Paulo",
        uf          => 'SP',
        estado      => "S\x{e3}o Paulo",
        regiao      => 'Sudeste',
        ibge        => '3550308',
        gia         => '1004',
        ddd         => '11',
        siafi       => '7107',
    };
}

sub csv_header {
    return 'cep,logradouro,complemento,unidade,bairro,localidade,uf,estado,'
        . 'regiao,ibge,gia,ddd,siafi';
}

sub csv_body {
    my (@rows) = @_;
    return join( "\n", csv_header(), @rows ) . "\n";
}

sub json {
    my ($data) = @_;
    return $ENCODER->encode($data);
}

sub new_client {
    my ( $server, %args ) = @_;
    require Cepis::Client;
    return Cepis::Client->new(
        base_url     => $server->url,
        timeout      => 5.0,
        backoff_base => 0.001,
        backoff_max  => 0.01,
        %args,
    );
}

sub new {
    my ( $class, %args ) = @_;

    my $listener = IO::Socket::INET->new(
        LocalAddr => '127.0.0.1',
        LocalPort => 0,
        Proto     => 'tcp',
        Listen    => 128,
        ReuseAddr => 1,
    ) or die "TestServer: cannot listen: $!";

    my $port = $listener->sockport;

    pipe( my $reader, my $writer ) or die "TestServer: pipe: $!";

    my $pid = fork();
    die "TestServer: fork: $!" unless defined $pid;

    if ( $pid == 0 ) {
        close $reader;
        _child( $listener, $writer, $args{routes} || {}, $args{handler} );
        POSIX::_exit(0);
    }

    close $writer;
    close $listener;

    my $flags = fcntl( $reader, F_GETFL, 0 );
    fcntl( $reader, F_SETFL, $flags | O_NONBLOCK );

    return bless {
        pid    => $pid,
        port   => $port,
        reader => $reader,
        buffer => '',
        calls  => [],
    }, $class;
}

sub url { return 'http://127.0.0.1:' . $_[0]->{port} }

sub calls {
    my ($self) = @_;
    $self->_drain;
    return @{ $self->{calls} };
}

sub count {
    my ( $self, $prefix ) = @_;
    $self->_drain;
    return scalar grep { index( $_, $prefix ) == 0 } @{ $self->{calls} };
}

sub stop {
    my ($self) = @_;
    return unless $self->{pid};
    $self->_drain;
    kill 'TERM', $self->{pid};
    waitpid $self->{pid}, 0;
    close $self->{reader};
    delete $self->{pid};
    return;
}

sub DESTROY {
    my ($self) = @_;
    local $@;
    eval { $self->stop; 1 };
    return;
}

sub _drain {
    my ($self) = @_;
    return unless $self->{reader};

    while (1) {
        my $chunk = '';
        my $read = sysread( $self->{reader}, $chunk, 65536 );
        last if !defined $read || $read == 0;
        $self->{buffer} .= $chunk;
    }
    while ( $self->{buffer} =~ s/\A([^\n]*)\n// ) {
        push @{ $self->{calls} }, $1;
    }
    return;
}

sub _child {
    my ( $listener, $writer, $routes, $handler ) = @_;

    local $SIG{PIPE} = 'IGNORE';
    $writer->autoflush(1);

    my %state = %$routes;
    my $seen  = 0;

    while (1) {
        my $socket = $listener->accept or next;
        binmode $socket;
        $socket->autoflush(1);

        my $line = <$socket>;
        if ( !defined $line ) {
            close $socket;
            next;
        }
        my $path = ( split /\s+/, $line )[1];
        $path = '' unless defined $path;

        my %request_headers;
        while ( my $header = <$socket> ) {
            last if $header eq "\r\n" || $header eq "\n";
            $request_headers{ lc $1 } = $2 if $header =~ /\A([^:]+):\s*(.*?)\s*\z/s;
        }

        $seen++;
        print {$writer} "$path\n";

        my ( $status, $body, $headers )
            = @{ _response_for( \%state, $handler, $path, $seen, \%request_headers ) };
        $body    = '' unless defined $body;
        $headers = {} unless defined $headers;

        my $bytes = Encode::encode( 'UTF-8', $body );
        my $head = sprintf "HTTP/1.1 %d %s\r\n", $status,
            ( $REASON{$status} || 'Unknown' );
        $head .= "$_: $headers->{$_}\r\n" for sort keys %$headers;
        $head .= "Content-Type: text/plain; charset=utf-8\r\n";
        $head .= 'Content-Length: ' . length($bytes) . "\r\n";
        $head .= "Connection: close\r\n\r\n";

        print {$socket} $head;
        print {$socket} $bytes;
        close $socket;
    }
    return;
}

sub _response_for {
    my ( $state, $handler, $path, $seen, $request_headers ) = @_;

    return $handler->( $path, $seen, $request_headers ) if $handler;

    my $response = $state->{$path};
    return [ 404, json( { erro => 'cep_nao_encontrado' } ), {} ]
        unless defined $response;

    return $response unless ref $response->[0] eq 'ARRAY';
    return @$response > 1 ? shift @$response : $response->[0];
}

1;

__END__

=encoding UTF-8

=head1 NAME

TestServer - a throwaway HTTP/1.1 server for the Cepis suite

=head1 DESCRIPTION

Brings up a real HTTP server on a random loopback port and points the client at
it through C<base_url>. Nothing in the suite touches the network and nothing
mocks L<HTTP::Tiny>: the code path exercised is the one that runs in production,
request construction and error body reading included.

Deliberately built on L<IO::Socket::INET> rather than on a web server from CPAN,
because the suite must run against a stock Perl with nothing installed.

The server runs in a forked child. Routes are set before the fork, so the child
inherits them; each request the child serves is written down a pipe, which is
what C<calls> and C<count> read back in the parent.

=head1 METHODS

=head2 new

    my $server = TestServer->new(
        routes  => { '/01001000' => [ 200, $body, {} ] },
        handler => sub { my ( $path, $n ) = @_; return [ 200, $body, {} ] },
    );

A route value is either a C<[ $status, $body, \%headers ]> triple or an arrayref
of them, in which case each request consumes the next one and the last repeats
once the list runs out — that is how retrying is tested. An unrouted path
answers 404.

C<handler> takes precedence over C<routes> and receives the path, the number of
requests served so far, and a hashref of the request headers with lowercased
names. The handler runs in the child, so the way to assert on a request header is
to return it in the body and check it in the parent.

Bodies are character strings; the child encodes them as UTF-8 and sets
C<Content-Length> from the encoded bytes.

=head2 url

The base URL to hand to C<< Cepis::Client->new >>.

=head2 calls

Every path requested so far, in order.

=head2 count

How many requests so far began with the given prefix.

=head2 stop

Stops the child and reaps it. Called automatically on destruction.

=head1 EXPORTABLE FUNCTIONS

C<se_address> (the CEP fixture used across the suite), C<csv_header>,
C<csv_body>, C<json> and C<new_client>.

=cut