diff options
Diffstat (limited to 't/lib')
| -rw-r--r-- | t/lib/TestServer.pm | 298 |
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 |