File Coverage

blib/lib/JIRA/REST.pm

Criterion	Covered	Total	%
statement	32	208	15.3
branch	0	108	0.0
condition	0	60	0.0
subroutine	11	28	39.2
pod	8	8	100.0
total	51	412	12.3

package JIRA::REST;
# ABSTRACT: Thin wrapper around Jira's REST API
$JIRA::REST::VERSION = '0.022';
use 5.016;
use utf8;
use warnings;

use Carp;
use URI;
use Encode;
use MIME::Base64;
use URI::Escape;
use JSON 2.23;
use REST::Client;
use HTTP::CookieJar::LWP;

sub new {
    my ($class, %args) = &_grok_args;

    my ($path, $api) = ($args{url}->path, '/rest/api/latest');
    # See if the user wants a default REST API:
    if ($path =~ s:(/rest/.*)$::) {
        $api = $1;
        $args{url}->path($path);
    }
    # Strip trailing slashes from $path. For some reason they cause 404
    # errors down the road.
    if ($path =~ s:/+$::) {
        $args{url}->path($path);
    }

    unless ($args{anonymous} || $args{pat}) {
        # If username and password are not set we try to lookup the credentials
        if (! defined $args{username} || ! defined $args{password}) {
            ($args{username}, $args{password}) =
                _search_for_credentials($args{url}, $args{username});
        }

        foreach (qw/username password/) {
            croak __PACKAGE__ . "::new: '$_' argument must be a non-empty string.\n"
                if ! defined $args{$_} || ref $args{$_} || length $args{$_} == 0;
        }
    }

    my $rest = REST::Client->new($args{rest_client_config});

    # Set default base URL
    $rest->setHost($args{url});

    # Follow redirects/authentication by default
    $rest->setFollow(1);

    unless ($args{anonymous} || $args{session}) {
        # Since Jira doesn't send an authentication challenge, we force the
        # sending of the authentication header.
        $rest->addHeader(
            Authorization =>
                $args{pat}
                ? "Bearer $args{pat}"
                : 'Basic ' . encode_base64("$args{username}:$args{password}", '')
            );
    }

    for my $ua ($rest->getUseragent) {
        # Configure UserAgent name
        $ua->agent(__PACKAGE__);

        # Set proxy to be used
        $ua->proxy(['http','https'] => $args{proxy}) if $args{proxy};

        # Turn off SSL verification if requested
        $ua->ssl_opts(SSL_verify_mode => 0, verify_hostname => 0) if $args{ssl_verify_none};

        # Configure a cookie_jar so that we can send Cookie headers
        $ua->cookie_jar(HTTP::CookieJar::LWP->new());
    }

    my $jira = bless {
        rest => $rest,
        json => JSON->new->utf8->allow_nonref,
        api  => $api,
    } => $class;

    $jira->{_session} = $jira->POST('/rest/auth/1/session', undef, {
        username => $args{username},
        password => $args{password},
    }) if $args{session};

    return $jira;
}

sub _grok_args {
    my ($class, @args) = @_;

    # Valid option names in the order expected by the old-form constructor
    my @opts = qw/url username password rest_client_config proxy ssl_verify_none anonymous pat session/;

    my %args;

    if (@args == 1 && ref $args[0] && ref $args[0] eq 'HASH') {
        # The new-form constructor expects a single hash reference.
        @args{@opts} = delete @{$args[0]}{@opts};
        croak __PACKAGE__ . "::new: unknown arguments: '", join("', '", sort keys %{$args[0]}), "'.\n"
            if keys %{$args[0]};
    } else {
        # The old-form constructor expects a list of positional parameters.
        @args{@opts} = @args;
    }

    # Turn the url into a URI object
    if (! $args{url}) {
        croak __PACKAGE__ . "::new: 'url' argument must be defined.\n";
    } elsif (! ref $args{url}) {
        $args{url} = URI->new($args{url});
    } elsif (! $args{url}->isa('URI')) {
        croak __PACKAGE__ . "::new: 'url' argument must be a URI object.\n";
    }

    if (!!$args{anonymous} + !!$args{pat} + !!$args{session} > 1) {
        croak __PACKAGE__ . "::new: 'anonymous', 'pat', and 'session' are mutually exclusive options.\n"
    }

    for ($args{rest_client_config}) {
        $_ //= {};
        croak __PACKAGE__ . "::new: 'rest_client_config' argument must be a hash reference.\n"
            unless defined && ref && ref eq 'HASH';
    }

    # remove the REST::Client faux config 'proxy' if set and use it later.
    # This is deprecated since v0.017
    if (my $proxy = delete $args{rest_client_config}{proxy}) {
        carp __PACKAGE__ . "::new: passing 'proxy' in the 'rest_client_config' hash is deprecated. Please, use the corresponding argument instead.\n";
        $args{proxy} //= $proxy;
    }

    return ($class, %args);
}

