view release on metacpan or  search on metacpan

lib/API/Docker.pm  view on Meta::CPAN

package API::Docker;
# ABSTRACT: Perl client for the Docker Engine API
our $VERSION = '0.004';
use Moo;
use Carp qw( croak );
use Log::Any qw( $log );

use API::Docker::API::System;
use API::Docker::API::Containers;
use API::Docker::API::Images;
use API::Docker::API::Networks;
use API::Docker::API::Volumes;
use API::Docker::API::Exec;
use API::Docker::API::Distribution;
use API::Docker::API::Secrets;
use API::Docker::API::Configs;
use API::Docker::API::Plugins;
use namespace::clean;


has host => (
  is      => 'ro',
  default => sub { $ENV{DOCKER_HOST} // 'unix:///var/run/docker.sock' },
);


has api_version => (
  is      => 'rwp',
  default => undef,
);


has tls => (
  is => 'lazy',
);

sub _build_tls {
  my ($self) = @_;

  # The docker CLI's own rule, read off cli/flags/options.go:
  #   dockerTLSVerify = os.Getenv(client.EnvTLSVerify) != ""
  # Every non-empty value turns TLS on, DOCKER_TLS_VERIFY=0 included. Perl
  # truthiness would read that '0' as off and disagree with the CLI on exactly
  # the value a user is most likely to type for "off", so the test is
  # defined-and-not-empty rather than a boolean one.
  return 0 unless defined $ENV{DOCKER_TLS_VERIFY}
    && $ENV{DOCKER_TLS_VERIFY} ne '';

  # And the CLI ignores TLS on a socket host without saying so
  # (cli/context/docker/load.go, "there's no need to configure TLS for a
  # socket connection"). Ignoring it here is not politeness: BUILD croaks on
  # tls => 1 with a non-tcp:// host, so a host-blind default would make a bare
  # API::Docker->new die on every unix:// machine that exports the variable.
  return $self->host =~ m{^tcp://} ? 1 : 0;
}


has cert_path => (
  is      => 'ro',
  default => sub { $ENV{DOCKER_CERT_PATH} },
);


has tls_insecure => (
  is      => 'ro',
  default => 0,
);


sub BUILD {
  my ($self) = @_;

  # Both checks are here rather than at connect time so that a request for
  # encryption that cannot be honoured is refused before the caller has a
  # client to hand credentials to.
  croak __PACKAGE__ . '->new tls_insecure => 1 without tls => 1 does '
    . 'nothing: verification is only reachable on a connection that has TLS '
    . 'to verify. Set tls => 1 as well, or drop the option'
    if $self->tls_insecure && !$self->tls;

  return unless $self->tls;

  my $host = $self->host;
  croak __PACKAGE__ . '->new tls => 1 is only meaningful for a tcp:// host, '
    . 'and this one is ' . $host . '. A Unix socket is a file rather than a '
    . 'wire and carries nothing to encrypt, so honouring the option is not '
    . 'possible and ignoring it would answer a request for an encrypted '
    . 'transport with an unencrypted one'
    unless $host =~ m{^tcp://};
}

has _version_negotiated => (
  is      => 'rw',
  default => 0,
);

with 'API::Docker::Role::HTTP';

has system => (
  is      => 'lazy',
  builder => sub { API::Docker::API::System->new(client => $_[0]) },
);


has containers => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Containers->new(client => $_[0]) },
);


has images => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Images->new(client => $_[0]) },
);


has networks => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Networks->new(client => $_[0]) },
);


has volumes => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Volumes->new(client => $_[0]) },
);


has exec => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Exec->new(client => $_[0]) },
);


has distribution => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Distribution->new(client => $_[0]) },
);


has secrets => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Secrets->new(client => $_[0]) },
);


has configs => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Configs->new(client => $_[0]) },
);


has plugins => (
  is      => 'lazy',
  builder => sub { API::Docker::API::Plugins->new(client => $_[0]) },
);


sub negotiate_version {
  my ($self, %opts) = @_;
  return if $self->_version_negotiated;
  return if defined $self->api_version;

  $log->debug("Auto-negotiating API version");
  my $version_info = $self->_request('GET', '/version',
    exists $opts{read_timeout} ? ( read_timeout => $opts{read_timeout} ) : (),
    exists $opts{connect_timeout} ? ( connect_timeout => $opts{connect_timeout} ) : (),
  );

  # The ApiVersion is put straight into every later request path (/v1.44/...),
  # so it has to be a JSON object carrying one of the form N.N -- nothing else
  # can be trusted there. Three ways a body fails that, each measured against a
  # fake daemon: a non-object body reached strict refs ('garbage' died with
  # "Can't use string as a HASH ref", [1] with "Not a HASH reference"); an
  # object with no ApiVersion set _version_negotiated and then sent every
  # request unversioned; and an ApiVersion copied verbatim let 'v1.44/../x'
  # become "GET /vv1.44/../x/info". One croak, naming the endpoint and the
  # shape, covers all of them.
  my $got;
  if (!defined $version_info) {
    $got = 'nothing';
  }
  elsif (ref $version_info ne 'HASH') {
    $got = ref $version_info ? 'a ' . ref($version_info) . ' reference'
      : "the non-object body '" . $version_info . "'";
  }
  elsif (!defined $version_info->{ApiVersion}) {
    $got = 'an object with no ApiVersion field';
  }
  else {
    my $v = $version_info->{ApiVersion};
    $got = 'an ApiVersion of '
      . (ref $v ? 'a ' . ref($v) . ' reference' : "'" . $v . "'");
  }

  croak __PACKAGE__ . '->negotiate_version: GET /version must answer with a '
    . 'JSON object carrying an ApiVersion of the form N.N (e.g. "1.44"); got '
    . $got
    unless ref $version_info eq 'HASH'
      && defined $version_info->{ApiVersion}
      && !ref $version_info->{ApiVersion}
      && $version_info->{ApiVersion} =~ /^\d+\.\d+$/;

  $self->_set_api_version($version_info->{ApiVersion});
  $log->debugf("Negotiated API version: %s", $version_info->{ApiVersion});
  $self->_version_negotiated(1);
}


around _request => sub {
  my ($orig, $self, $method, $path, %opts) = @_;

  # Auto-negotiate before any versioned request, but not for /version itself.
  # The triggering request's own bounds are handed to it: the negotiation is a
  # pre-flight the caller never wrote, and a caller who asked for a bound and
  # then hung in GET /version has been told something untrue (karr k72).
  if ($path ne '/version' && !defined $self->api_version && !$self->_version_negotiated) {
    $self->negotiate_version(
      exists $opts{read_timeout} ? ( read_timeout => $opts{read_timeout} ) : (),
      exists $opts{connect_timeout} ? ( connect_timeout => $opts{connect_timeout} ) : (),
    );
  }

  return $self->$orig($method, $path, %opts);
};


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

API::Docker - Perl client for the Docker Engine API

=head1 VERSION

version 0.004

=head1 SYNOPSIS

    use API::Docker;

    # Connect to local Docker daemon via Unix socket
    my $docker = API::Docker->new;

    # Or connect to remote Docker daemon
    my $docker = API::Docker->new(
        host => 'tcp://192.168.1.100:2375',
    );

    # System information
    my $info = $docker->system->info;
    my $version = $docker->system->version;

    # Container management -- list/inspect return generated
    # API::Docker::Type::* objects with snake_case accessors, not hashrefs
    my $containers = $docker->containers->list(all => 1);
    for my $container (@$containers) {
        say $container->id;
        say $container->status;
    }

    my $result = $docker->containers->create(
        Image => 'nginx:latest',
        name  => 'my-nginx',