view release on metacpan or  search on metacpan

t/tls.t  view on Meta::CPAN

  like $err, qr/only meaningful for a tcp:\/\/ host/, 'it says which half is wrong';
  like $err, qr/unix:\/\/\/var\/run\/docker\.sock/, 'and names the host it got';
  like $err, qr/ at \S+ line \d+/, 'croaked, so the caller\'s line is named';
};

subtest 'tls_insecure without tls croaks' => sub {
  # Only reachable while tls is off, and the default is read from the
  # environment now, so the environment is what this subtest pins first.
  delete local $ENV{DOCKER_TLS_VERIFY};

  my $err = do {
    local $@;
    eval { client(tls_insecure => 1) };
    $@;
  };
  like $err, qr/tls_insecure => 1 without tls => 1/,
    'an option that could not do anything is refused, not accepted quietly';

  is client()->tls_insecure, 0, 'the default is off';
  is client(tls => 1, tls_insecure => 1)->tls_insecure, 1,
    'and it is settable alongside tls';
};

subtest 'cert_path on its own still transmits nothing' => sub {
  # Kept from the file this replaces, and still true: cert_path defaults from
  # DOCKER_CERT_PATH, which machines running the docker CLI export, so it must
  # not change anything for a client that never asked for TLS.
  delete local $ENV{DOCKER_TLS_VERIFY};
  my $docker = eval { client(cert_path => '/etc/docker/certs') };
  is $@, '', 'no croak, even though the path does not exist';
  is $docker->cert_path, '/etc/docker/certs', 'the value is kept';
  is $docker->tls, 0, 'and TLS is still off, so nothing reads it';

  local $ENV{DOCKER_CERT_PATH} = '/from/env';
  my $from_env = eval { API::Docker->new(api_version => '1.41') };
  is $@, '', 'a machine with DOCKER_CERT_PATH set still constructs';
  is $from_env->cert_path, '/from/env', 'defaulted from the environment';
};

# ===========================================================================
# The transport now reads both attributes
# ===========================================================================

subtest 'the transport consults tls and cert_path' => sub {
  # The inverse of the claim this replaces, which asserted that
  # API::Docker::Role::HTTP never mentions either attribute and that its
  # tcp:// branch is unconditionally a plain socket.
  my $source = path($INC{'API/Docker/Role/HTTP.pm'})->slurp_utf8;

  ok length($source) > 1000, 'the transport source was actually read';
  like $source, qr/\$self->tls\b/, 'the socket builder asks whether TLS is wanted';
  like $source, qr/\$self->cert_path\b/, 'and reads the certificate directory';
  like $source, qr/IO::Socket::SSL->new/, 'the tcp:// branch can be an SSL socket';
  like $source, qr/IO::Socket::INET->new/, 'and is still a plain one without TLS';
};

SKIP: {
  skip 'IO::Socket::SSL is not installed', 4 unless $HAVE_SSL;

  subtest 'verification is the default' => sub {
    my %ssl = client(tls => 1)->_ssl_options('dockerhost');

    is $ssl{SSL_verify_mode}, IO::Socket::SSL::SSL_VERIFY_PEER(),
      'the certificate chain is checked';
    is $ssl{SSL_verifycn_scheme}, 'http',
      'and so is the name on it: a valid certificate for another host is not '
      . 'this host';
    is $ssl{SSL_verifycn_name}, 'dockerhost', 'checked against the host asked for';
    is $ssl{SSL_hostname}, 'dockerhost', 'which is also sent as SNI';

    ok !exists $ssl{SSL_ca_file}, 'no ca file without a cert_path';
    ok !exists $ssl{SSL_cert_file}, 'and no client certificate';
  };

  subtest 'tls_insecure turns verification off, and only that' => sub {
    my %ssl = client(tls => 1, tls_insecure => 1)->_ssl_options('dockerhost');

    is $ssl{SSL_verify_mode}, IO::Socket::SSL::SSL_VERIFY_NONE(),
      'the chain is not checked';
    is $ssl{SSL_verifycn_scheme}, undef, 'nor the name';
    is $ssl{SSL_hostname}, 'dockerhost',
      'SNI is still sent: a terminator serving several names needs it either way';
  };

  subtest 'the cert.pem / key.pem / ca.pem layout' => sub {
    my $dir = Path::Tiny->tempdir;
    $dir->child($_)->spew('') for qw( ca.pem cert.pem key.pem );

    my %ssl = client(tls => 1, cert_path => "$dir")->_ssl_options('dockerhost');
    is $ssl{SSL_ca_file}, $dir->child('ca.pem') . '', 'ca.pem is the trust anchor';
    is $ssl{SSL_cert_file}, $dir->child('cert.pem') . '', 'cert.pem is sent';
    is $ssl{SSL_key_file}, $dir->child('key.pem') . '', 'with key.pem';
    is $ssl{SSL_verify_mode}, IO::Socket::SSL::SSL_VERIFY_PEER(),
      'and having certificates does not change the verification policy';

    my $ca_only = Path::Tiny->tempdir;
    $ca_only->child('ca.pem')->spew('');
    my %anchor = client(tls => 1, cert_path => "$ca_only")->_ssl_options('dockerhost');
    is $anchor{SSL_ca_file}, $ca_only->child('ca.pem') . '', 'ca.pem alone is used';
    ok !exists $anchor{SSL_cert_file},
      'and is a daemon this client verifies without authenticating to it';

    my $client_only = Path::Tiny->tempdir;
    $client_only->child($_)->spew('') for qw( cert.pem key.pem );
    my %pair = client(tls => 1, cert_path => "$client_only")->_ssl_options('dockerhost');
    ok !exists $pair{SSL_ca_file},
      'no ca.pem falls back to the system trust store rather than croaking';
    is $pair{SSL_cert_file}, $client_only->child('cert.pem') . '',
      'while the client certificate is still sent';
  };

  subtest 'the layouts that are mistakes' => sub {
    for my $half (['cert.pem', 'key.pem'], ['key.pem', 'cert.pem']) {
      my ($present, $missing) = @$half;
      my $dir = Path::Tiny->tempdir;
      $dir->child($present)->spew('');
      my $err = do {
        local $@;
        eval { client(tls => 1, cert_path => "$dir")->_ssl_options('dockerhost') };
        $@;
      };
      like $err, qr/\Q$missing\E missing/,
        "$present without $missing croaks, naming the half that is gone";
      like $err, qr/Both cert\.pem and key\.pem are needed, or neither/,
        'and says what a complete client certificate is';
    }

    my $err = do {
      local $@;
      eval { client(tls => 1, cert_path => '/no/such/certificate/directory')
        ->_ssl_options('dockerhost') };
      $@;
    };
    like $err, qr{cert_path /no/such/certificate/directory is not a directory},
      'a cert_path naming nothing croaks rather than connecting without the '
      . 'certificates the caller believes are in use';
  };
}

