path: root/Bugzilla/Migrate/Gnats.pm

# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0. If a copy of the MPL was not distributed with this
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
#
# This Source Code Form is "Incompatible With Secondary Licenses", as
# defined by the Mozilla Public License, v. 2.0.

package Bugzilla::Migrate::Gnats;

use 5.10.1;
use strict;
use warnings;

use parent qw(Bugzilla::Migrate);

use Bugzilla::Constants;
use Bugzilla::Install::Util qw(indicate_progress);
use Bugzilla::Util qw(format_time trim generate_random_password);

use Email::Address;
use Email::MIME;
use File::Basename;
use IO::File;
use List::MoreUtils qw(firstidx);
use List::Util qw(first);

use constant REQUIRED_MODULES => [
  {
    package => 'Email-Simple-FromHandle',
    module  => 'Email::Simple::FromHandle',

    # This version added seekable handles.
    version => 0.050,
  },
];

use constant FIELD_MAP => {
  'Number'         => 'bug_id',
  'Category'       => 'product',
  'Synopsis'       => 'short_desc',
  'Responsible'    => 'assigned_to',
  'State'          => 'bug_status',
  'Class'          => 'cf_type',
  'Classification' => '',
  'Originator'     => 'reporter',
  'Arrival-Date'   => 'creation_ts',
  'Last-Modified'  => 'delta_ts',
  'Release'        => 'version',
  'Severity'       => 'bug_severity',
  'Description'    => 'comment',
};

use constant VALUE_MAP => {
  bug_severity => {
    'serious'      => 'major',
    'cosmetic'     => 'trivial',
    'new-feature'  => 'enhancement',
    'non-critical' => 'normal',
  },
  bug_status => {
    'open'      => 'CONFIRMED',
    'analyzed'  => 'IN_PROGRESS',
    'suspended' => 'RESOLVED',
    'feedback'  => 'RESOLVED',
    'released'  => 'VERIFIED',
  },
  bug_status_resolution => {
    'feedback'  => 'FIXED',
    'released'  => 'FIXED',
    'closed'    => 'FIXED',
    'suspended' => 'LATER',
  },
  priority => {'medium' => 'Normal',},
};

use constant GNATS_CONFIG_VARS => (
  {
    name    => 'gnats_path',
    default => '/var/lib/gnats',
    desc    => <<END,
# The path to the directory that contains the GNATS database.
END
  },
  {
    name    => 'default_email_domain',
    default => 'example.com',
    desc    => <<'END',
# Some GNATS users do not have full email addresses, but Bugzilla requires
# every user to have an email address. What domain should be appended to
# usernames that don't have emails, to make them into email addresses?
# (For example, if you leave this at the default, "unknown" would become
# "unknown@example.com".)
END
  },
  {
    name    => 'component_name',
    default => 'General',
    desc    => <<'END',
# GNATS has only "Category" to classify bugs. However, Bugzilla has a
# multi-level system of Products that contain Components. When importing
# GNATS categories, they become a Product with one Component. What should
# the name of that Component be?
END
  },
  {
    name    => 'version_regex',
    default => '',
    desc    => <<'END',
# In GNATS, the "version" field can contain almost anything. However, in
# Bugzilla, it's a drop-down, so you don't want too many choices in there.
# If you specify a regular expression here, versions will be tested against
# this regular expression, and if they match, the first match (the first set
# of parentheses in the regular expression, also called "$1") will be used
# as the version value for the bug instead of the full version value specified
# in GNATS.
END
  },
  {
    name    => 'default_originator',
    default => 'gnats-admin',
    desc    => <<'END',
# Sometimes, a PR has no valid Originator, so we fall back to the From
# header of the email. If the From header also isn't a valid username
# (is just a name with spaces in it--we can't convert that to an email
# address) then this username (which can either be a GNATS username or an
# email address) will be considered to be the Originator of the PR.
END
  }
);

sub CONFIG_VARS {
  my $self      = shift;
  my @vars      = (GNATS_CONFIG_VARS, $self->SUPER::CONFIG_VARS);
  my $field_map = first { $_->{name} eq 'translate_fields' } @vars;
  $field_map->{default} = FIELD_MAP;
  my $value_map = first { $_->{name} eq 'translate_values' } @vars;
  $value_map->{default} = VALUE_MAP;
  return @vars;
}

# Directories that aren't projects, or that we shouldn't be parsing
use constant SKIP_DIRECTORIES => qw(
  gnats-adm
  gnats-queue
  pending
);

