view release on metacpan or  search on metacpan

t/role_http.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More;
use FindBin;
use lib "$FindBin::Bin/lib";
use JSON::MaybeXS qw( encode_json decode_json );
use API::Docker;
use Test::API::Docker::FakeTransport;

# API::Docker::Role::HTTP sits below _request as far as Test::API::Docker::Mock
# is concerned -- the mock replaces _request wholesale, so request-line
# assembly, header sanitising, chunked reading, status handling and the
# >=400 croak path are exercised by nothing but use_ok in t/basic.t.
#
# Nothing here opens a real socket or reaches a daemon: the socket-facing
# methods (_read_response, _read_chunked) are driven directly over a tied
# filehandle, and _request itself is driven through a subclass that fakes the
# socket instead of connecting one. So this file needs no is_live()/can_write()
# gating -- it is unconditionally safe with no Docker installed.

# ---------------------------------------------------------------------------
# A tied filehandle serving a fixed string, with a step: 0 hands over
# everything that is left in one call, a positive N hands over at most N bytes
# per call, so "a chunk arriving in several reads" is a real multi-call
# scenario for _read_chunked's inner while loop rather than one read that
# happens to satisfy the whole request.
#
# This used to be an in-memory scalar filehandle (open $fh, '<', \$str) for
# everything but the multi-read case. It cannot be one any more: since karr k60
# the transport reads with sysread, and sysread on a scalar filehandle fails
# outright -- measured, it returns undef with EBADF, because such a handle has
# no file descriptor (fileno is -1). A tied handle is the shape that works for
# both, and it also makes the step explicit rather than inherited from
# PerlIO::scalar's own behaviour.
package Test::RoleHTTP::PartialReader;

sub TIEHANDLE {
  my ($class, $data, $step) = @_;
  return bless { buf => $data, pos => 0, step => defined $step ? $step : 0 },
    $class;
}

sub READ {
  my $self   = $_[0];
  my $len    = $_[2];
  my $offset = $_[3] || 0;
  my $avail  = length($self->{buf}) - $self->{pos};
  return 0 if $avail <= 0;
  my $n = $len;
  $n = $self->{step} if $self->{step} && $n > $self->{step};
  $n = $avail if $n > $avail;
  my $chunk = substr($self->{buf}, $self->{pos}, $n);
  if ($offset) {
    substr($_[1], $offset, $n) = $chunk;
  }
  else {
    $_[1] = $chunk;
  }
  $self->{pos} += $n;
  return $n;
}

sub CLOSE { 1 }

package main;

# A handle over $data. Anonymous, so several can be alive at once and none
# needs untying.
sub string_handle {
  my ($data, $step) = @_;
  my $fh = \do { no warnings 'once'; local *HANDLE };
  tie *$fh, 'Test::RoleHTTP::PartialReader', $data, $step;
  return $fh;
}

# What the transport has read off a handle but not yet consumed. Since karr k60
# the read-ahead past a header block lands here instead of in PerlIO's own
# buffer, which is what makes "these bytes were not swallowed" answerable.
sub unconsumed {
  my ($client, $fh) = @_;
  return ${ $client->_read_buffer($fh) };
}

my $client = API::Docker->new(
  host        => 'unix:///nonexistent.sock',
  api_version => '1.41',
);

# ---------------------------------------------------------------------------
subtest '_read_response: status line parsing' => sub {
  my $fh = string_handle("HTTP/1.1 204 No Content\r\n\r\n");
  my $resp = $client->_read_response($fh);
  is $resp->[0], 204, 'status code';
  is $resp->[1], 'No Content', 'status text, including the embedded space';
};

subtest '_read_response: header collection' => sub {
  my $raw = "HTTP/1.1 200 OK\r\n"
    . "Content-Type: application/json\r\n"
    . "X-Mixed-CASE:   value with spaces  \r\n"
    . "Content-Length: 2\r\n"
    . "\r\n"
    . "{}";
  my $fh = string_handle($raw);
  my $resp = $client->_read_response($fh);
  my $headers = $resp->[2];

  is $headers->{'content-type'}, 'application/json',
    'an already-lowercase key is kept';
  is $headers->{'x-mixed-case'}, 'value with spaces  ',
    'a mixed-case key is lowercased; leading space after the colon is '
    . 'trimmed, the rest of the value is kept verbatim (trailing spaces too)';
  is $headers->{'content-length'}, '2', 'colon splits key from value';
  is $resp->[3], '{}', 'body still decoded via content-length';
};

