summaryrefslogtreecommitdiffstats
path: root/Bugzilla/S3/Bucket.pm
blob: a53ab5c5159eb35413c2c9fa562f12d595773dcd (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
package Bugzilla::S3::Bucket;

# Forked from Amazon::S3, which appears to be abandoned.

use 5.10.1;
use strict;
use warnings;

use Carp;
use File::stat;
use IO::File;

use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(bucket creation_date account));

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);
    croak "no bucket"  unless $self->bucket;
    croak "no account" unless $self->account;
    return $self;
}

sub _uri {
    my ($self, $key) = @_;
    return ($key)
      ? $self->bucket . "/" . $self->account->_urlencode($key)
      : $self->bucket . "/";
}

# returns bool
sub add_key {
    my ($self, $key, $value, $conf) = @_;
    croak 'must specify key' unless $key && length $key;

    if ($conf->{acl_short}) {
        $self->account->_validate_acl_short($conf->{acl_short});
        $conf->{'x-amz-acl'} = $conf->{acl_short};
        delete $conf->{acl_short};
    }

    if (ref($value) eq 'SCALAR') {
        $conf->{'Content-Length'} ||= -s $$value;
        $value = _content_sub($$value);
    }
    else {
        $conf->{'Content-Length'} ||= length $value;
    }

    # If we're pushing to a bucket that's under DNS flux, we might get a 307
    # Since LWP doesn't support actually waiting for a 100 Continue response,
    # we'll just send a HEAD first to see what's going on

    if (ref($value)) {
        return $self->account->_send_request_expect_nothing_probed('PUT',
            $self->_uri($key), $conf, $value);
    }
    else {
        return $self->account->_send_request_expect_nothing('PUT',
            $self->_uri($key), $conf, $value);
    }
}

sub add_key_filename {
    my ($self, $key, $value, $conf) = @_;
    return $self->add_key($key, \$value, $conf);
}

sub head_key {
    my ($self, $key) = @_;
    return $self->get_key($key, "HEAD");
}

sub get_key {
    my ($self, $key, $method, $filename) = @_;
    $method ||= "GET";
    $filename = $$filename if ref $filename;
    my $acct = $self->account;

    my $request = $acct->_make_request($method, $self->_uri($key), {});
    my $response = $acct->_do_http($request, $filename);

    if ($response->code == 404) {
        $acct->err(404);
        $acct->errstr('The requested key was not found');
        return undef;
    }

    return undef unless $acct->_check_response($response);

    my $etag = $response->header('ETag');
    if ($etag) {
        $etag =~ s/^"//;
        $etag =~ s/"$//;
    }

    my $return = {
        content_length => $response->content_length || 0,
        content_type   => $response->content_type,
        etag           => $etag,
        value          => $response->content,
    };

    foreach my $header ($response->headers->header_field_names) {
        next unless $header =~ /x-amz-meta-/i;
        $return->{lc $header} = $response->header($header);
    }

    return $return;

}

sub get_key_filename {
    my ($self, $key, $method, $filename) = @_;
    $filename = $key unless defined $filename;
    return $self->get_key($key, $method, \$filename);
}

# returns bool
sub delete_key {
    my ($self, $key) = @_;
    croak 'must specify key' unless $key && length $key;
    return $self->account->_send_request_expect_nothing('DELETE',
        $self->_uri($key), {});
}

sub get_acl {
    my ($self, $key) = @_;
    my $acct = $self->account;

    my $request = $acct->_make_request('GET', $self->_uri($key) . '?acl', {});
    my $response = $acct->_do_http($request);

    if ($response->code == 404) {
        return undef;
    }

    return undef unless $acct->_check_response($response);

    return $response->content;
}

sub set_acl {
    my ($self, $conf) = @_;
    $conf ||= {};

    unless ($conf->{acl_xml} || $conf->{acl_short}) {
        croak "need either acl_xml or acl_short";
    }

    if ($conf->{acl_xml} && $conf->{acl_short}) {
        croak "cannot provide both acl_xml and acl_short";
    }

    my $path = $self->_uri($conf->{key}) . '?acl';

    my $hash_ref =
        ($conf->{acl_short})
      ? {'x-amz-acl' => $conf->{acl_short}}
      : {};

    my $xml = $conf->{acl_xml} || '';

    return $self->account->_send_request_expect_nothing('PUT', $path,
        $hash_ref, $xml);

}

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

    my $xpc =
      $self->account->_send_request('GET', $self->bucket . '/?location');
    return undef unless $xpc && !$self->account->_remember_errors($xpc);

    my $lc = $xpc->{content};
    if (defined $lc && $lc eq '') {
        $lc = undef;
    }
    return $lc;
}

# proxy up the err requests

sub err { $_[0]->account->err }

sub errstr { $_[0]->account->errstr }

