1#!/usr/bin/perl
2
3#  This software code is made available "AS IS" without warranties of any
4#  kind.  You may copy, display, modify and redistribute the software
5#  code either by itself or as incorporated into your code; provided that
6#  you do not remove any proprietary notices.  Your use of this software
7#  code is at your own risk and you waive any claim against Amazon
8#  Digital Services, Inc. or its affiliates with respect to your use of
9#  this software code. (c) 2006-2007 Amazon Digital Services, Inc. or its
10#  affiliates.
11
12package S3::AWSAuthConnection;
13
14use strict;
15use warnings;
16
17use HTTP::Date;
18use URI::Escape;
19use Carp;
20
21use S3 qw($DEFAULT_HOST $PORTS_BY_SECURITY $CALLING_FORMATS merge_meta urlencode);
22use S3::GetResponse;
23use S3::ListBucketResponse;
24use S3::ListAllMyBucketsResponse;
25use S3::LocationResponse;
26use S3::S3Object;
27
28# new(id, key, is_secure=1, server=DEFAULT_HOST, port=DEFAULT, calling_format=DEFAULT)
29sub new {
30    my $proto = shift;
31    my $class = ref($proto) || $proto;
32    my $self  = {};
33    $self->{AWS_ACCESS_KEY_ID} = shift || croak "must specify aws access key id";
34    $self->{AWS_SECRET_ACCESS_KEY} = shift || croak "must specify aws secret access key";
35    $self->{IS_SECURE} = shift;
36    $self->{IS_SECURE} = 1 if (not defined $self->{IS_SECURE});
37    $self->{PROTOCOL} = $self->{IS_SECURE} ? 'https' : 'http';
38    $self->{SERVER} = shift || $DEFAULT_HOST;
39    $self->{PORT} = shift || $PORTS_BY_SECURITY->{$self->{IS_SECURE}};
40    $self->{CALLING_FORMAT} = shift || $CALLING_FORMATS->[0];
41    $self->{AGENT} = LWP::UserAgent->new();
42    bless ($self, $class);
43    return $self;
44}
45
46sub set_calling_format {
47  my ($self, $calling_format) = @_;
48  $self->{CALLING_FORMAT} = $calling_format;
49}
50
51sub get_calling_format {
52  my ($self) = @_;
53  return $self->{CALLING_FORMAT};
54}
55
56sub create_bucket {
57    my ($self, $bucket, $headers) = @_;
58    croak 'must specify bucket' unless $bucket;
59    $headers ||= {};
60
61    return S3::Response->new($self->_make_request('PUT', $bucket, '', {}, $headers));
62}
63
64sub create_located_bucket {
65    my ($self, $bucket, $location, $headers) = @_;
66    croak 'must specify bucket' unless $bucket;
67    $headers ||= {};
68
69	my $data = "";
70	if ($location) {
71        my $data = "<CreateBucketConstraint><LocationConstraint>$location</LocationConstraint></CreateBucketConstraint>"
72    }
73    return S3::Response->new($self->_make_request('PUT', $bucket, '', {}, $headers, $data));
74}
75
76sub get_bucket_location {
77    my ($self, $bucket) = @_;
78    return S3::LocationResponse->new($self->_make_request('GET', $bucket, '', {location => undef}));
79}
80
81sub check_bucket_exists {
82    my ($self, $bucket) = @_;
83    return S3::Response->new($self->_make_request('HEAD', $bucket, '', {}, {}));
84}
85
86sub list_bucket {
87    my ($self, $bucket, $options, $headers) = @_;
88    croak 'must specify bucket' unless $bucket;
89    $options ||= {};
90    $headers ||= {};
91
92    return S3::ListBucketResponse->new($self->_make_request('GET', $bucket, '', $options, $headers));
93}
94
95sub delete_bucket {
96    my ($self, $bucket, $headers) = @_;
97    croak 'must specify bucket' unless $bucket;
98    $headers ||= {};
99
100    return S3::Response->new($self->_make_request('DELETE', $bucket, '', {}, $headers));
101}
102
103sub put {
104    my ($self, $bucket, $key, $object, $headers) = @_;
105    croak 'must specify bucket' unless $bucket;
106    croak 'must specify key' unless $key;
107    $headers ||= {};
108
109    $key = urlencode($key);
110
111    if (ref($object) ne 'S3::S3Object') {
112        $object = S3::S3Object->new($object);
113    }
114
115    return S3::Response->new($self->_make_request('PUT', $bucket, $key, {}, $headers, $object->data, $object->metadata));
116}
117
118sub get {
119    my ($self, $bucket, $key, $headers) = @_;
120    croak 'must specify bucket' unless $bucket;
121    croak 'must specify key' unless $key;
122    $headers ||= {};
123
124    $key = urlencode($key);
125
126    return S3::GetResponse->new($self->_make_request('GET', $bucket, $key, {}, $headers));
127}
128
129sub delete {
130    my ($self, $bucket, $key, $headers) = @_;
131    croak 'must specify bucket' unless $bucket;
132    croak 'must specify key' unless $key;
133    $headers ||= {};
134
135    $key = urlencode($key);
136
137    return S3::Response->new($self->_make_request('DELETE', $bucket, $key, {}, $headers));
138}
139
140sub get_bucket_logging {
141    my ($self, $bucket, $headers) = @_;
142    croak 'must specify bucket' unless $bucket;
143    return S3::GetResponse->new($self->_make_request('GET', $bucket, '', {logging => undef}, $headers));
144}
145
146sub put_bucket_logging {
147    my ($self, $bucket, $logging_xml_doc, $headers) = @_;
148    croak 'must specify bucket' unless $bucket;
149    return S3::Response->new($self->_make_request('PUT', $bucket, '', {logging => undef}, $headers, $logging_xml_doc));
150}
151
152sub get_bucket_acl {
153    my ($self, $bucket, $headers) = @_;
154    croak 'must specify bucket' unless $bucket;
155    return $self->get_acl($bucket, "", $headers);
156}
157
158sub get_acl {
159    my ($self, $bucket, $key, $headers) = @_;
160    croak 'must specify bucket' unless $bucket;
161    croak 'must specify key' unless defined $key;
162    $headers ||= {};
163
164    $key = urlencode($key);
165
166    return S3::GetResponse->new($self->_make_request('GET', $bucket, $key, {acl => undef}, $headers));
167}
168
169sub put_bucket_acl {
170    my ($self, $bucket, $acl_xml_doc, $headers) = @_;
171    return $self->put_acl($bucket, '', $acl_xml_doc, $headers);
172}
173
174sub put_acl {
175    my ($self, $bucket, $key, $acl_xml_doc, $headers) = @_;
176    croak 'must specify acl xml document' unless defined $acl_xml_doc;
177    croak 'must specify bucket' unless $bucket;
178    croak 'must specify key' unless defined $key;
179    $headers ||= {};
180
181    $key = urlencode($key);
182
183    return S3::Response->new(
184        $self->_make_request('PUT', $bucket, $key, {acl => undef}, $headers, $acl_xml_doc));
185}
186
187sub list_all_my_buckets {
188    my ($self, $headers) = @_;
189    $headers ||= {};
190
191    return S3::ListAllMyBucketsResponse->new($self->_make_request('GET', '', '', {}, $headers));
192}
193
194# parameters:
195# * method - "GET","PUT", etc
196# * bucket - the bucket being accessed in this request
197# * path - path within the bucket that will be accessed, possibly ""
198# * path_args - a hash ref giving arguments that go in the url
199# * headers - a hash ref specifying request HTTP headers, may be omitted
200# * data - data to upload for a PUT request (and certain other requests), may be omitted
201# * metadata - hash ref specifying metadata for a PUT request
202sub _make_request {
203    my ($self, $method, $bucket, $path, $path_args, $headers, $data, $metadata) = @_;
204    croak 'must specify method' unless $method;
205    croak 'must specify bucket' unless defined $bucket;
206    $path ||= '';
207    $headers ||= {};
208    $data ||= '';
209    $metadata ||= {};
210
211    my $http_headers = merge_meta($headers, $metadata);
212
213    $self->_add_auth_header($http_headers, $method, $bucket, $path, $path_args);
214    my $url_base = S3::build_url_base($self->{PROTOCOL}, $self->{SERVER}, $self->{PORT}, $bucket, $self->{CALLING_FORMAT});
215    my $url = "$url_base/$path";
216
217    my $arg_string = S3::path_args_hash_to_string($path_args);
218    if ($arg_string) {
219        $url .= "?$arg_string";
220    }
221
222    while (1) {
223	my $request = HTTP::Request->new($method, $url, $http_headers);
224	$request->content($data);
225	my $response = $self->{AGENT}->request($request);
226	# if not redirect, return
227	return $response unless ($response->code >= 300 && $response->code < 400);
228	# retry on returned url
229	$url = $response->header('location');
230	return $response unless $url;
231	croak "bad redirect url: $url" unless $url;
232    }
233}
234
235sub _add_auth_header {
236    my ($self, $headers, $method, $bucket, $path, $path_args) = @_;
237
238    if (not $headers->header('Date')) {
239        $headers->header(Date => time2str(time));
240    }
241    my $canonical_string = S3::canonical_string($method, $bucket, $path, $path_args, $headers);
242    my $encoded_canonical = S3::encode($self->{AWS_SECRET_ACCESS_KEY}, $canonical_string);
243    $headers->header(Authorization => "AWS ".$self->{AWS_ACCESS_KEY_ID}.":$encoded_canonical");
244}
245
2461;
247