sub new_session {
    my ($class, @args) = @_;

    if (@args == 1 && ref $args[0] && ref $args[0] eq 'HASH') {
        $args[0]{session} = 1;
    } else {
        $args[8] = 1;
    }

    return $class->new(@args);
}

sub DESTROY {
    my $self = shift;
    $self->DELETE('/rest/auth/1/session') if exists $self->{_session};
    return;
}

sub _search_for_credentials {
    my ($URL, $username) = @_;
    my (@errors, $password);

    # Try .netrc first
    ($username, $password) = eval { _user_pass_from_netrc($URL, $username) };
    push @errors, "Net::Netrc: $@" if $@;
    return ($username, $password) if defined $username && defined $password;

    # Fallback to Config::Identity
    my $stub = $ENV{JIRA_REST_IDENTITY} || "jira";
    ($username, $password) = eval { _user_pass_from_config_identity($stub) };
    push @errors, "Config::Identity: $@" if $@;
    return ($username, $password) if defined $username && defined $password;

    # Still not defined, so we report errors
    for (@errors) {
        chomp;
        s/\n//g;
        s/ at \S+ line \d+.*//;
    }
    croak __PACKAGE__ . "::new: Could not locate credentials. Tried these modules:\n"
        . join("", map { "* $_\n" } @errors)
        . "Please specify the USERNAME and PASSWORD as arguments to new";
}

sub _user_pass_from_config_identity {
    my ($stub) = @_;
    my ($username, $password);
    eval {require Config::Identity; Config::Identity->VERSION(0.0019) }
        or croak "Can't load Config::Identity 0.0019 or later.\n";
    my %id = Config::Identity->load_check( $stub, [qw/username password/] );
    return ($id{username}, $id{password});
}

sub _user_pass_from_netrc {
    my ($URL, $username) = @_;
    my $password;
    eval {require Net::Netrc; 1}
        or croak "Can't require Net::Netrc module.";
    if (my $machine = Net::Netrc->lookup($URL->host, $username)) { # $username may be undef
        $username = $machine->login;
        $password = $machine->password;
    } else {
        croak "No credentials found in the .netrc file.\n";
    }
    return ($username, $password);
}

sub _error {
    my ($self, $content, $type, $code) = @_;

    $type = 'text/plain' unless $type;
    $code = 500          unless $code;

    my $msg = __PACKAGE__ . " Error[$code";

    if (eval {require HTTP::Status}) {
        if (my $status = HTTP::Status::status_message($code)) {
            $msg .= " - $status";
        }
    }

    $msg .= "]:\n";

    if ($type =~ m:text/plain:i) {
        $msg .= $content;
    } elsif ($type =~ m:application/json:) {
        my $error = $self->{json}->decode($content);
        if (ref $error eq 'HASH') {
            # Jira errors may be laid out in all sorts of ways. You have to
            # look them up from the scant documentation at
            # https://docs.atlassian.com/jira/REST/latest/.

            # /issue/bulk tucks the errors one level down, inside the
            # 'elementErrors' hash.
            $error = $error->{elementErrors} if exists $error->{elementErrors};

            # Some methods tuck the errors in the 'errorMessages' array.
            if (my $errorMessages = $error->{errorMessages}) {
                $msg .= "- $_\n" foreach @$errorMessages;
            }

            # And some tuck them in the 'errors' hash.
            if (my $errors = $error->{errors}) {
                $msg .= "- [$_] $errors->{$_}\n" foreach sort keys %$errors;
            }

            # some give us a single message in 'errorMessage'
            $msg .= $error->{errorMessage} . qq{\n} if $error->{errorMessage};
        } else {
            $msg .= $content;
        }
    } elsif ($type =~ m:text/html:i && eval {require HTML::TreeBuilder}) {
        $msg .= HTML::TreeBuilder->new_from_content($content)->as_text;
    } elsif ($type =~ m:^(text/|application|xml):i) {
        $msg .= "$content";
    } else {
        $msg .= "(binary content not shown)";
    };
    $msg =~ s/\n*$/\n/s;       # end message with a single newline
    return $msg;
}

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

    my $rest    = $self->{rest};
    my $code    = $rest->responseCode();
    my $type    = $rest->responseHeader('Content-Type');
    my $content = $rest->responseContent();

    $code =~ /^2/
        or croak $self->_error($content, $type, $code);

    return unless $content;

    if (! defined $type) {
        croak $self->_error("Cannot convert response content with no Content-Type specified.");
    } elsif ($type =~ m:^application/json:i) {
        return $self->{json}->decode($content);
    } elsif ($type =~ m:^text/plain:i) {
        return $content;
    } else {
        croak $self->_error("I don't understand content with Content-Type '$type'.");
    }
}