subtest '_read_response: chunked body' => sub {
  my $raw = "HTTP/1.1 200 OK\r\n"
    . "Transfer-Encoding: chunked\r\n"
    . "\r\n"
    . "5\r\nhello\r\n"
    . "6\r\n world\r\n"
    . "0\r\n\r\n";
  my $fh = string_handle($raw);
  my $resp = $client->_read_response($fh);
  is $resp->[3], 'hello world', 'chunks concatenated, chunk framing stripped';
};

subtest '_read_response: content-length body' => sub {
  # Embedded CRLF and a NUL byte prove this is a byte-exact length read, not
  # a line-oriented one.
  my $body = "line1\r\nline2\x00tail";
  my $raw = 'HTTP/1.1 200 OK' . "\r\n"
    . 'Content-Length: ' . length($body) . "\r\n"
    . "\r\n"
    . $body;
  my $fh = string_handle($raw);
  my $resp = $client->_read_response($fh);
  is $resp->[3], $body,
    'exactly content-length bytes read, embedded CRLF/NUL preserved';
};

subtest '_read_response: read-to-EOF fallback' => sub {
  # Neither Transfer-Encoding nor Content-Length -- the pre-HTTP/1.1-ish
  # case where the body is "whatever remains until the connection closes".
  my $raw = "HTTP/1.1 200 OK\r\n"
    . "Connection: close\r\n"
    . "\r\n"
    . "no length header, read until eof";
  my $fh = string_handle($raw);
  my $resp = $client->_read_response($fh);
  is $resp->[3], 'no length header, read until eof',
    'falls back to slurping the rest of the socket';
};

# ---------------------------------------------------------------------------
# HTTP field values are case-insensitive (RFC 9110 section 5.6.2). A daemon or
# a proxy in front of it may write Transfer-Encoding in any case; the value is
# compared with lc() so that a body announced as chunked is dechunked whatever
# the spelling. Before this, a value that was not exactly 'chunked' fell
# through to the close-delimited branch and the raw chunk framing came back as
# the body.
subtest '_read_response: Transfer-Encoding is matched case-insensitively'
  => sub {
  for my $spelling (qw( Chunked CHUNKED chUNKed )) {
    my $raw = "HTTP/1.1 200 OK\r\n"
      . "Transfer-Encoding: $spelling\r\n"
      . "\r\n"
      . "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\n";
    my $resp = $client->_read_response(string_handle($raw));
    is $resp->[3], 'hello world',
      "Transfer-Encoding: $spelling is dechunked, not returned as framing";
  }
};

subtest 'the streaming reader dechunks a case-varied Transfer-Encoding too'
  => sub {
  my @got;
  my $handler = $client->_stream_handler('GET /v1.41/events', 'on_event',
    sub { push @got, $_[0] }, 0);
  my $raw = "HTTP/1.1 200 OK\r\n"
    . "Transfer-Encoding: Chunked\r\n"
    . "\r\n"
    . qq(11\r\n{"status":"one"}\n\r\n)
    . qq(11\r\n{"status":"two"}\n\r\n)
    . "0\r\n\r\n";
  $client->_read_streaming_response(string_handle($raw), 'GET', $handler, {});
  is_deeply [ map { ref $_ eq 'HASH' ? $_->{status} : $_ } @got ],
    [qw( one two )],
    'exactly the two events, not the chunk framing decoded line by line';
};

