File Coverage

blib/lib/Amazon/S3/Lite.pm

Criterion	Covered	Total	%
statement	277	336	82.4
branch	89	136	65.4
condition	39	99	39.3
subroutine	43	47	91.4
pod	13	14	92.8
total	461	632	72.9

package Amazon::S3::Lite;

use strict;
use warnings;

our $VERSION = '1.0.1';

use AWS::Signature4;
use Amazon::S3::Lite::Credentials;
use Amazon::S3::Lite::Logger;
use Carp qw(croak carp);
use Data::Dumper;
use Digest::MD5 qw(md5_base64 md5);
use Digest::SHA qw(sha256_hex);
use HTTP::Request;
use HTTP::Tiny;
use MIME::Base64 qw(encode_base64);
use Scalar::Util qw(blessed openhandle reftype);
use URI::Escape qw(uri_escape_utf8);
use XML::LibXML;

########################################################################
sub new {
########################################################################
  my ( $class, $args ) = @_;

  $args //= {};

  croak 'new() requires a hashref'
    if ref $args ne 'HASH';

  croak 'region is required'
    if !$args->{region};

  my $self = bless {}, $class;

  $self->{region}  = $args->{region};
  $self->{host}    = $args->{host}    // 's3.amazonaws.com';
  $self->{secure}  = $args->{secure}  // 1;
  $self->{timeout} = $args->{timeout} // 30;

  $self->_init_logger( $args->{logger} );
  $self->_init_credentials($args);
  $self->_init_ua;

  return $self;
}

########################################################################
# Logger setup
# Priority: caller-supplied object -> Log::Log4perl (if available) ->
#           minimal STDERR logger
########################################################################
sub _init_logger {
########################################################################
  my ( $self, $logger ) = @_;

  if ($logger) {
    # Validate it quacks like a logger
    for my $method (qw(trace debug info warn error)) {
      croak "logger object must implement '$method'"
        if !$logger->can($method);
    }
    $self->{logger} = $logger;
    return;
  }

  if ( eval { require Log::Log4perl; 1 } ) {
    if ( !Log::Log4perl->initialized ) {
      Log::Log4perl->easy_init($Log::Log4perl::WARN);
    }
    $self->{logger} = Log::Log4perl->get_logger(__PACKAGE__);
    return;
  }

  # Fall back to minimal STDERR logger
  $self->{logger} = Amazon::S3::Lite::Logger->new;

  return;
}

########################################################################
# Credential resolution
# Priority: explicit credentials object -> constructor args ->
#           environment variables -> Amazon::Credentials (if available)
########################################################################
sub _init_credentials {
########################################################################
  my ( $self, $args ) = @_;

  # 1. Caller-supplied credentials object (duck-typed)
  if ( my $creds = $args->{credentials} ) {
    croak "credential object is not blessed.\n"
      if !blessed $creds;

    foreach (qw(aws_access_key_id aws_secret_access_key token)) {
      my $sub = $creds->can($_) // $creds->can("get_$_");

      croak "credentials object must implement $_ or get_$_\n"
        if !$sub;
    }

    $self->{credentials} = $creds;

    return;
  }

  # 2. Explicit constructor args
  if ( $args->{aws_access_key_id} && $args->{aws_secret_access_key} ) {
    $self->{credentials} = Amazon::S3::Lite::Credentials->new(
      aws_access_key_id     => $args->{aws_access_key_id},
      aws_secret_access_key => $args->{aws_secret_access_key},
      token                 => $args->{token},
    );
    return;
  }

  # 3. Environment variables
  if ( $ENV{AWS_ACCESS_KEY_ID} && $ENV{AWS_SECRET_ACCESS_KEY} ) {
    $self->{credentials} = Amazon::S3::Lite::Credentials->new(
      aws_access_key_id     => $ENV{AWS_ACCESS_KEY_ID},
      aws_secret_access_key => $ENV{AWS_SECRET_ACCESS_KEY},
      token                 => $ENV{AWS_SESSION_TOKEN},
    );
    return;
  }

  # 4. Amazon::Credentials (covers IAM roles, ECS task roles,
  #    ~/.aws/credentials, etc.)
  if ( eval { require Amazon::Credentials; 1 } ) {
    $self->{credentials} = Amazon::Credentials->new;
    return;
  }

  croak 'No AWS credentials found. Supply aws_access_key_id/'
    . 'aws_secret_access_key, set AWS_ACCESS_KEY_ID/'
    . 'AWS_SECRET_ACCESS_KEY environment variables, '
    . 'or install Amazon::Credentials for IAM role support.';
}