sub _build_path {
    my ($self, $path, $query) = @_;

    # Prefix $path with the default API prefix unless it already specifies
    # one or it's an absolute URL.
    $path = $self->{api} . $path unless $path =~ m@^(?:/rest/|(?i)https?:)@;

    if (defined $query) {
        croak $self->_error("The QUERY argument must be a hash reference.")
            unless ref $query && ref $query eq 'HASH';
        return $path . '?'. join('&', map {$_ . '=' . uri_escape($query->{$_})} keys %$query);
    } else {
        return $path;
    }
}

sub GET {
    my ($self, $path, $query) = @_;

    $self->{rest}->GET($self->_build_path($path, $query));

    return $self->_content();
}

sub DELETE {
    my ($self, $path, $query) = @_;

    $self->{rest}->DELETE($self->_build_path($path, $query));

    return $self->_content();
}

sub PUT {
    my ($self, $path, $query, $value, $headers) = @_;

    defined $value
        or croak $self->_error("PUT method's 'value' argument is undefined.");

    $path = $self->_build_path($path, $query);

    $headers                   ||= {};
    $headers->{'Content-Type'} //= 'application/json;charset=UTF-8';

    $self->{rest}->PUT($path, $self->{json}->encode($value), $headers);

    return $self->_content();
}

sub POST {
    my ($self, $path, $query, $value, $headers) = @_;

    defined $value
        or croak $self->_error("POST method's 'value' argument is undefined.");

    $path = $self->_build_path($path, $query);

    $headers                   ||= {};
    $headers->{'Content-Type'} //= 'application/json;charset=UTF-8';

    $self->{rest}->POST($path, $self->{json}->encode($value), $headers);

    return $self->_content();
}

sub set_search_iterator {
    my ($self, $params) = @_;

    my %params = ( %$params );  # rebuild the hash to own it

    $params{startAt} = 0;

    $self->{iter} = {
        params  => \%params,    # params hash to be used in the next call
        offset  => 0,           # offset of the next issue to be fetched
        results => {            # results of the last call (this one is fake)
            startAt => 0,
            total   => -1,
            issues  => [],
        },
    };

    return;
}

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

    my $iter = $self->{iter}
        or croak $self->_error("You must call set_search_iterator before calling next_issue");

    if ($iter->{offset} == $iter->{results}{total}) {
        # This is the end of the search results
        $self->{iter} = undef;
        return;
    } elsif ($iter->{offset} == $iter->{results}{startAt} + @{$iter->{results}{issues}}) {
        # Time to get the next bunch of issues
        $iter->{params}{startAt} = $iter->{offset};
        $iter->{results}         = $self->POST('/search', undef, $iter->{params});
    }

    return $iter->{results}{issues}[$iter->{offset}++ - $iter->{results}{startAt}];
}

sub attach_files {
    my ($self, $issueIdOrKey, @files) = @_;

    # We need to violate the REST::Client class encapsulation to implement
    # the HTTP POST method necessary to invoke the /issue/key/attachments
    # REST endpoint because it has to use the form-data Content-Type.

    my $rest = $self->{rest};

    # FIXME: How to attach all files at once?
    foreach my $file (@files) {
        my $response = $rest->getUseragent()->post(
            $rest->getHost . "/rest/api/latest/issue/$issueIdOrKey/attachments",
            %{$rest->{_headers}},
            'X-Atlassian-Token' => 'nocheck',
            'Content-Type'      => 'form-data',
            'Content'           => [ file => [$file, encode_utf8( $file )] ],
        );

        $response->is_success
            or croak $self->_error("attach_files($file): " . $response->status_line);
    }

    return;
}

1;

__END__