use constant NON_COMMENT_FIELDS => qw(
  Audit-Trail
  Closed-Date
  Confidential
  Unformatted
  attachments
);

# Certain fields can contain things that look like fields in them,
# because they might contain quoted emails. To avoid mis-parsing,
# we list out here the exact order of fields at the end of a PR
# and wait for the next field to consider that we actually have
# a field to parse.
use constant END_FIELD_ORDER => qw(
  Description
  How-To-Repeat
  Fix
  Release-Note
  Audit-Trail
  Unformatted
);

use constant CUSTOM_FIELDS =>
  {cf_type => {type => FIELD_TYPE_SINGLE_SELECT, description => 'Type',},};

use constant FIELD_REGEX => qr/^>(\S+):\s*(.*)$/;

# Used for bugs that have no Synopsis.
use constant NO_SUBJECT => "(no subject)";

# This is the divider that GNATS uses between attachments in its database
# files. It's missign two hyphens at the beginning because MIME Emails use
# -- to start boundaries.
use constant GNATS_BOUNDARY => '----gnatsweb-attachment----';

use constant LONG_VERSION_LENGTH => 32;

#########
# Hooks #
#########

sub before_insert {
  my $self = shift;

  # gnats_id isn't a valid User::create field, and we don't need it
  # anymore now.
  delete $_->{gnats_id} foreach @{$self->users};

  # Grab a version out of a bug for each product, so that there is a
  # valid "version" argument for Bugzilla::Product->create.
  foreach my $product (@{$self->products}) {
    my $bug = first { $_->{product} eq $product->{name} and $_->{version} }
    @{$self->bugs};
    if (defined $bug) {
      $product->{version} = $bug->{version};
    }
    else {
      $product->{version} = 'unspecified';
    }
  }
}

#########
# Users #
#########

sub _read_users {
  my $self = shift;
  my $path = $self->config('gnats_path');
  my $file = "$path/gnats-adm/responsible";
  $self->debug("Reading users from $file");
  my $default_domain = $self->config('default_email_domain');
  open(my $users_fh, '<', $file) || die "$file: $!";
  my @users;
  foreach my $line (<$users_fh>) {
    $line = trim($line);
    next if $line =~ /^#/;
    my ($id, $name, $email) = split(':', $line, 3);
    $email ||= "$id\@$default_domain";

    # We can't call our own translate_value, because that depends on
    # the existence of user_map, which doesn't exist until after
    # this method. However, we still want to translate any users found.
    $email = $self->SUPER::translate_value('user', $email);
    push(@users, {realname => $name, login_name => $email, gnats_id => $id});
  }
  close($users_fh);
  return \@users;
}

sub user_map {
  my $self = shift;
  $self->{user_map}
    ||= {map { $_->{gnats_id} => $_->{login_name} } @{$self->users}};
  return $self->{user_map};
}

sub add_user {
  my ($self, $id, $email) = @_;
  return if defined $self->user_map->{$id};
  $self->user_map->{$id} = $email;
  push(@{$self->users}, {login_name => $email, gnats_id => $id});
}

sub user_to_email {
  my ($self, $value) = @_;
  if (defined $self->user_map->{$value}) {
    $value = $self->user_map->{$value};
  }
  elsif ($value !~ /@/) {
    my $domain = $self->config('default_email_domain');
    $value = "$value\@$domain";
  }
  return $value;
}

############
# Products #
############

sub _read_products {
  my $self = shift;
  my $path = $self->config('gnats_path');
  my $file = "$path/gnats-adm/categories";
  $self->debug("Reading categories from $file");

  open(my $categories_fh, '<', $file) || die "$file: $!";
  my @products;
  foreach my $line (<$categories_fh>) {
    $line = trim($line);
    next if $line =~ /^#/;
    my ($name, $description, $assigned_to, $cc) = split(':', $line, 4);
    my %product = (name => $name, description => $description);

    my @initial_cc = split(',', $cc);
    @initial_cc = @{$self->translate_value('user', \@initial_cc)};
    $assigned_to = $self->translate_value('user', $assigned_to);
    my %component = (
      name         => $self->config('component_name'),
      description  => $description,
      initialowner => $assigned_to,
      initial_cc   => \@initial_cc
    );
    $product{components} = [\%component];
    push(@products, \%product);
  }
  close($categories_fh);
  return \@products;
}

################
# Reading Bugs #
################