sub _content_sub {
    my $filename  = shift;
    my $stat      = stat($filename);
    my $remaining = $stat->size;
    my $blksize   = $stat->blksize || 4096;

    croak "$filename not a readable file with fixed size"
      unless -r $filename
          and $remaining;

    my $fh = IO::File->new($filename, 'r')
      or croak "Could not open $filename: $!";
    $fh->binmode;

    return sub {
        my $buffer;

        # upon retries the file is closed and we must reopen it
        unless ($fh->opened) {
            $fh = IO::File->new($filename, 'r')
              or croak "Could not open $filename: $!";
            $fh->binmode;
            $remaining = $stat->size;
        }

        unless (my $read = $fh->read($buffer, $blksize)) {
            croak
              "Error while reading upload content $filename ($remaining remaining) $!"
              if $! and $remaining;
            $fh->close    # otherwise, we found EOF
              or croak "close of upload content $filename failed: $!";
            $buffer
              ||= '';  # LWP expects an empty string on finish, read returns 0
        }
        $remaining -= length($buffer);
        return $buffer;
    };
}

1;

__END__

=head1 NAME

Bugzilla::S3::Bucket - A container class for a S3 bucket and its contents.

=head1 METHODS

=head2 new

Instaniates a new bucket object.

Requires a hash containing two arguments:

=over

=item bucket

The name (identifier) of the bucket.

=item account

The L<S3::Amazon> object (representing the S3 account) this
bucket is associated with.

=back

NOTE: This method does not check if a bucket actually
exists. It simply instaniates the bucket.

Typically a developer will not call this method directly,
but work through the interface in L<S3::Amazon> that will
handle their creation.

=head2 add_key

Takes three positional parameters:

=over

=item key

A string identifier for the resource in this bucket

=item value

A SCALAR string representing the contents of the resource.

=item configuration

A HASHREF of configuration data for this key. The configuration
is generally the HTTP headers you want to pass the S3
service. The client library will add all necessary headers.
Adding them to the configuration hash will override what the
library would send and add headers that are not typically
required for S3 interactions.

In addition to additional and overriden HTTP headers, this
HASHREF can have a C<acl_short> key to set the permissions
(access) of the resource without a seperate call via
C<add_acl> or in the form of an XML document.  See the
documentation in C<add_acl> for the values and usage.

=back

Returns a boolean indicating its success. Check C<err> and
C<errstr> for error message if this operation fails.

=head2 add_key_filename

The method works like C<add_key> except the value is assumed
to be a filename on the local file system. The file will
be streamed rather then loaded into memory in one big chunk.

=head2 head_key $key_name

Returns a configuration HASH of the given key. If a key does
not exist in the bucket C<undef> will be returned.

=head2 get_key $key_name, [$method]

Takes a key and an optional HTTP method and fetches it from
S3. The default HTTP method is GET.

The method returns C<undef> if the key does not exist in the
bucket. If a server error occurs C<undef> is returned and
C<err> and C<errstr> are set.

On success, the method returns a HASHREF containing:

=over

=item content_type

=item etag

=item value

=item @meta

=back

=head2 get_key_filename $key_name, $method, $filename

This method works like C<get_key>, but takes an added
filename that the S3 resource will be written to.

=head2 delete_key $key_name

Permanently removes C<$key_name> from the bucket. Returns a
boolean value indicating the operations success.

=head2 get_acl

Retrieves the Access Control List (ACL) for the bucket or
resource as an XML document.

=over

=item key

The key of the stored resource to fetch. This parameter is
optional. By default the method returns the ACL for the
bucket itself.

=back

=head2 set_acl $conf

Retrieves the Access Control List (ACL) for the bucket or
resource. Requires a HASHREF argument with one of the following keys:

=over

=item acl_xml

An XML string which contains access control information
which matches Amazon's published schema.

=item acl_short

Alternative shorthand notation for common types of ACLs that
can be used in place of a ACL XML document.

According to the Amazon S3 API documentation the following recognized acl_short
types are defined as follows:

=over

=item private

Owner gets FULL_CONTROL. No one else has any access rights.
This is the default.

=item public-read

Owner gets FULL_CONTROL and the anonymous principal is
granted READ access. If this policy is used on an object, it
can be read from a browser with no authentication.

=item public-read-write

Owner gets FULL_CONTROL, the anonymous principal is granted
READ and WRITE access. This is a useful policy to apply to a
bucket, if you intend for any anonymous user to PUT objects
into the bucket.

=item authenticated-read

Owner gets FULL_CONTROL, and any principal authenticated as
a registered Amazon S3 user is granted READ access.

=back

=item key

The key name to apply the permissions. If the key is not
provided the bucket ACL will be set.

=back

Returns a boolean indicating the operations success.

=head2 get_location_constraint

Returns the location constraint data on a bucket.

For more information on location constraints, refer to the
Amazon S3 Developer Guide.

=head2 err

The S3 error code for the last error the account encountered.

=head2 errstr

A human readable error string for the last error the account encountered.

=head1 SEE ALSO

L<Bugzilla::S3>

=head1 AUTHOR & COPYRIGHT

Please see the L<Bugzilla::S3> manpage for author, copyright, and
license information.