# ---------------------------------------------------------------------------
# A 1xx informational response (100 Continue, 103 Early Hints, ...) is a whole
# head with no body, sent before the real response (RFC 9110 section 15.2). It
# is read and discarded so the reader continues with the real response rather
# than taking the 1xx status and reading the real response as its body.
subtest '_read_response: a 1xx informational response is skipped' => sub {
  my $raw = "HTTP/1.1 100 Continue\r\n\r\n"
    . "HTTP/1.1 200 OK\r\n"
    . "Content-Length: 2\r\n\r\n"
    . "{}";
  my $resp = $client->_read_response(string_handle($raw));
  is $resp->[0], 200, 'the real status is returned, not the 100';
  is $resp->[1], 'OK', 'and its reason';
  is $resp->[3], '{}', 'and the real body, not the second response as bytes';
};

subtest '_read_response: several stacked 1xx heads are all skipped' => sub {
  my $raw = "HTTP/1.1 100 Continue\r\n\r\n"
    . "HTTP/1.1 103 Early Hints\r\nLink: </x>; rel=preload\r\n\r\n"
    . "HTTP/1.1 204 No Content\r\n\r\n";
  my $resp = $client->_read_response(string_handle($raw));
  is $resp->[0], 204, 'the first non-1xx status wins';
};

subtest 'the streaming reader skips a 1xx before the stream too' => sub {
  my @got;
  my $handler = $client->_stream_handler('GET /v1.41/events', 'on_event',
    sub { push @got, $_[0] }, 0);
  my $raw = "HTTP/1.1 100 Continue\r\n\r\n"
    . "HTTP/1.1 200 OK\r\n"
    . "Transfer-Encoding: chunked\r\n\r\n"
    . qq(11\r\n{"status":"one"}\n\r\n)
    . "0\r\n\r\n";
  my $res = $client->_read_streaming_response(
    string_handle($raw), 'GET', $handler, {});
  is $res->[0], 200, 'the stream reader also passes the 100 by';
  is_deeply [ map { $_->{status} } @got ], ['one'],
    'and the real event reaches the callback';
};

# ---------------------------------------------------------------------------
subtest '_read_chunked: hex sizes, upper and lower case' => sub {
  # 'a' and 'A' are both 10 -- hex() is case-insensitive, and so must this be.
  my $raw = "a\r\n0123456789\r\nA\r\nABCDEFGHIJ\r\n0\r\n\r\n";
  my $fh = string_handle($raw);
  is $client->_read_chunked($fh), '0123456789ABCDEFGHIJ',
    'lowercase and uppercase hex chunk sizes both read correctly';
};

subtest '_read_chunked: a single zero-size chunk terminates immediately' => sub {
  my $fh = string_handle("0\r\n\r\n");
  is $client->_read_chunked($fh), '', 'empty body, no chunks';
};

subtest '_read_chunked: a chunk arriving in several reads' => sub {
  my $data = "b\r\nhello world\r\n0\r\n\r\n"; # 'b' hex = 11 = length("hello world")
  tie *FH, 'Test::RoleHTTP::PartialReader', $data, 3; # 3 bytes per read() call
  my $body = $client->_read_chunked(\*FH);
  is $body, 'hello world',
    'chunk payload reassembled correctly across multiple short reads';
  untie *FH;
};