sub _read_bugs {
  my $self        = shift;
  my $path        = $self->config('gnats_path');
  my @directories = glob("$path/*");
  my @bugs;
  foreach my $directory (@directories) {
    next if !-d $directory;
    my $name = basename($directory);
    next if grep($_ eq $name, SKIP_DIRECTORIES);
    push(@bugs, @{$self->_parse_project($directory)});
  }
  @bugs = sort { $a->{Number} <=> $b->{Number} } @bugs;
  return \@bugs;
}

sub _parse_project {
  my ($self, $directory) = @_;
  my @files = glob("$directory/*");

  $self->debug("Reading Project: $directory");

  # Sometimes other files get into gnats directories.
  @files = grep { basename($_) =~ /^\d+$/ } @files;
  my @bugs;
  my $count = 1;
  my $total = scalar @files;
  print basename($directory) . ":\n";
  foreach my $file (@files) {
    push(@bugs, $self->_parse_bug_file($file));
    if (!$self->verbose) {
      indicate_progress({current => $count++, every => 5, total => $total});
    }
  }
  return \@bugs;
}

sub _parse_bug_file {
  my ($self, $file) = @_;
  $self->debug("Reading $file");
  open(my $fh, "<", $file) || die "$file: $!";
  my $email  = Email::Simple::FromHandle->new($fh);
  my $fields = $self->_get_gnats_field_data($email);

  # We parse attachments here instead of during translate_bug,
  # because otherwise we'd be taking up huge amounts of memory storing
  # all the raw attachment data in memory.
  $fields->{attachments} = $self->_parse_attachments($fields);
  close($fh);
  return $fields;
}

sub _get_gnats_field_data {
  my ($self, $email) = @_;
  my ($current_field, @value_lines, %fields);
  $email->reset_handle();
  my $handle = $email->handle;
  foreach my $line (<$handle>) {

    # If this line starts a field name
    if ($line =~ FIELD_REGEX) {
      my ($new_field, $rest_of_line) = ($1, $2);

      # If this is one of the last few PR fields, then make sure
      # that we're getting our fields in the right order.
      my $new_field_valid   = 1;
      my $search_for        = $current_field || '';
      my $current_field_pos = firstidx { $_ eq $search_for }
      END_FIELD_ORDER;
      if ($current_field_pos > -1) {
        my $new_field_pos = firstidx { $_ eq $new_field }
        END_FIELD_ORDER;

        # We accept any field, as long as it's later than this one.
        $new_field_valid = $new_field_pos > $current_field_pos ? 1 : 0;
      }

      if ($new_field_valid) {
        if ($current_field) {
          $fields{$current_field} = _handle_lines(\@value_lines);
          @value_lines = ();
        }
        $current_field = $new_field;
        $line          = $rest_of_line;
      }
    }
    push(@value_lines, $line) if defined $line;
  }
  $fields{$current_field} = _handle_lines(\@value_lines);
  $fields{cc} = [$email->header('Cc')] if $email->header('Cc');

  # If the Originator is invalid and we don't have a translation for it,
  # use the From header instead.
  my $originator
    = $self->translate_value('reporter', $fields{Originator}, {check_only => 1});
  if ($originator !~ Bugzilla->params->{emailregexp}) {

    # We use the raw header sometimes, because it looks like "From: user"
    # which Email::Address won't parse but we can still use.
    my $address = $email->header('From');
    my ($parsed) = Email::Address->parse($address);
    if ($parsed) {
      $address = $parsed->address;
    }
    if ($address) {
      $self->debug("PR $fields{Number} had an Originator that was not a valid"
          . " user ($fields{Originator}). Using From ($address)"
          . " instead.\n");
      my $address_email
        = $self->translate_value('reporter', $address, {check_only => 1});
      if ($address_email !~ Bugzilla->params->{emailregexp}) {
        $self->debug(" From was also invalid, using default_originator.\n");
        $address = $self->config('default_originator');
      }
      $fields{Originator} = $address;
    }
  }

  $self->debug(\%fields, 3);
  return \%fields;
}

sub _handle_lines {
  my ($lines) = @_;
  my $value = join('', @$lines);
  $value =~ s/\s+$//;
  return $value;
}

####################
# Translating Bugs #
####################

