Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 127 lines (106 sloc) 3.54 KB
#!/usr/bin/env perl
use strict;
use warnings;
use Getopt::Long 'GetOptions';
use Path::Tiny 'path';
use Paws;
use Media::Type::Simple;
use Time::Piece;
# A script to upload files to S3
GetOptions(
'bucket=s' => \my $BUCKET,
'delete-stale' => \my $DELETE_STALE,
'files=s' => \my $BASEPATH,
'force' => \my $FORCE,
'max-age=i' => \(my $MAX_AGE = 0),
'mime-types=s' => \(my $MIME_TYPES = '/etc/mime.types'),
'region=s' => \my $REGION,
'strip=s@' => \my $STRIP,
) or die 'unrecognized arguments';
die 'must provide --bucket --region --files'
unless $BUCKET && $REGION && $BASEPATH;
die "directory $BASEPATH not found" unless -d $BASEPATH;
my $s3 = Paws->service('S3', region => $REGION);
my $remote_objects = get_remote_objects($s3);
my $local_objects = upload($s3, $remote_objects);
delete_stale_objects($s3, $remote_objects, $local_objects) if $DELETE_STALE;
# return a hashref of object keys and modified times
sub get_remote_objects {
my ($s3) = @_;
my (%remote_objects, $token, $truncated);
do {
my $response = $s3->ListObjectsV2(
Bucket => $BUCKET,
($token ? (ContinuationToken => $token) : ())
);
for (@{$response->{Contents}}) {
$remote_objects{ $_->{Key} } =
Time::Piece->strptime($_->{LastModified}, '%Y-%m-%dT%T.000Z')->epoch;
}
if($response->{isTruncated}) {
$token = $response->{NextContinuationToken};
$truncated = 1;
}
} while ($truncated);
return \%remote_objects;
}
# upload local files to S3, returns a hashref of local objects
sub upload {
my ($s3, $remote_objects) = @_;
# setup mime types, add missing
open my $mime_types, '<', $MIME_TYPES or die "Can't find $MIME_TYPES $!";
my $media = Media::Type::Simple->new($mime_types);
$media->add_type('application/font-woff2', 'woff2');
my %local_objects = ();
my $iter = path($BASEPATH)->iterator({ recurse => 1 });
while (my $path = $iter->()) {
next if $path->is_dir;
# remove base dir from the object path
my $key = "$path";
my $base = "$BASEPATH";
$key =~ s{$base/}{};
# guess the mime type
my @ext = $path =~ /\.(\w+)$/;
my $mime = eval { @ext ? $media->type_from_ext($ext[0]) : undef };
print STDERR $@ if $@;
print STDERR "failed to get mimetype for $path\n" unless $mime;
# strip file extensions
$key =~ s/\.$_$// for (@$STRIP);
# skip files whose basename would be encoded
# https://github.com/pplu/aws-sdk-perl/issues/111
if ($path->basename !~ qr{^[A-Za-z0-9\-._~/]+$}) {
print STDERR "skipping, path contains illegal characters: $path\n";
next;
}
# unless forced to, only upload when the local file is newer
$local_objects{$key} = [stat "$path"]->[9];
next unless $FORCE || ($remote_objects->{$key} || 0) < $local_objects{$key};
$s3->PutObject(
Bucket => $BUCKET,
Key => $key,
ACL => 'public-read',
Body => $path->slurp_raw,
($MAX_AGE ? (CacheControl => "max-age=$MAX_AGE") : ()),
($mime ? (ContentType => $mime) : () ),
);
print "$key\n";
}
return \%local_objects;
}
# deletes remote objects which do not exist locally
sub delete_stale_objects {
my ($s3, $remote_objects, $local_objects) = @_;
for my $key (keys %{$remote_objects}) {
next if exists $local_objects->{$key};
print STDERR "delete remote object $key? ";
my $answer = <>;
chomp $answer;
if ($answer eq 'y') {
print STDERR "Deleting $key\n";
$s3->DeleteObject(
Bucket => $BUCKET,
Key => $key,
);
}
}
}