# ---------------------------------------------------------------------------
subtest '_uri_encode: what it escapes and what it leaves alone' => sub {
  # Called as a bare function everywhere in the module (see _request's
  # query-string assembly) -- not as a method. Calling it as $client->
  # _uri_encode(...) would silently shift $client into the $str slot, since
  # the sub only unpacks a single positional argument.
  my $encode = \&API::Docker::Role::HTTP::_uri_encode;

  is $encode->('alpine:latest'), 'alpine:latest',
    'colon is left raw -- image references keep their tag separator';
  is $encode->('myrepo/app:v1'), 'myrepo/app:v1',
    'slash is left raw too -- image references keep their path shape';
  is $encode->('abcXYZ019-_.~'), 'abcXYZ019-_.~',
    'unreserved characters (alnum - _ . ~) are never escaped';
  is $encode->('a b'), 'a%20b', 'space is percent-encoded';
  is $encode->('foo?bar=baz'), 'foo%3Fbar%3Dbaz',
    '? and = are percent-encoded';
  is $encode->('100%'), '100%25', 'a literal percent sign is escaped itself';
  is $encode->("a\nb"), 'a%0Ab', 'control characters are escaped, not passed through';

  # A character string -- what a name/tag/author/comment/search term arrives as
  # under `use utf8` or through a :utf8 layer -- is escaped by its UTF-8 bytes,
  # not by its codepoint. The old code took ord() of the character, so 'ü'
  # became %FC (not even valid UTF-8) and '中' became %4E2D.
  is $encode->("\x{4E2D}"), '%E4%B8%AD',
    'a wide character is escaped by its UTF-8 bytes, not its codepoint';
  {
    my $u = "\x{00FC}";
    utf8::upgrade($u); # what a decoded 'ü' is: codepoint 252, the utf8 flag on
    is $encode->($u), '%C3%BC',
      'a Latin-1 character with the utf8 flag is UTF-8 encoded before escaping';
  }

  # The other half, and the reason the encoding is not unconditional: a byte
  # string is already octets and must be escaped as-is. encode_json hands a
  # HASH param (filters among them) its UTF-8 bytes, and re-encoding those would
  # turn %C3%BC into %C3%83%C2%BC -- trading this bug for a broader one.
  is $encode->("\xC3\xBC"), '%C3%BC',
    'a byte string of UTF-8 octets is escaped as-is, never double-encoded';
};

# ---------------------------------------------------------------------------
subtest '_request: assembles the request line, headers and body' => sub {
  my $t = Test::API::Docker::FakeTransport->new(
    host        => 'unix:///nonexistent.sock',
    api_version => '1.41',
  );

  subtest 'plain GET, no body' => sub {
    $t->_request('GET', '/containers/json');
    my $req = $t->written;
    like $req, qr{\AGET /v1\.41/containers/json HTTP/1\.1\r\n},
      'method, versioned path, and protocol on the request line';
    like $req, qr{Host: localhost\r\n}, 'Host header sent';
    like $req, qr{Connection: close\r\n}, 'Connection: close sent';
    like $req, qr{User-Agent: API-Docker\r\n}, 'User-Agent sent';
    unlike $req, qr{Content-Type}, 'no Content-Type without a body';
    unlike $req, qr{Content-Length}, 'no Content-Length without a body';
    like $req, qr{\r\n\r\n\z}, 'request ends on the blank line, empty body';
  };

  subtest 'POST with a JSON body' => sub {
    $t->_request('POST', '/containers/create', body => { Image => 'alpine:3' });
    my $req = $t->written;
    my $encoded = encode_json({ Image => 'alpine:3' });
    like $req, qr{\APOST /v1\.41/containers/create HTTP/1\.1\r\n},
      'request line for the POST';
    like $req, qr{Content-Type: application/json\r\n}, 'JSON content type';
    like $req, qr{Content-Length: @{[ length $encoded ]}\r\n},
      'content-length matches the encoded body';
    like $req, qr{\r\n\r\n\Q$encoded\E\z}, 'body follows the blank line verbatim';
  };

  subtest 'raw_body + content_type (tarball upload)' => sub {
    my $tar = "fake tar bytes\0\0\0";
    $t->_request('POST', '/build', raw_body => $tar, content_type => 'application/x-tar');
    my $req = $t->written;
    like $req, qr{Content-Type: application/x-tar\r\n},
      'content type overridden for a raw body, not left as application/json';
    like $req, qr{Content-Length: @{[ length $tar ]}\r\n},
      'content-length matches the raw body, not a JSON encoding of it';
    like $req, qr{\r\n\r\n\Q$tar\E\z}, 'raw bytes appended verbatim';
  };

  subtest 'params: sorted, hashref values JSON-encoded, then URI-encoded' => sub {
    $t->_request('GET', '/images/json',
      params => { all => 1, filters => { dangling => ['true'] } });
    my $req = $t->written;
    my ($request_line) = $req =~ /\A(GET [^\r\n]+)\r\n/;
    my $expected_filters = API::Docker::Role::HTTP::_uri_encode(
      encode_json({ dangling => ['true'] }));
    is $request_line,
      "GET /v1.41/images/json?all=1&filters=$expected_filters HTTP/1.1",
      'params sorted alphabetically by key; a hashref value is JSON-encoded '
      . 'then URI-encoded, not encoded twice by hand';
  };

  subtest 'extra headers: sanitised and appended' => sub {
    $t->_request('POST', '/images/x/push',
      headers => { 'X-Registry-Auth' => 'e30=' });
    my $req = $t->written;
    like $req, qr{X-Registry-Auth: e30=\r\n}, 'extra header present';
  };
};