sub translate_bug {
  my ($self, $fields) = @_;

  my ($bug, $other_fields) = $self->SUPER::translate_bug($fields);

  $bug->{attachments} = delete $other_fields->{attachments};

  if (defined $other_fields->{_add_to_comment}) {
    $bug->{comment} .= delete $other_fields->{_add_to_comment};
  }

  my ($changes, $extra_comment)
    = $self->_parse_audit_trail($bug, $other_fields->{'Audit-Trail'});

  my @comments;
  foreach my $change (@$changes) {
    if (exists $change->{comment}) {
      push(
        @comments,
        {
          thetext  => $change->{comment},
          who      => $change->{who},
          bug_when => $change->{bug_when}
        }
      );
      delete $change->{comment};
    }
  }
  $bug->{history} = $changes;

  if (trim($extra_comment)) {
    push(
      @comments,
      {
        thetext  => $extra_comment,
        who      => $bug->{reporter},
        bug_when => $bug->{delta_ts} || $bug->{creation_ts}
      }
    );
  }
  $bug->{comments} = \@comments;

  $bug->{component} = $self->config('component_name');
  if (!$bug->{short_desc}) {
    $bug->{short_desc} = NO_SUBJECT;
  }

  foreach my $attachment (@{$bug->{attachments} || []}) {
    $attachment->{submitter}   = $bug->{reporter};
    $attachment->{creation_ts} = $bug->{creation_ts};
  }

  $self->debug($bug, 3);
  return $bug;
}

sub _parse_audit_trail {
  my ($self, $bug, $audit_trail) = @_;
  return [] if !trim($audit_trail);
  $self->debug(" Parsing audit trail...", 2);

  if ($audit_trail !~ /^\S+-Changed-\S+:/ms) {

    # This is just a comment from the bug's creator.
    $self->debug("  Audit trail is just a comment.", 2);
    return ([], $audit_trail);
  }

  my (@changes, %current_data, $current_column, $on_why);
  my $extra_comment = '';
  my $current_field;
  my @all_lines = split("\n", $audit_trail);
  foreach my $line (@all_lines) {

    # GNATS history looks like:
    # Status-Changed-From-To: open->closed
    # Status-Changed-By: jack
    # Status-Changed-When: Mon May 12 14:46:59 2003
    # Status-Changed-Why:
    #     This is some comment here about the change.
    if ($line =~ /^(\S+)-Changed-(\S+):(.*)/) {
      my ($field, $column, $value) = ($1, $2, $3);
      my $bz_field = $self->translate_field($field);

      # If it's not a field we're importing, we don't care about
      # its history.
      next if !$bz_field;

      # GNATS doesn't track values for description changes,
      # unfortunately, and that's the only information we'd be able to
      # use in Bugzilla for the audit trail on that field.
      next if $bz_field eq 'comment';
      $current_field = $bz_field if !$current_field;
      if ($bz_field ne $current_field) {
        $self->_store_audit_change(\@changes, $current_field, \%current_data);
        %current_data  = ();
        $current_field = $bz_field;
      }
      $value = trim($value);
      $self->debug("  $bz_field $column: $value", 3);
      if ($column eq 'From-To') {
        my ($from, $to) = split('->', $value, 2);

        # Sometimes there's just a - instead of a -> between the values.
        if (!defined($to)) {
          ($from, $to) = split('-', $value, 2);
        }
        $current_data{added}   = $to;
        $current_data{removed} = $from;
      }
      elsif ($column eq 'By') {
        my $email = $self->translate_value('user', $value);

        # Sometimes we hit users in the audit trail that we haven't
        # seen anywhere else.
        $current_data{who} = $email;
      }
      elsif ($column eq 'When') {
        $current_data{bug_when} = $self->parse_date($value);
      }
      if ($column eq 'Why') {
        $value = '' if !defined $value;
        $current_data{comment} = $value;
        $on_why = 1;
      }
      else {
        $on_why = 0;
      }
    }
    elsif ($on_why) {

      # "Why" lines are indented four characters.
      $line =~ s/^\s{4}//;
      $current_data{comment} .= "$line\n";
    }
    else {
      $self->debug(
        "Extra Audit-Trail line on $bug->{product} $bug->{bug_id}:" . " $line\n", 2);
      $extra_comment .= "$line\n";
    }
  }
  $self->_store_audit_change(\@changes, $current_field, \%current_data);
  return (\@changes, $extra_comment);
}

sub _store_audit_change {
  my ($self, $changes, $old_field, $current_data) = @_;

  $current_data->{field} = $old_field;
  $current_data->{removed}
    = $self->translate_value($old_field, $current_data->{removed});
  $current_data->{added}
    = $self->translate_value($old_field, $current_data->{added});
  push(@$changes, {%$current_data});
}

