1 files changed, 298 insertions, 0 deletions
diff --git a/t/lib/TestServer.pm b/t/lib/TestServer.pm
new file mode 100644
index 0000000..5a1acda
--- /dev/null
+++ b/t/lib/TestServer.pm
@@ -0,0 +1,298 @@
+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