File Coverage

blib/lib/Bio/CIPRES.pm

Criterion	Covered	Total	%
statement	27	29	93.1
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	37	39	94.8

package Bio::CIPRES;

use 5.012;
use strict;
use warnings;

use Carp;
use Config::Tiny;
use List::Util qw/first/;
use LWP;
use URI;
use URI::Escape;
use XML::LibXML;

use Bio::CIPRES::Job;
use Bio::CIPRES::Error;

our $VERSION = '0.003001';
our $SERVER  = 'cipresrest.sdsc.edu';
our $API     = 'cipresrest/v1';
our $DOMAIN  = 'Cipres Authentication';

my %required = ( # must be defined after config parsing
    url     => "https://$SERVER/$API/",
    timeout => 60,
    app_id  => 'cipres_perl-E9B8D52FA2A54472BF13F25E4CD957D4',
    user    => undef,
    pass    => undef,
);

my %umb_only = ( # only for UMBRELLA auth
    eu           => undef, # if this is defined, then the rest are:
    eu_email     => undef, # REQUIRED
    app_name     => undef, # REQUIRED
    eu_instition => undef, # optional
    eu_country   => undef, # optional
);

my @eu_headers = qw/
    eu
    eu_email
    eu_institution
    eu_country
/;

sub new {

    my ($class, %args) = @_;
    my $self = bless {}, $class;

    # parse properties from file or constructor
    $self->_parse_args(%args);

    # setup user agent
    $self->{agent} = LWP::UserAgent->new(
        agent    => __PACKAGE__ . "/$VERSION",
        ssl_opts => {verify_hostname => 0},
        timeout  => $self->{cfg}->{timeout},
    );

    # create URI object for easier protocol/port parsing
    $self->{uri} = URI->new( $self->{cfg}->{url} );

    my $netloc = join ':', $self->{uri}->host, $self->{uri}->port;
    $self->{agent}->credentials(
        $netloc,
        $DOMAIN,
        $self->{cfg}->{user},
        $self->{cfg}->{pass}
    );

    my %headers = ( 'cipres-appkey' => $self->{cfg}->{app_id} );

    $self->{account} = $self->{cfg}->{user};

    # UMBRELLA headers
    if (defined $self->{cfg}->{eu}) {
        croak "eu_email required for UMBRELLA authentication"
            if (! defined $self->{cfg}->{'eu_email'});
        croak "app_name required for UMBRELLA authentication"
            if (! defined $self->{cfg}->{'app_name'});
        for my $h (@eu_headers) {
            my $val = $self->{cfg}->{$h} // next;
            $h =~ s/_/\-/g;
            $headers{"cipres-$h"} = $val;
        }

        $self->{account}
            = uri_escape( "$self->{cfg}->{app_name}.$self->{cfg}->{eu}" );
    }

    $self->{uri}->path("/$API/job/$self->{account}");
    $self->{agent}->default_header(%headers);

    return $self;

}

sub _parse_args {

    my ($self, %args) = @_;
    my ($fn_cfg) = delete $args{conf};

    # set defaults
    $self->{cfg} = {%required}; # copy, don't reference!

    # read from config file if asked, overwriting defaults
    if (defined $fn_cfg) {
        croak "Invalid or missing configuration file specified"
            if (! -e $fn_cfg);
        my $cfg = Config::Tiny->read( $fn_cfg )
            or croak "Error reading configuration file: $@";
        $self->{cfg}->{$_} = $cfg->{_}->{$_}
            for (keys %{ $cfg->{_} });

    }

    # read parameters from constructor, overwriting if present
    $self->{cfg}->{$_} = $args{$_} for (keys %args);

    # check that all defined fields are valid
    my @extra = grep {! exists $required{$_} && ! exists $umb_only{$_}}
        keys %{ $self->{cfg} };
    croak "Unexpected config variables found (@extra) -- check syntax"
        if (scalar @extra);

    # check that all required fields are defined
    my @missing = grep {! defined $self->{cfg}->{$_}} keys %required;
    croak "Required config variables missing (@missing) -- check syntax"
        if (scalar @missing);

    # TODO: further parameter validation ???

    # Do necessary url-encoding
    for (qw/user pass/) {
        $self->{cfg}->{$_} = uri_escape( $self->{cfg}->{$_} );
    }

    return 1;

}

sub list_jobs {

    my ($self) = @_;

    my $res = $self->_get( "$self->{uri}?expand=true" );
    my $dom = XML::LibXML->load_xml('string' => $res);

    return map {
        Bio::CIPRES::Job->new( agent => $self->{agent}, dom => $_ )
    } $dom->findnodes('/joblist/jobs/jobstatus');

}

sub get_job {

    my ($self, $handle) = @_;

    my $res = $self->_get( "$self->{uri}/$handle" );
    my $dom = XML::LibXML->load_xml('string' => $res);

    return Bio::CIPRES::Job->new(
        agent => $self->{agent},
        dom   => $dom,
    );

}

sub submit_job {

    my ($self, @args) = @_;

    my $res = $self->_post( $self->{uri}, @args );
    my $dom = XML::LibXML->load_xml('string' => $res);

    return Bio::CIPRES::Job->new(
        agent => $self->{agent},
        dom   => $dom,
    );

}

sub _get {

    my ($self, $url) = @_;

    my $res = $self->{agent}->get( $url )
        or croak "Error fetching file from $url: $@";

    die Bio::CIPRES::Error->new( $res->content )
        if (! $res->is_success);

    return $res->content;

}

sub _post {

    my ($self, $url, @args) = @_;

    my $res = $self->{agent}->post(
        $url,
        [ @args ],
        'content_type' => 'form-data',
    ) or croak "Error POSTing to $url: $@";

    die Bio::CIPRES::Error->new( $res->content )
        if (! $res->is_success);

    return $res->content;

}

1;


__END__