sub _parse_attachments {
  my ($self, $fields) = @_;
  my $unformatted    = delete $fields->{'Unformatted'};
  my $gnats_boundary = GNATS_BOUNDARY;

  # A sanity checker to make sure that we're parsing attachments right.
  my $num_attachments = 0;
  $num_attachments++ while ($unformatted =~ /\Q$gnats_boundary\E/g);

  # Sometimes there's a GNATS_BOUNDARY that is on the same line as other data.
  $unformatted =~ s/(\S\s*)\Q$gnats_boundary\E$/$1\n$gnats_boundary/mg;

  # Often the "Unformatted" section starts with stuff before
  # ----gnatsweb-attachment---- that isn't necessary.
  $unformatted =~ s/^\s*From:.+?Reply-to:[^\n]+//s;
  $unformatted = trim($unformatted);
  return [] if !$unformatted;
  $self->debug('Reading attachments...', 2);
  my $boundary = generate_random_password(48);
  $unformatted =~ s/\Q$gnats_boundary\E/--$boundary/g;

  # Sometimes the whole Unformatted section is indented by exactly
  # one space, and needs to be fixed.
  if ($unformatted =~ /--\Q$boundary\E\n /) {
    $unformatted =~ s/^ //mg;
  }
  $unformatted = <<END;
From: nobody
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="$boundary"

This is a multi-part message in MIME format.
--$boundary
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 7bit

$unformatted
--$boundary--
END
  my $email = new Email::MIME(\$unformatted);
  my @parts = $email->parts;

  # Remove the fake body.
  my $part1 = shift @parts;
  if ($part1->body) {
    $self->debug(" Additional Unformatted data found on "
        . $fields->{Category} . " bug "
        . $fields->{Number});
    $self->debug($part1->body, 3);
    $fields->{_add_comment} .= "\n\nUnformatted:\n" . $part1->body;
  }

  my @attachments;
  foreach my $part (@parts) {
    $self->debug('  Parsing attachment: ' . $part->filename);
    my $temp_fh = IO::File->new_tmpfile or die("Can't create tempfile: $!");
    $temp_fh->binmode;
    print $temp_fh $part->body;
    my $content_type = $part->content_type;
    $content_type =~ s/; name=.+$//;
    my $attachment = {
      filename    => $part->filename,
      description => $part->filename,
      mimetype    => $content_type,
      data        => $temp_fh
    };
    $self->debug($attachment, 3);
    push(@attachments, $attachment);
  }

  if (scalar(@attachments) ne $num_attachments) {
    warn "WARNING: Expected $num_attachments attachments but got "
      . scalar(@attachments) . "\n";
    $self->debug($unformatted, 3);
  }
  return \@attachments;
}

sub translate_value {
  my $self = shift;
  my ($field, $value, $options) = @_;
  my $original_value = $value;
  $options ||= {};

  if (!ref($value) and grep($_ eq $field, $self->USER_FIELDS)) {
    if ($value =~ /(\S+\@\S+)/) {
      $value = $1;
      $value =~ s/^<//;
      $value =~ s/>$//;
    }
    else {
      # Sometimes names have extra stuff on the end like "(Somebody's Name)"
      $value =~ s/\s+\(.+\)$//;

      # Sometimes user fields look like "(user)" instead of just "user".
      $value =~ s/^\((.+)\)$/$1/;
      $value = trim($value);
    }
  }

  if ($field eq 'version' and $value ne '') {
    my $version_re = $self->config('version_regex');
    if ($version_re and $value =~ $version_re) {
      $value = $1;
    }

    # In the GNATS that I tested this with, there were many extremely long
    # values for "version" that caused some import problems (they were
    # longer than the max allowed version value). So if the version value
    # is longer than 32 characters, pull out the first thing that looks
    # like a version number.
    elsif (length($value) > LONG_VERSION_LENGTH) {
      $value =~ s/^.+?\b(\d[\w\.]+)\b.+$/$1/;
    }
  }

  my @args = @_;
  $args[1] = $value;

  $value = $self->SUPER::translate_value(@args);
  return $value if ref $value;

  if (grep($_ eq $field, $self->USER_FIELDS)) {
    my $from_value = $value;
    $value = $self->user_to_email($value);
    $args[1] = $value;

    # If we got something new from user_to_email, do any necessary
    # translation of it.
    $value = $self->SUPER::translate_value(@args);
    if (!$options->{check_only}) {
      $self->add_user($from_value, $value);
    }
  }

  return $value;
}

1;

=head1 B<Methods in need of POD>

=over

=item user_map

=item user_to_email

=item add_user

=item translate_value

=item before_insert

=item translate_bug

=item CONFIG_VARS

=back