view release on metacpan or  search on metacpan

t/tls_read.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More;
use Config;
use Path::Tiny;
use Time::HiRes qw( time sleep );
use API::Docker;
use API::Docker::Error::Timeout;

# karr k65. t/tls.t covers option assembly, certificate selection and the
# handshake; nothing in the suite ever reads a byte over TLS. This file is
# that read path, pinned against the three measurements taken by hand
# during the transport rebuild (karr k60), before and after, identical both
# times:
#
#   three writes 0.15s apart      -> 3 on_chunk calls, spaced apart
#   100000 bytes over many records -> every byte arrives, none lost
#   delivered, then silent, read_timeout 1 -> Error::Timeout after ~1s,
#     phase 'read', summary delivered=1, the bytes already with the callback
#
# It matters here specifically because TLS is the one transport where a
# short read is the normal case -- one plaintext record (<= 16384 bytes,
# RFC 8446 5.1) per sysread -- so the "a short read is not an end of
# stream" rule this role depends on (see _pull in
# API::Docker::Role::HTTP) has no margin to be wrong in. And
# IO::Socket::SSL's own read/sysread split -- ssl_read_all on a blocking
# socket for read(), a single Net::SSLeay::read for sysread() -- is exactly
# the distinction karr k60 is built on: get the wrong one and either every
# read blocks until the daemon closes, or a stall never times out.
#
# Certificate: generated fresh per run rather than checked in under t/, the
# same choice t/tls.t already made for the same reason -- a stored
# certificate is deterministic but expires, and CERT_create costs single-
# digit milliseconds. Gated on IO::Socket::SSL the same way t/tls.t gates
# it: a recommended, not a required, dependency, so its absence is
# skip_all rather than a failure.
#
# The server below is a forked, real TCP/TLS listener on 127.0.0.1 -- no
# Docker daemon, no network beyond loopback. Every child this file starts
# is reaped by the subtest that started it and, as a backstop for a test
# that dies before reaching that reap, by the END block at the bottom: a
# leaked server process left sleeping is worse than a missing test.

my $HAVE_SSL   = eval { require IO::Socket::SSL; 1 };
my $HAVE_UTILS = $HAVE_SSL && eval { require IO::Socket::SSL::Utils; 1 };

plan skip_all => 'IO::Socket::SSL is not installed (recommended, not '
  . 'required -- see API::Docker::Role::HTTP)' unless $HAVE_SSL;
plan skip_all => 'IO::Socket::SSL::Utils cannot generate certificates'
  unless $HAVE_UTILS;
plan skip_all => 'no fork on this platform' unless $Config{d_fork};

# ---------------------------------------------------------------------------
# One CA and one server leaf certificate, reused by every subtest below.
# ---------------------------------------------------------------------------

my $dir = Path::Tiny->tempdir;
my ($ca, $cakey) = IO::Socket::SSL::Utils::CERT_create(
  CA => 1, subject => { CN => 'API-Docker TLS-read test CA' });
my ($server_cert, $server_key) = IO::Socket::SSL::Utils::CERT_create(
  issuer          => [$ca, $cakey],
  subject         => { CN => 'localhost' },
  purpose         => 'server',
  subjectAltNames => [ [ DNS => 'localhost' ], [ IP => '127.0.0.1' ] ],
);
IO::Socket::SSL::Utils::PEM_cert2file($ca, $dir->child('ca.pem') . '');
IO::Socket::SSL::Utils::PEM_cert2file($server_cert, $dir->child('server.pem') . '');
IO::Socket::SSL::Utils::PEM_key2file($server_key, $dir->child('server-key.pem') . '');

# ---------------------------------------------------------------------------
# A TLS server that speaks whatever $respond->($conn) tells it to, once per
# connection. Forked so the parent's read is a real client of a real socket
# rather than a mock -- the whole point of this file.
# ---------------------------------------------------------------------------

my @CHILDREN;

sub start_server {
  my ($respond) = @_;

  my $listen = IO::Socket::INET->new(
    LocalAddr => '127.0.0.1', LocalPort => 0, Listen => 1, ReuseAddr => 1,
  ) or die "listen: $!";
  my $port = $listen->sockport;

  my $pid = fork;