########################################################################
# HTTP::Tiny instance - one per object, keep-alive enabled
########################################################################
sub _init_ua {
########################################################################
  my ($self) = @_;

  $self->{ua} = HTTP::Tiny->new(
    timeout    => $self->{timeout},
    verify_SSL => $self->{secure},
  );

  return;
}

########################################################################
# Accessors
########################################################################
sub logger      { return $_[0]->{logger} }
sub ua          { return $_[0]->{ua} }
sub region      { return $_[0]->{region} }
sub host        { return $_[0]->{host} }
sub credentials { return $_[0]->{credentials} }

########################################################################
# Build a fresh signer from current credentials.
# Called per-request so that rotating credentials (Lambda IAM roles)
# are always current.
########################################################################
sub _signer {
########################################################################
  my ($self) = @_;

  my $creds = $self->credentials;

  return AWS::Signature4->new(
    -access_key => $creds->get_aws_access_key_id     // $creds->aws_access_key_id,
    -secret_key => $creds->get_aws_secret_access_key // $creds->get_aws_secret_access_key,
  );
}

########################################################################
# Build the endpoint URL for a bucket/key
########################################################################
sub _endpoint {
########################################################################
  my ( $self, $bucket, $key ) = @_;

  my $scheme = $self->{secure} ? 'https' : 'http';
  my $host   = $self->host;

  # Path-style URL: https://s3.amazonaws.com/bucket/key
  # (virtual-hosted style omitted for simplicity; path-style works
  # everywhere and avoids SSL cert issues with dotted bucket names)
  my $url = "$scheme://$host";

  $url .= "/$bucket"              if defined $bucket && length $bucket;
  $url .= '/' . _encode_key($key) if defined $key    && length $key;

  return $url;
}

