File Coverage

blib/lib/WebService/BitbucketServer.pm

Criterion	Covered	Total	%
statement	78	144	54.1
branch	9	50	18.0
condition	6	28	21.4
subroutine	17	23	73.9
pod	3	3	100.0
total	113	248	45.5

package WebService::BitbucketServer;
# ABSTRACT: Bindings for Bitbucket Server REST APIs


use warnings;
use strict;

our $VERSION = '0.605'; # VERSION

use HTTP::AnyUA::Util qw(www_form_urlencode);
use HTTP::AnyUA;
use Module::Load qw(load);
use Scalar::Util qw(weaken);
use Types::Standard qw(Bool Object Str);
use WebService::BitbucketServer::Response;
use WebService::BitbucketServer::Spec qw(api_info documentation_url);

use Moo;
use namespace::clean;

sub _croak { require Carp; Carp::croak(@_) }
sub _usage { _croak("Usage: @_\n") }

sub _debug_log { print STDERR join(' ', @_), "\n" if $ENV{PERL_WEBSERVICE_BITBUCKETSERVER_DEBUG} }


has base_url => (
    is          => 'ro',
    isa         => Str,
    required    => 1,
);


has path => (
    is      => 'lazy',
    isa     => Str,
    default => 'rest',
);


has [qw(username password)] => (
    is  => 'ro',
    isa => Str,
);


has ua => (
    is      => 'lazy',
    default => sub {
        load HTTP::Tiny;
        HTTP::Tiny->new(
            agent   => "perl-webservice-bitbucketserver/$VERSION",
        );
    },
);


has any_ua => (
    is      => 'lazy',
    isa     => Object,
    default => sub {
        my $self = shift;
        HTTP::AnyUA->new(ua => $self->ua);
    },
);


has json => (
    is      => 'lazy',
    isa     => Object,
    default => sub {
        load JSON::MaybeXS;
        JSON::MaybeXS->new(utf8 => 1);
    },
);


has no_security_warning => (
    is      => 'rwp',
    isa     => Bool,
    lazy    => 1,
    default => sub { $ENV{PERL_WEBSERVICE_BITBUCKETSERVER_NO_SECURITY_WARNING} || 0 },
);


my %api_accessors;
while (my ($namespace, $api) = each %WebService::BitbucketServer::Spec::API) {
    my $method  = $api->{id};
    my $package = __PACKAGE__ . '::' . $api->{package};

    next if $api_accessors{$method};
    $api_accessors{$method} = 1;

    no strict 'refs';   ## no critic ProhibitNoStrict
    *{__PACKAGE__."::${method}"} = sub {
        my $self = shift;
        return $self->{$method} if defined $self->{$method};
        load $package;
        my $api = $package->new(context => $self);
        $self->{$method} = $api;
        weaken($self->{$method});
        return $api;
    };
};


sub url {
    my $self = shift;
    my $base = $self->base_url;
    my $path = $self->path;
    $base =~ s!/+$!!;
    $path =~ s!^/+!!;
    return "$base/$path";
}


sub call {
    my $self = shift;
    (@_ == 1 && ref($_[0]) eq 'HASH') || @_ % 2 == 0
        or _usage(q{$api->call(method => $method, url => $url, %options)});
    my $args = @_ == 1 ? shift : {@_};

    $args->{url} or _croak("url is required\n");

    my $method  = $args->{method} || 'GET';
    my $url     = join('/', $self->url, $args->{url});

    my %options;
    $options{headers}{Accept} = '*/*;q=0.2,application/json';       # prefer json response

    $self->_call_add_authorization($args, \%options);

    # request body
    my $data        = $args->{data};
    my $data_type   = $args->{data_type} || 'application/json';
    if ($data) {
        if ($method eq 'GET' || $method eq 'HEAD') {
            my $params  = ref($data) ? www_form_urlencode($data) : $data;
            my $sep     = $url =~ /\?/ ? '&' : '?';
            $url .= "${sep}${params}";
        }
        else {
            if ($data_type eq 'application/json' && ref($data)) {
                $data = $self->json->encode($data);
            }
            $options{content} = $data;
            $options{headers}{'content-type'}   = $data_type;
            $options{headers}{'content-length'} = length $data;
        }
    }

    my $handle_response = sub {
        my $resp = shift;

        return $resp if $args->{raw};

        return WebService::BitbucketServer::Response->new(
            context         => $self,
            request_args    => $args,
            raw             => $resp,
            json            => $self->json,
        );
    };

    my $resp = $self->any_ua->request($method, $url, \%options);

    if ($self->any_ua->response_is_future) {
        return $resp->transform(
            done => $handle_response,
            fail => $handle_response,
        );
    }
    else {
        return $handle_response->($resp);
    }
}

