gh-deploy.pl

gh-deploy.pl

#!/usr/bin/env perl

# This script is free software; you can redistribute it and/or modify it under the same terms
# as Perl 5.10.0. For more details, see http://dev.perl.org/licenses/.

package github_downloader;
use Moose;
with 'MooseX::Getopt';

use YAML::Any;
use HTTP::Request::Common 'POST';
use LWP::UserAgent;
use List::Util 'first';
use Archive::Extract;

has login    => (is => 'rw', isa => 'Str', required => 1);
has token    => (is => 'rw', isa => 'Str', required => 1);
has tag      => (is => 'rw', isa => 'Str', required => 1);
has download => (is => 'rw', isa => 'Bool');
has unpack   => (is => 'rw', isa => 'Bool');
has repo     => (is => 'rw', isa => 'Str', required => 1);
has ua       => (
    is => 'ro',
    default => sub { LWP::UserAgent->new },
    metaclass => 'NoGetopt'
);

sub gh_v2_request {
    my $self = shift;
    my $path = shift;
    my $response = $self->ua->request(
        POST "https://github.com/api/v2/yaml/repos/show/$path",
        [login => $self->login, token => $self->token, @_]
    );
    return Load($response->content)->{tags};
}

sub tags {
    my $self = shift;
    return $self->gh_v2_request($self->repo . '/tags');
}

sub download_tag {
    my $self = shift;
    my $tag = shift;

    $self->ua->requests_redirectable([qw{ GET HEAD POST }]);
    my $filename = "$tag.tar.gz";
    my $response = $self->ua->request(
        POST(join(
            '/',
            'https://github.com',
            $self->repo,
            'tarball',
            $tag),
            [login => $self->login, token => $self->token]),
        $filename
    );
    
    return $response->is_error ? () : $filename;
}

sub tag_re {
    my $self = shift;
    my $tag  = $self->tag;

    my $tag_re = $tag;
    if($tag =~ /[\*\?]/) {
        $tag_re =~ s/\*/.*/g;
        $tag_re =~ s/\?/.?/g;
    }
    
    return qr/^$tag_re$/;
}

sub matching_tags {
    my $self = shift;
    
    my $tags = $self->tags;
    delete $tags->{$_}
        for grep { $_ !~ $self->tag_re } keys %$tags;
    
    return $tags;
}

sub unpack_file {
    my $self 	 = shift;
    my $filename = shift;
    
    my $tmpdir = ".tmp.$$." . rand();
    mkdir $tmpdir;
    my $ae = Archive::Extract->new(archive => $filename);
    $ae->extract or die "Failed unpacking $filename: $!";

    return $ae->extract_path;
}

sub repo_base {
    my $base = shift->repo;
    $base =~ s{/}{-}g;
    return $base;
}

sub main {
    my $self = shift;

    my $matching_tags = $self->matching_tags;
        
    if(%$matching_tags) {
        for(keys %$matching_tags) {
            print "$_: $matching_tags->{$_}\n";
            if($self->download) {
                my $filename = $self->download_tag($_);
                if($self->unpack) {
                    my $path = $self->unpack_file($filename);
                    symlink $path, $self->repo_base . '-' . $_;
                }
            }
        }
    }
}
    
1;

github_downloader->new_with_options->main;