########################################################################
# URI-encode an S3 key, preserving '/' separators
########################################################################
sub _encode_key {
########################################################################
  my ($key) = @_;

  return join '/', map { uri_escape_utf8( $_, '^A-Za-z0-9\-._~' ) }
    split m{/}, $key, -1;
}
########################################################################
# Core request method:
#   1. Build HTTP::Request for signing
#   2. Sign it (fresh signer = current credentials)
#   3. Extract auth headers
#   4. Execute via HTTP::Tiny
#
# Returns raw HTTP::Tiny response hashref.
########################################################################
sub _request {
########################################################################
  my ( $self, $method, $url, $headers, $content, $extra, $region ) = @_;

  $region //= $self->region;

  $headers //= {};
  $content //= q{};
  my $content_is_coderef = ref $content eq 'CODE';

  $extra //= {};

  # Build an HTTP::Request just for signing
  my $req = HTTP::Request->new( $method, $url );
  $req->content($content) if length $content && !$content_is_coderef;

  for my $name ( keys %{$headers} ) {
    $req->header( $name => $headers->{$name} );
  }

  my $token_sub = $self->credentials->can('get_token') // $self->credentials->can('token');
  my $token     = $token_sub ? $token_sub->( $self->credentials ) : undef;

  if ( defined $token && length $token ) {
    $req->header( 'x-amz-security-token' => $token );
  }

  # add before $signer->sign(...)
  if ( !$content_is_coderef ) {
    my $hash = sha256_hex( ref $content eq 'SCALAR' ? ${$content} : $content // q{} );
    $req->header( 'x-amz-content-sha256' => $hash );
  }

  # Sign — mutates $req with Authorization and x-amz-date
  my $signer = $self->_signer;

  my $payload_hash = $content_is_coderef ? 'UNSIGNED-PAYLOAD' : undef;
  $signer->sign( $req, $region, $payload_hash );

  # Pull signed headers back out for HTTP::Tiny
  my %signed_headers;
  for my $name ( $req->headers->header_field_names ) {
    $signed_headers{$name} = $req->header($name);
  }

  # HTTP::Tiny sets Host itself from the URL and rejects it as an explicit
  # header option. The host value is already covered by the Authorization
  # SignedHeaders list, so removing it here is safe.
  delete $signed_headers{Host};

  $self->logger->debug("$method $url");

  # Execute via HTTP::Tiny
  my $options = { headers => \%signed_headers };

  # For HTTP::Tiny — code ref is valid content
  $options->{content} = $content if length $content || $content_is_coderef;

  # Pass through data_callback for streaming downloads
  if ( $extra->{data_callback} ) {
    $options->{data_callback} = $extra->{data_callback};
  }

  my $response = $self->ua->request( $method, $url, $options );

  $self->logger->debug( sprintf 'Response: %s %s', $response->{status}, $response->{reason} );

  return $response;
}

########################################################################
# head_object( $bucket, $key )
#
# Fetches metadata for an object without retrieving the body.
# Returns undef if the key does not exist (404).
# Returns a hashref with content_type, content_length, etag,
# last_modified, and metadata (x-amz-meta-* headers).
########################################################################
sub head_object {
########################################################################
  my ( $self, $bucket, $key ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;

  my $url      = $self->_endpoint( $bucket, $key );
  my $response = $self->_request( 'HEAD', $url );

  return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
    if _is_not_found($response);

  $self->_croak_on_error( $response, 'head_object' );

  return $self->_extract_object_metadata( $response->{headers} );
}

########################################################################
# Extract the standard object metadata hashref from a response headers
# hash. Used by both head_object and get_object.
########################################################################
sub _extract_object_metadata {
########################################################################
  my ( $self, $headers ) = @_;

  my $etag = $headers->{etag};
  $etag =~ s/\A"|"\z//gxsm if defined $etag;

  # Collect x-amz-meta-* headers, stripping the prefix from the key
  my %metadata;
  for my $name ( keys %{$headers} ) {
    if ( $name =~ /^x-amz-meta-(.+)$/xsm ) {
      $metadata{$1} = $headers->{$name};
    }
  }

  return {
    content_type   => $headers->{'content-type'},
    content_length => $headers->{'content-length'} + 0,
    etag           => $etag,
    last_modified  => $headers->{'last-modified'},
    metadata       => \%metadata,
  };
}

########################################################################
# get_object( $bucket, $key, %options )
#
# Fetches an object from S3. Options:
#   range    => 'bytes=0-1023'   partial fetch
#   filename => '/tmp/foo'       stream body to disk; omits content key
#
# Returns undef on 404.
# Returns a hashref with content_type, content_length, etag,
# last_modified, metadata, and content (unless filename is used).
########################################################################
sub get_object {
########################################################################
  my ( $self, $bucket, $key, %options ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;

  my $url = $self->_endpoint( $bucket, $key );

  my %headers;
  $headers{Range} = $options{range} if defined $options{range};

  my $filename = $options{filename};
  my $extra    = {};

  if ( defined $filename ) {
    # Open the destination file before making the request so we catch
    # permission errors early, before network round-trip
    open my $fh, '>', $filename
      or croak "cannot open '$filename' for writing: $!";

    $extra->{data_callback} = sub {
      my ($data) = @_;
      print {$fh} $data
        or croak "write to '$filename' failed: $!";
    };

    my $response = $self->_request( 'GET', $url, \%headers, q{}, $extra );

    close $fh
      or croak "close of '$filename' failed: $!";

    return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
      if _is_not_found($response);

    $self->_croak_on_error( $response, 'get_object' );

    # Return metadata only — content is on disk
    return $self->_extract_object_metadata( $response->{headers} );
  }

  # In-memory path
  my $response = $self->_request( 'GET', $url, \%headers );

  return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
    if _is_not_found($response);

  $self->_croak_on_error( $response, 'get_object' );

  my $result = $self->_extract_object_metadata( $response->{headers} );
  $result->{content} = $response->{content};

  return $result;
}

########################################################################
# delete_object( $bucket, $key, %options )
#
# Deletes an object from S3. Options:
#   version_id => $vid    delete a specific version
#
# Returns true on success. Note S3 returns 204 for both successful
# deletes and deletes of non-existent keys — no distinction is made.
# Croaks on network or server errors.
########################################################################
sub delete_object {
########################################################################
  my ( $self, $bucket, $key, %options ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;

  my $url = $self->_endpoint( $bucket, $key );

  if ( defined $options{version_id} ) {
    $url .= '?versionId=' . uri_escape_utf8( $options{version_id} );
  }

  my $response = $self->_request( 'DELETE', $url );

  $self->_croak_on_error( $response, 'delete_object' );

  return 1;
}

########################################################################
# list_buckets()
#
# Lists all buckets owned by the authenticated user.
#
# Note: ListBuckets is a global S3 operation and must always be signed
# against us-east-1 regardless of the region the object was constructed
# with. We pass the region override directly to the signer.
#
# Returns a hashref:
#   {
#     owner_id   => '...',
#     owner_name => '...',
#     buckets    => [
#       { name => '...', creation_date => '...' },
#       ...
#     ],
#   }
########################################################################
sub list_buckets {
########################################################################
  my ($self) = @_;

  my $url = $self->_endpoint;  # https://s3.amazonaws.com

  my $response = $self->_request( 'GET', $url, {}, q{}, {}, 'us-east-1' );

  $self->_croak_on_error( $response, 'list_buckets' );

  return $self->_parse_list_buckets( $response->{content} );
}

########################################################################
# Parse ListAllMyBucketsResult XML
########################################################################
sub _parse_list_buckets {
########################################################################
  my ( $self, $xml ) = @_;

  my $doc  = XML::LibXML->load_xml( string => $xml );
  my $xpc  = _xpc($doc);
  my $root = '/s3:ListAllMyBucketsResult';

  my @buckets;

  for my $node ( $xpc->findnodes("$root/s3:Buckets/s3:Bucket") ) {
    push @buckets,
      {
      name          => $xpc->findvalue( 's3:Name',         $node ),
      creation_date => $xpc->findvalue( 's3:CreationDate', $node ),
      };
  }

  return {
    owner_id   => $xpc->findvalue("$root/s3:Owner/s3:ID"),
    owner_name => $xpc->findvalue("$root/s3:Owner/s3:DisplayName"),
    buckets    => \@buckets,
  };
}

########################################################################
# copy_object( %args )
#
# Copies an object within or between buckets, entirely server-side.
# Required: src_bucket, src_key, dst_bucket, dst_key
#
# Note: S3 can return HTTP 200 with an XML error body for copy operations
# that fail mid-transfer. This method detects and croaks on that case.
#
# Returns a hashref: { etag => '...', last_modified => '...' }
########################################################################
sub copy_object {
########################################################################
  my ( $self, %args ) = @_;

  for my $required (qw( src_bucket src_key dst_bucket dst_key )) {
    croak "$required is required"
      if !defined $args{$required} || !length $args{$required};
  }

  my $url = $self->_endpoint( $args{dst_bucket}, $args{dst_key} );

  # x-amz-copy-source: /src-bucket/encoded-key
  my $copy_source = '/' . $args{src_bucket} . '/' . _encode_key( $args{src_key} );

  my %headers = (
    'x-amz-copy-source'       => $copy_source,
    'x-amz-tagging-directive' => 'COPY',
    'Content-Length'          => 0,
  );

  my $response = $self->_request( 'PUT', $url, \%headers );

  $self->_croak_on_error( $response, 'copy_object' );

  # S3 can return HTTP 200 with an XML error body for copies that fail
  # after the headers have been sent. Detect this by checking the root
  # element — a success response has , an error has .
  return $self->_parse_copy_response( $response->{content}, 'copy_object' );
}

########################################################################
# Parse CopyObjectResult XML, detecting the 200-with-error edge case
########################################################################
sub _parse_copy_response {
########################################################################
  my ( $self, $xml, $context ) = @_;

  my $doc  = XML::LibXML->load_xml( string => $xml );
  my $root = $doc->documentElement->localname;

  if ( $root eq 'Error' ) {
    my $code = $doc->findvalue('/Error/Code');
    my $msg  = $doc->findvalue('/Error/Message');
    croak sprintf '%s failed: %s - %s', $context, $code, $msg;
  }

  my $xpc         = _xpc($doc);
  my $result_root = '/s3:CopyObjectResult';

  my $etag = $xpc->findvalue("$result_root/s3:ETag");
  $etag =~ s/\A"|"\z//gxsm if defined $etag;

  return {
    etag          => $etag,
    last_modified => $xpc->findvalue("$result_root/s3:LastModified"),
  };
}

########################################################################
# put_object( $bucket, $key, $data, %options )
#
# Stores an object in S3. $data may be a scalar string, a reference to
# a scalar, or an open filehandle / IO::File object.
#
# Options: content_type, content_length, metadata (hashref), acl
#
# Returns the ETag of the stored object. Croaks on failure.
########################################################################
sub put_object {
########################################################################
  my ( $self, $bucket, $key, $data, %options ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;
  croak 'data is required'   if !defined $data;

  my $url = $self->_endpoint( $bucket, $key );

  my %headers;
  $headers{'Content-Type'} = $options{content_type} // 'application/octet-stream';

  # x-amz-acl header
  if ( $options{acl} ) {
    $headers{'x-amz-acl'} = $options{acl};
  }

  # User metadata — prefix bare keys with x-amz-meta-
  if ( my $meta = $options{metadata} ) {
    for my $k ( keys %{$meta} ) {
      my $header = $k =~ /^x-amz-meta-/xsm ? $k : "x-amz-meta-$k";
      $headers{$header} = $meta->{$k};
    }
  }

  my $body;

  if ( openhandle($data) || ( blessed($data) && $data->can('read') ) ) {
    # --- Filehandle path ---
    my $content_length = $options{content_length};

    if ( !defined $content_length ) {
      # Try to stat the handle for real files; suppress warning on
      # in-memory handles (IO::Scalar etc.) that have no underlying fd
      my @st = eval { stat $data };
      $content_length = $st[7] if @st && defined $st[7];
    }

    croak 'content_length is required for in-memory filehandles'
      if !defined $content_length;

    $headers{'Content-Length'} = $content_length;

    # Wrap filehandle in a code ref for HTTP::Tiny streaming
    my $chunk_size = 1024 * 64;  # 64KB chunks
    $body = sub {
      my $buf;
      my $n = read( $data, $buf, $chunk_size );
      return $buf if $n;
      return q{};
    };
  }
  elsif ( ref $data eq 'SCALAR' ) {
    # --- Scalar ref path ---
    $body                      = ${$data};
    $headers{'Content-Length'} = length $body;
    $headers{'Content-MD5'}    = encode_base64( md5($body), q{} );
  }
  else {
    # --- Plain scalar path ---
    $body                      = $data;
    $headers{'Content-Length'} = length $body;
    $headers{'Content-MD5'}    = encode_base64( md5($body), q{} );
  }

  my $response = $self->_request( 'PUT', $url, \%headers, $body );

  $self->_croak_on_error( $response, 'put_object' );

  my $etag = $response->{headers}{etag};
  $etag =~ s/\A"|"\z//gxsm if defined $etag;

  return $etag;
}

########################################################################
# S3 XML namespace — must be registered for all XPath queries
########################################################################
use constant S3_NS => 'http://s3.amazonaws.com/doc/2006-03-01/';

########################################################################
# Build a namespace-aware XPath context for a parsed document
########################################################################
sub _xpc {
########################################################################
  my ($doc) = @_;

  my $xpc = XML::LibXML::XPathContext->new($doc);
  $xpc->registerNs( 's3', S3_NS );

  return $xpc;
}

########################################################################
# list_objects_v2( $bucket, %options )
#
# Lists objects in a bucket using the S3 ListObjectsV2 API.
# Returns a hashref with keys: bucket, prefix, key_count, max_keys,
# is_truncated, next_continuation_token, objects, common_prefixes.
########################################################################
sub list_objects_v2 {
########################################################################
  my ( $self, $bucket, %options ) = @_;

  croak 'bucket is required'
    if !defined $bucket || !length $bucket;

  # Map our option names to S3 query parameter names
  my %param_map = (
    prefix             => 'prefix',
    delimiter          => 'delimiter',
    max_keys           => 'max-keys',
    continuation_token => 'continuation-token',
    start_after        => 'start-after',
  );

  my %params = ( 'list-type' => '2' );

  for my $opt ( keys %param_map ) {
    if ( defined $options{$opt} ) {
      $params{ $param_map{$opt} } = $options{$opt};
    }
  }

  # Build query string
  my $query = join q{&}, map { uri_escape_utf8($_) . q{=} . uri_escape_utf8( $params{$_} ) }
    sort keys %params;

  my $url = $self->_endpoint($bucket) . q{?} . $query;

  my $response = $self->_request( 'GET', $url );

  return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
    if _is_not_found($response);

  $self->_croak_on_error( $response, 'list_objects_v2' );

  return $self->_parse_list_objects_v2( $response->{content} );
}

########################################################################
# Parse the XML body of a ListObjectsV2 response
########################################################################
sub _parse_list_objects_v2 {
########################################################################
  my ( $self, $xml ) = @_;

  my $doc  = XML::LibXML->load_xml( string => $xml );
  my $xpc  = _xpc($doc);
  my $root = '/s3:ListBucketResult';

  my $is_truncated = $xpc->findvalue("$root/s3:IsTruncated") eq 'true' ? 1 : 0;

  my $next_token
    = $is_truncated
    ? $xpc->findvalue("$root/s3:NextContinuationToken")
    : undef;

  my @objects;

  for my $node ( $xpc->findnodes("$root/s3:Contents") ) {
    my $etag = $xpc->findvalue( 's3:ETag', $node );
    $etag =~ s/\A"|"\z//gxsm if defined $etag;  # strip surrounding quotes

    push @objects,
      {
      key           => $xpc->findvalue( 's3:Key',          $node ),
      size          => $xpc->findvalue( 's3:Size',         $node ) + 0,
      last_modified => $xpc->findvalue( 's3:LastModified', $node ),
      etag          => $etag,
      storage_class => $xpc->findvalue( 's3:StorageClass', $node ),
      };
  }

  my @common_prefixes;

  for my $node ( $xpc->findnodes("$root/s3:CommonPrefixes") ) {
    push @common_prefixes, $xpc->findvalue( 's3:Prefix', $node );
  }

  return {
    bucket                  => $xpc->findvalue("$root/s3:Name"),
    prefix                  => $xpc->findvalue("$root/s3:Prefix"),
    key_count               => $xpc->findvalue("$root/s3:KeyCount") + 0,
    max_keys                => $xpc->findvalue("$root/s3:MaxKeys") + 0,
    is_truncated            => $is_truncated,
    next_continuation_token => $next_token,
    objects                 => \@objects,
    common_prefixes         => \@common_prefixes,
  };
}

########################################################################
# list_all_objects_v2( $bucket, %options )
#
# Convenience wrapper that auto-paginates list_objects_v2 and returns
# a flat list of all matching object hashrefs.
# delimiter is ignored — use list_objects_v2 directly for that.
########################################################################
sub list_all_objects_v2 {
########################################################################
  my ( $self, $bucket, %options ) = @_;

  # delimiter is meaningless here — silently remove it
  delete $options{delimiter};

  my @all_objects;
  my $continuation_token;

  while (1) {
    $options{continuation_token} = $continuation_token
      if defined $continuation_token;

    my $result = $self->list_objects_v2( $bucket, %options );

    last if !$result;  # 404 / empty bucket

    push @all_objects, @{ $result->{objects} };

    last if !$result->{is_truncated};

    $continuation_token = $result->{next_continuation_token};
  }

  return @all_objects;
}

########################################################################
# Error checking helpers
########################################################################
sub _is_success {
  return $_[0]->{status} =~ /\A2\d{2}\z/;
}

sub _is_not_found {
  return $_[0]->{status} == 404;
}

sub _croak_on_error {
  my ( $self, $response, $context ) = @_;

  return if _is_success($response);

  my $status = $response->{status};
  my $reason = $response->{reason};

  # Attempt to extract S3 error message from XML body
  my $detail = q{};
  if ( $response->{content} && $response->{content} =~ /<\?xml/xsm ) {
    eval {
      my $doc  = XML::LibXML->load_xml( string => $response->{content} );
      my $msg  = $doc->findvalue('/Error/Message');
      my $code = $doc->findvalue('/Error/Code');
      $detail = " - $code: $msg" if $code || $msg;
    };
  }

  croak sprintf '%s failed: HTTP %s %s%s', $context, $status, $reason, $detail;
}

1;

__END__