# add the authorization header to request options
sub _call_add_authorization {
    my $self = shift;
    my $args = shift;
    my $opts = shift;

    if ($self->username && $self->password) {
        my $url = $self->base_url;
        if (!$self->no_security_warning && $url !~ /^https/) {
            warn "Bitbucket Server authorization is being transferred unencrypted to $url !!!\n";
            $self->_set_no_security_warning(0);
        }

        my $payload = $self->username . ':' . $self->password;
        require MIME::Base64;
        my $auth_token = MIME::Base64::encode_base64($payload, '');
        $opts->{headers}{'authorization'} = "Basic $auth_token";
    }
}


sub write_api_packages {
    my $self = shift;
    (@_ == 1 && ref($_[0]) eq 'HASH') || @_ % 2 == 0
        or _usage(q{$api->write_api_packages(%args)});
    my $args = @_ == 1 ? shift : {@_};

    $self = __PACKAGE__->new(base_url => '') unless ref $self;

    require WebService::BitbucketServer::WADL;

    my $handle_response = sub {
        my $resp = shift;

        if (!$resp->{success}) {
            warn "Failed to fetch $resp->{url} - $resp->{status} $resp->{reason}\n";
            return;
        }

        $self->_debug_log('Fetched WADL', $resp->{url});

        my $wadl = WebService::BitbucketServer::WADL::parse_wadl($resp->{content});

        my $api_info = api_info($wadl);
        if (!$api_info) {
            warn "Missing API info: $resp->{url}\n";
            return;
        }

        my ($package_code, $package) = WebService::BitbucketServer::WADL::generate_package($wadl, %$args, base => __PACKAGE__);

        require File::Path;
        require File::Spec;

        my @pm  = ($args->{dir} ? $args->{dir} : (), _mod_to_pm($package));
        my $pm  = File::Spec->catfile(@pm);
        my $dir = File::Spec->catdir(@pm[0 .. (scalar @pm - 2)]);

        File::Path::make_path($dir);

        # write the pm
        open(my $fh, '>', $pm) or die "open failed ($pm): $!";
        print $fh $package_code;
        close($fh);

        my $submap = WebService::BitbucketServer::WADL::generate_submap($wadl, %$args);

        my $filename = "submap_$api_info->{id}.pl";

        my $filepath = File::Spec->catfile(qw{shares spec}, $filename);
        $dir = File::Spec->catdir(qw{shares spec});

        File::Path::make_path($dir);

        # write the subroutine map
        open($fh, '>', $filepath) or die "open failed ($filepath): $!";
        print $fh $submap;
        close($fh);
    };

    my @responses;
    my %requested;

    for my $namespace (keys %WebService::BitbucketServer::Spec::API) {
        my $url  = documentation_url($namespace, 'wadl', $args->{version});

        next if $requested{$url};
        $requested{$url} = 1;

        my $resp = $self->any_ua->get($url);
        if ($self->any_ua->response_is_future) {
            push @responses, $resp->transform(
                done => $handle_response,
                fail => $handle_response,
            );
        }
        else {
            push @responses, $handle_response->($resp);
        }
    }

    if ($self->any_ua->response_is_future) {
        return Future->wait_all(@responses);
    }
    else {
        return \@responses;
    }
}

sub _mod_to_pm {
    my $mod = shift;
    my @parts = split(/::/, $mod);
    $parts[-1] = "$parts[-1].pm";
    return @parts;
}

1;

__END__