view release on metacpan or  search on metacpan

t/secure.t  view on Meta::CPAN

package main;

use 5.020;
use utf8;
use strict;
use warnings;
use experimental qw/ signatures /;
use bytes ();

use lib 'lib/', 't/lib';

use Test::More ('import' => [qw/ done_testing is ok use_ok plan /]);
use Test::Utils qw/ get_listen_socket start_server notify_parent /;

use Time::HiRes qw/ sleep /;
use IO::Socket::SSL qw/ SSL_VERIFY_NONE /;


my $host = '127.0.0.1';
my $processed_slots = 0;
my $request_timeout = 7.2;
my $connect_timeout = 6;
my $inactivity_timeout = 6.5;

BEGIN { use_ok('MojoX::HTTP::Async') };

sub on_start_cb ($port) {

    my $socket = get_listen_socket($host, $port, 1);
    my $default_response = "HTTP/1.1 200 OK\r\nContent-Length: 0\r\n\r\n";
    my %responses_by_request_number = (
        '01' => "HTTP/1.1 200 OK\r\nContent-Length: 10\r\n\r\n0123456789",
        '02' => "HTTP/1.1 200 OK\r\nContent-Length: 10\r\n\r\n9876543210",
    );

    notify_parent();

    while (1) {

        my $pid;
        my $client = $socket->accept();

        die("failed to accept or SSL handshake: ${!}, ${IO::Socket::SSL::SSL_ERROR}") if $!;
        sleep(0.1) && next if !$client;

        if ($pid = fork()) { # parent
            sleep(0.05);
        } elsif ($pid == 0) { # child
            close($socket);

            local $| = 1; # autoflush

            my $rh = '';
            vec($rh, fileno($client), 1) = 1;
            my ($wh, $eh) = ($rh) x 2;

            select($rh, undef, $eh, undef);

            die($!) if ( vec($eh, fileno($client), 1) != 0 );

            my $data = <$client>; # GET /page/01.html HTTP/1.1
            my ($page) = (($data // '') =~ m#^[A-Z]{3,}\s/page/([0-9]+)\.html#);
            my $response = $default_response;

            $response = $responses_by_request_number{$page} // $response if $page;
            $eh = $wh;

            select(undef, $wh, $eh, undef);

            die($!) if ( vec($eh, fileno($client), 1) != 0 );

            my $bytes = syswrite($client, $response, bytes::length($response), 0);

            warn("Can't send the response") if $bytes != bytes::length($response);

            sleep(0.1);
            close($client);
            exit(0);
        } else {
            die("Can't fork: $!");
        }
    }
}


my $server = start_server(\&on_start_cb, $host);
my $ua = MojoX::HTTP::Async->new(
    'host' => $host,
    'port' => $server->port,
    'slots' => 2,
    'connect_timeout' => $connect_timeout,
    'request_timeout' => $request_timeout,
    'ssl' => 1,
    'ssl_opts' => {
        'SSL_verify_mode' => &SSL_VERIFY_NONE,
    },
    'sol_socket' => {},
    'sol_tcp' => {},
    'inactivity_conn_ts' => $inactivity_timeout,
);

# there can be some connection issues on rare and specific OS due to their settings
eval { $ua->_make_connections(1); };