view release on metacpan or  search on metacpan

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

      . 'terminating zero chunk')
    unless defined $line;

  $self->_croak_truncated($ctx, phase => 'chunk-header',
    detail => 'the stream ended inside a chunk header, after '
      . length($line) . ' byte' . (length($line) == 1 ? '' : 's') . ' of one')
    unless $line =~ /\n\z/;

  # The line arrived whole and terminated, and its size is not a hexadecimal
  # number. Left to hex() that warns once and reads as 0 -- the terminating
  # zero chunk -- so a 200 whose framing is corrupt used to come back as an
  # empty body, the same body-shaped lie a truncation is. A chunk size is hex
  # digits, optionally followed by a ';' extension (RFC 9112 section 7.1.1),
  # which is read past and discarded; anything else is refused here rather than
  # silently misread by the caller. The returned size is parsed from the same
  # match, so hex() is called on nothing but hex digits and never has cause to
  # warn on a legal extension either.
  my ($size) = $line =~ /^([0-9A-Fa-f]+)(?:;.*)?\r?\n\z/;
  $self->_croak_truncated($ctx, phase => 'chunk-header',
    detail => "the chunk size line '" . ($line =~ s/\r?\n\z//r)
      . "' is not a hexadecimal number")
    unless defined $size;

  return hex($size);
}

# Completeness only, never content: a terminator that arrived but is not CRLF
# is a daemon speaking chunked wrongly, which is a different complaint and one
# this reader has never made.
sub _assert_chunk_terminator {
  my ($self, $ctx, $line) = @_;

  $self->_croak_truncated($ctx, phase => 'chunk-terminator',
    detail => 'the stream ended before the CRLF that terminates a chunk')
    unless defined $line && $line =~ /\n\z/;

  return;
}

# The declared body length, validated to be the digits RFC 9110 section 8.6
# requires before it is compared against or counted down (karr k113). The
# sibling of _assert_chunk_header's hex check: a Content-Length that is not a
# number -- 'abc', an empty value, a duplicated '11, 11', a leading space --
# left as it stood is run through `$len > 0`, which warns once ("isn't
# numeric") and reads as 0, so the body is taken to be empty and a response
# that had one comes back blank. Refused here rather than silently misread, so
# hex()'s sibling warning is never reached either.
sub _assert_content_length {
  my ($self, $ctx, $value) = @_;

  return $value if $value =~ /\A[0-9]+\z/;

  $self->_croak_truncated($ctx, phase => 'content-length',
    detail => "the Content-Length header '" . $value . "' is not a number");
}

sub _uri_encode {
  my ($str) = @_;
  # Escape a character string by its UTF-8 bytes ('ü' -> %C3%BC, not %FC), and
  # a byte string as it stands. ord() on a character is not its wire byte: a
  # name or tag typed under `use utf8`, or read through a :utf8 layer, arrives
  # as characters and used to escape to a lone high byte or a bare codepoint
  # (%FC, %4E2D) that is not UTF-8 at all. But the encoding cannot be
  # unconditional: encode_json has already handed a HASH param (filters among
  # them) its UTF-8 octets, and re-encoding those would double them
  # (%C3%BC -> %C3%83%C2%BC). The utf8 flag is exactly that distinction -- on
  # for a decoded string, off for encode_json's output -- so a copy is encoded
  # only when it carries one, leaving the caller's own value untouched either
  # way.
  my $bytes = $str;
  utf8::encode($bytes) if utf8::is_utf8($bytes);
  $bytes =~ s/([^A-Za-z0-9\-_.~:\/])/sprintf("%%%02X", ord($1))/ge;
  return $bytes;
}

sub get {
  my ($self, $path, %opts) = @_;
  return $self->_request('GET', $path, %opts);
}


sub post {
  my ($self, $path, $body, %opts) = @_;
  $opts{body} = $body if defined $body;
  return $self->_request('POST', $path, %opts);
}


sub put {
  my ($self, $path, $body, %opts) = @_;
  $opts{body} = $body if defined $body;
  return $self->_request('PUT', $path, %opts);
}


sub delete_request {
  my ($self, $path, %opts) = @_;
  return $self->_request('DELETE', $path, %opts);
}


sub head {
  my ($self, $path, %opts) = @_;
  return $self->_request('HEAD', $path, %opts);
}


sub stream_frames {
  my ($self, $method, $path, %opts) = @_;

  my $tty = delete $opts{tty};

  if (my $cb = delete $opts{on_frame}) {
    # tty is a declaration here, not the hint it is on the buffered path. The
    # sniff below needs the whole body to decide, and the whole body is what a
    # callback stream does not have; so an unframed stream has to say so, and
    # anything not declared is required to be framed.
    return $self->_request($method, $path, %opts,
      $tty
        ? ( on_chunk => sub { $cb->({ stream => 'raw', data => $_[0] }, $_[1]) } )
        : ( on_frame => $cb ),
    );
  }

  my $body = $self->_request($method, $path, %opts, raw => 1);

  return [] unless defined $body && length $body;

  my $frames = $tty ? undef : $self->_demux_frames($body);

  return $frames if $frames;