subtest 'IO::Socket::SSL is a recommended dependency, and says so when absent' => sub {
  # It is required at the moment the first TLS connection is opened, not at
  # compile time, because the unix:// transport never needs it. Simulated by
  # hiding it from require rather than by uninstalling it.
  my $err = do {
    local %INC = %INC;
    delete $INC{'IO/Socket/SSL.pm'};
    local @INC = (sub {
      my (undef, $filename) = @_;
      die "Can't locate $filename in \@INC\n" if $filename eq 'IO/Socket/SSL.pm';
      return;
    }, @INC);
    local $@;
    eval { client(tls => 1)->_load_ssl };
    $@;
  };

  like $err, qr/needs IO::Socket::SSL/, 'the croak names the module';
  like $err, qr/cpanm IO::Socket::SSL/, 'and how to install it';
  like $err, qr/recommended rather than a required/,
    'and why it was not there already';
};

# ===========================================================================
# A real handshake, against a TLS server this file starts
# ===========================================================================

SKIP: {
  skip 'IO::Socket::SSL is not installed', 1 unless $HAVE_SSL;
  skip 'IO::Socket::SSL::Utils cannot generate certificates', 1
    unless eval { require IO::Socket::SSL::Utils; 1 };
  skip 'no fork on this platform', 1 unless $Config{d_fork};

  my $dir = Path::Tiny->tempdir;
  my ($ca, $cakey) = IO::Socket::SSL::Utils::CERT_create(
    CA => 1, subject => { CN => 'API-Docker test CA' });
  my ($server, $server_key) = IO::Socket::SSL::Utils::CERT_create(
    issuer          => [$ca, $cakey],
    subject         => { CN => 'localhost' },
    purpose         => 'server',
    subjectAltNames => [ [ DNS => 'localhost' ], [ IP => '127.0.0.1' ] ],
  );
  my ($other, $other_key) = IO::Socket::SSL::Utils::CERT_create(
    issuer          => [$ca, $cakey],
    subject         => { CN => 'otherhost.example' },
    purpose         => 'server',
    subjectAltNames => [ [ DNS => 'otherhost.example' ] ],
  );
  my ($cert, $key) = IO::Socket::SSL::Utils::CERT_create(
    issuer => [$ca, $cakey], subject => { CN => 'a-client' }, purpose => 'client');

  IO::Socket::SSL::Utils::PEM_cert2file($ca, $dir->child('ca.pem') . '');
  IO::Socket::SSL::Utils::PEM_cert2file($cert, $dir->child('cert.pem') . '');
  IO::Socket::SSL::Utils::PEM_key2file($key, $dir->child('key.pem') . '');
  IO::Socket::SSL::Utils::PEM_cert2file($server, $dir->child('server.pem') . '');
  IO::Socket::SSL::Utils::PEM_key2file($server_key, $dir->child('server-key.pem') . '');
  IO::Socket::SSL::Utils::PEM_cert2file($other, $dir->child('other.pem') . '');
  IO::Socket::SSL::Utils::PEM_key2file($other_key, $dir->child('other-key.pem') . '');

  # One connection, one canned /version response, and the client certificate
  # CN the server saw handed back over a pipe.
  my $serve = sub {
    my (%o) = @_;
    my $listen = IO::Socket::INET->new(LocalAddr => '127.0.0.1', LocalPort => 0,
      Listen => 1, ReuseAddr => 1) or die "listen: $!";
    my $port = $listen->sockport;
    pipe(my $read, my $write) or die "pipe: $!";
    my $pid = fork;
    die "fork: $!" unless defined $pid;
    if (!$pid) {
      close $read;
      my $conn = $listen->accept;
      if ($conn && IO::Socket::SSL->start_SSL($conn,
        SSL_server    => 1,