# ---------------------------------------------------------------------------
subtest '_request: a CR/LF in a header value cannot inject a second header' => sub {
  my $t = Test::API::Docker::FakeTransport->new(
    host        => 'unix:///nonexistent.sock',
    api_version => '1.41',
  );

  $t->_request('POST', '/images/x/push',
    headers => { 'X-Registry-Auth' => "e30=\r\nX-Injected: evil" });
  my $req = $t->written;

  unlike $req, qr{\r\nX-Injected:},
    'no second header line -- "X-Injected" never starts its own line';
  like $req, qr{X-Registry-Auth: e30=X-Injected: evil\r\n},
    'the CRLF is stripped, not left as a line break -- the payload is '
    . 'flattened onto the one header line it belongs to';
};

# ---------------------------------------------------------------------------
# karr k11: the value above is sanitised, but the *name* used to go on the
# wire untouched, so a caller-supplied key could open a header line of its
# own. Names are rejected rather than stripped -- see the reasoning in
# API::Docker::Role::HTTP under "Header names are rejected, header values are
# stripped".
subtest '_request: an invalid header name is refused, not rewritten' => sub {
  my $t = Test::API::Docker::FakeTransport->new(
    host        => 'unix:///nonexistent.sock',
    api_version => '1.41',
  );

  subtest 'CRLF in the name croaks and sends nothing' => sub {
    eval {
      $t->_request('POST', '/images/x/push',
        headers => { "X-Registry-Auth\r\nX-Injected" => 'evil' });
    };
    like $@, qr/invalid header name/, 'croaked';

t/role_http.t  view on Meta::CPAN

  # word the same 409 differently -- so a caller telling 404 from 409 apart
  # had to match on it. The status code goes on the exception instead, and
  # the exception has to stay indistinguishable from the string it replaces.
  subtest 'the exception carries the status and is still that exact string' => sub {
    my $body = encode_json({
      cause    => 'container state improper',
      message  => 'can only kill running containers. abc is in state stopped',
      response => 409,
    });
    $t->canned([409, 'Conflict', {}, $body]);
    my $err = do { local $@; eval { $t->_request('POST', '/containers/abc/kill') }; $@ };

    isa_ok $err, 'API::Docker::Error::HTTP';
    is $err->status, 409, 'the status code, as the thing to branch on';
    is $err->reason, 'Conflict', 'the reason phrase off the status line';
    is $err->body, $body, 'the response body verbatim';
    is $err->data->{cause}, 'container state improper',
      'and decoded, so an engine-specific extra key is reachable';

    is "$err", $err->message . $err->location,
      'stringification is the message plus Carp\'s location, nothing else';
    like "$err", qr/\ADocker API error \(409\): can only kill running containers\. abc is in state stopped at \S+ line \d+\.\n\z/,
      'which is byte for byte what the plain croak produced before';
    unlike $err->message, qr/ at \S+ line \d+/,
      'the message alone carries no location';
    ok $err, 'and the boolean overload is true even before stringifying';
  };

  subtest 'a body that could not be decoded leaves data undef' => sub {
    $t->canned([400, 'Bad Request', {}, '{not actually json']);
    my $err = do { local $@; eval { $t->_request('POST', '/containers/create') }; $@ };
    is $err->data, undef, 'nothing is invented where decode_json failed';
    is $err->body, '{not actually json', 'while the raw body is still there';
  };

  subtest '204 and other success codes still return undef/decode normally' => sub {
    $t->canned([204, 'No Content', {}, '']);
    is $t->_request('POST', '/containers/abc/start'), undef, '204 -> undef';

    $t->canned([200, 'OK', {}, '{"Id":"abc"}']);
    is_deeply $t->_request('GET', '/containers/abc/json'), { Id => 'abc' },
      'a 2xx JSON body still decodes';
  };
};

# ---------------------------------------------------------------------------
# karr k16: a HEAD response repeats the header fields the equivalent GET would
# send -- Content-Length among them -- and then sends no body at all. Reading
# one waits for bytes that never arrive. The bytes after the blank line below
# stand in for whatever comes next on the connection: consuming them as a body
# is exactly the bug, and a handle that simply hit EOF there would hide it (the
# old code returned '' there too, from a read that failed rather than from one
# it never made).
#
# Where "not consumed" is now read: since karr k60 the read-ahead past the
# header block sits in the transport's own buffer rather than in PerlIO's, so
# the question is asked of that buffer. The claim is unchanged -- these bytes
# were not taken as a body -- and it is now asked somewhere this code owns
# rather than of a buffer it could not see into.
subtest '_read_response: a HEAD response has no body, whatever it announces' => sub {
  subtest 'an announced content-length is not read' => sub {
    my $raw = "HTTP/1.1 200 OK\r\n"
      . "Content-Length: 13\r\n"
      . "X-Docker-Container-Path-Stat: e30=\r\n"
      . "\r\n"
      . 'NOT-THE-BODY!';
    my $fh = string_handle($raw);
    my $resp = $client->_read_response($fh, 'HEAD');

    is $resp->[3], '', 'body is empty';
    is $resp->[2]{'content-length'}, '13',
      'the announced length is still collected as a header';
    is $resp->[2]{'x-docker-container-path-stat'}, 'e30=',
      'and so is the header a HEAD response carries its payload in';
    is unconsumed($client, $fh), 'NOT-THE-BODY!',
      'the bytes after the headers are still unconsumed, not swallowed as a '
      . 'body that was never sent';
  };

  subtest 'a chunked announcement is not read either' => sub {
    my $raw = "HTTP/1.1 200 OK\r\n"
      . "Transfer-Encoding: chunked\r\n"
      . "\r\n"
      . "5\r\nhello\r\n0\r\n\r\n";
    my $fh = string_handle($raw);
    my $resp = $client->_read_response($fh, 'HEAD');

    is $resp->[3], '', 'body is empty';
    is unconsumed($client, $fh), "5\r\nhello\r\n0\r\n\r\n",
      'the chunk framing was not consumed';
  };

  subtest 'every other method still reads its body' => sub {
    my $raw = "HTTP/1.1 200 OK\r\nContent-Length: 2\r\n\r\n{}";
    my $fh = string_handle($raw);
    is $client->_read_response($fh, 'GET')->[3], '{}', 'a GET body is read';

    my $fh2 = string_handle($raw);
    is $client->_read_response($fh2)->[3], '{}',
      'and so is one read without a method argument at all';
  };
};

# ---------------------------------------------------------------------------
# karr k16: _request used to drop the status line and the response headers, so
# 304 ("it was already in that state") and 204 ("changed it") were both undef,
# and a header carrying the whole payload was unreachable.
subtest '_request: the response out-parameter' => sub {
  my $t = Test::API::Docker::FakeTransport->new(
    host        => 'unix:///nonexistent.sock',
    api_version => '1.41',
  );

  subtest '204 and 304 are told apart' => sub {
    $t->canned([204, 'No Content', {}, '']);
    my %changed;
    is $t->_request('POST', '/containers/abc/start', response => \%changed), undef,
      'the return value is unchanged -- an empty body is still undef';
    is $changed{status}, 204, 'the status code is handed out';
    is $changed{reason}, 'No Content', 'and the reason phrase with it';

    $t->canned([304, 'Not Modified', {}, '']);
    my %unchanged;
    is $t->_request('POST', '/containers/abc/start', response => \%unchanged), undef,
      'a 304 carries no body either';
    is $unchanged{status}, 304,
      '304 is reported as 304 -- the two are indistinguishable by return '
      . 'value, and this is the only thing that separates them';
  };

  subtest 'the response headers are handed out, lowercased' => sub {
    $t->canned([200, 'OK', { 'x-docker-container-path-stat' => 'e30=' }, '']);