File Coverage

blib/lib/App/Smolder/Report.pm

Criterion	Covered	Total	%
statement	130	133	97.7
branch	62	72	86.1
condition			n/a
subroutine	26	26	100.0
pod	0	12	0.0
total	218	243	89.7

package App::Smolder::Report;

use warnings;
use strict;
use 5.008;
use LWP::UserAgent;
use Getopt::Long;
use Carp::Clan qw(App::Smolder::Report);

our $VERSION = '0.04';


###################
# Smolder reporting

sub report {
  my $self = shift;

  $self->{run_as_api} = 1;
  return $self->_do_report(@_);
}

sub _do_report {
  my $self = shift;

  $self->_fatal("Required 'server' setting is empty or missing")
    unless $self->server;
  $self->_fatal("Required 'project_id' setting is empty or missing")
    unless $self->project_id;
  $self->_fatal("Required 'username' setting is empty or missing")
    unless $self->username;
  $self->_fatal("Required 'password' setting is empty or missing")
    unless $self->password;
  $self->_fatal("You must provide at least one report to upload")
    unless @_;

  return $self->_upload_reports(@_);
}

sub _upload_reports {
  my ($self, @reports) = @_;
  my $server = $self->server;
  my $reports_url;

  $server = "http://$server"
    unless $server =~ m/^http/;

  my $ua = LWP::UserAgent->new;
  my $url
    = $server
    . '/app/developer_projects/process_add_report/'
    . $self->project_id;

  REPORT_FILE:
  foreach my $report_file (@reports) {
    $self->_fatal("Could not read report file '$report_file'")
      unless -r $report_file;

    if ($self->dry_run) {
      $self->_log("Dry run: would POST to $url: $report_file");
      next REPORT_FILE;
    }

    my $response = $ua->post(
      $url,
      'Content-Type' => 'form-data',
      'Content'      => [
        username => $self->username,
        password => $self->password,
        tags     => '',
        report_file => [$report_file],
      ],
    );

    if ($response->code == 302) {
      if (! $reports_url) {
        $reports_url = $response->header('Location');
        $reports_url = "$server$reports_url"
          unless $reports_url =~ m/^http/;
      }

      $self->_log("Report '$report_file' sent successfully");

      if ($self->delete) {
        if (!unlink($report_file)) {
          $self->_log("WARNING: could not delete file $report_file: $!");
        }
      }
    }
    else {
      $self->_fatal(
        "Could not upload report '$report_file'",
        "HTTP Code: ".$response->code,
        $response->message,
      );
    }
  }

  $self->_log("See all reports at $reports_url") if $reports_url;
  return $reports_url;
}


###################################
# Configuration loading and merging

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

  my $filename = '.smolder.conf';
  my @files_to_check = ($filename);
  unshift @files_to_check, "$ENV{HOME}/$filename" if $ENV{HOME};
  push @files_to_check, $ENV{APP_SMOLDER_REPORT_CONF}
    if $ENV{APP_SMOLDER_REPORT_CONF};

  foreach my $file (@files_to_check) {
    $self->_merge_cfg_file($file);
  }

  return;
}

sub _merge_cfg_file {
  my ($self, $file) = @_;

  my $cfg = $self->_read_cfg_file($file);
  return unless $cfg;

  $self->_merge_cfg_hash($cfg);

  if (%$cfg) {
    my @bad_keys = sort keys %$cfg;
    $self->_fatal("Invalid configuration keys in $file:", @bad_keys);
  }

  return;
}

sub _read_cfg_file {
  my ($self, $file) = @_;
  my %cfg;
  local $_;

  open(my $fh, '<', $file) || return;
  while (<$fh>) {
    s/^\s+|\s+$//g;
    next if /^(#.*)?$/;

    if (/^(\S+)\s*=\s*(["'])(.*)\2$/) {
      $cfg{$1} = $3;
    }
    elsif (/^(\S+)\s*=\s*(.+)$/) {
      $cfg{$1} = $2;
    }
    else {
      $self->_fatal("Could not parse line $. of $file: $_");
    }
  }
  close($fh);

  return \%cfg;
}

sub _merge_cfg_hash {
  my ($self, $cfg) = @_;

  my @valid_settings = qw{
    server project_id
    username password
    delete
  };
  foreach my $cfg_key (@valid_settings) {
    next unless exists $cfg->{$cfg_key};
    $self->{$cfg_key} = delete $cfg->{$cfg_key};
  }

  return;
}


##################################
# Deal with command line arguments

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

  my ($username, $password, $server, $project_id, $dry_run, $delete, $quiet);
  my $ok = GetOptions(
    "username=s"   => \$username,
    "password=s"   => \$password,
    "server=s"     => \$server,
    "project-id=i" => \$project_id,
    "dry-run|n"    => \$dry_run,
    "quiet"        => \$quiet,
    "delete"       => \$delete,
  );
  exit(2) unless $ok;

  $self->_load_configs;

  $self->{username} = $username     if defined $username;
  $self->{password} = $password     if defined $password;
  $self->{server} = $server         if defined $server;
  $self->{project_id} = $project_id if defined $project_id;
  $self->{dry_run} = $dry_run       if defined $dry_run;
  $self->{quiet} = $quiet           if defined $quiet;
  $self->{delete} = $delete         if defined $delete;

  return;
}

sub run {
  my $self = shift;

  $self->{run_as_api} = 0;
  return $self->_do_report(@_);
}


#######
# Utils

sub _fatal {
  my ($self, $mesg, @more) = @_;

  $mesg = "FATAL: $mesg\n";
  foreach my $line (@more) {
    $mesg .= "  $line\n";
  }

  croak($mesg) if $self->run_as_api;

  print $mesg;
  exit(1);
}

sub _log {
  my ($self, $mesg) = @_;
  return if $self->run_as_api;
  return if $self->quiet;

  print "$mesg\n";

  return;
}


###########################
# Constructor and accessors
#   boring stuff

sub new {
  my $class = shift;
  my $self = bless {}, $class;

  my %args;
  if (ref($_[0])) { %args = %{$_[0]} }
  else            { %args = @_       }

  $self->_load_configs if delete $args{load_config};

  while (my ($k, $v) = each %args) {
    $self->{$k} = $v;
  }

  return $self;
}

sub dry_run    { return $_[0]{dry_run}    }
sub quiet      { return $_[0]{quiet}      }
sub username   { return $_[0]{username}   }
sub password   { return $_[0]{password}   }
sub delete     { return $_[0]{delete}     }
sub project_id { return $_[0]{project_id} }
sub server     { return $_[0]{server}     }
sub run_as_api { return $_[0]{run_as_api} }

__END__