request-tracker4 4.4.1-3+deb9u3 / usr / sbin / rt-validator-4

#!/usr/bin/perl
# BEGIN BPS TAGGED BLOCK {{{
#
# COPYRIGHT:
#
# This software is Copyright (c) 1996-2016 Best Practical Solutions, LLC
#                                          <sales@bestpractical.com>
#
# (Except where explicitly superseded by other copyright notices)
#
#
# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
# from www.gnu.org.
#
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 or visit their web page on the internet at
# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
#
#
# CONTRIBUTION SUBMISSION POLICY:
#
# (The following paragraph is not intended to limit the rights granted
# to you to modify and distribute this software under the terms of
# the GNU General Public License and is only of importance to you if
# you choose to contribute your changes and enhancements to the
# community by submitting them to Best Practical Solutions, LLC.)
#
# By intentionally submitting any modifications, corrections or
# derivatives to this work, or any other work intended for use with
# Request Tracker, to Best Practical Solutions, LLC, you confirm that
# you are the copyright holder for those contributions and you grant
# Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
# royalty-free, perpetual, license to use, copy, create derivative
# works based on those contributions, and sublicense and distribute
# those contributions and any derivatives thereof.
#
# END BPS TAGGED BLOCK }}}
use strict;
use warnings;

# fix lib paths, some may be relative
BEGIN { # BEGIN RT CMD BOILERPLATE
    require File::Spec;
    require Cwd;
    my @libs = ("/usr/share/request-tracker4/lib", "/usr/local/share/request-tracker4/lib");
    my $bin_path;

    for my $lib (@libs) {
        unless ( File::Spec->file_name_is_absolute($lib) ) {
            $bin_path ||= ( File::Spec->splitpath(Cwd::abs_path(__FILE__)) )[1];
            $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib );
        }
        unshift @INC, $lib;
    }

}

use RT::Interface::CLI qw(Init);
my %opt = ();
Init(
    \%opt,
    'check|c',
    'resolve',
    'force',
    'verbose|v',
    'links-only',
);

Pod::Usage::pod2usage( { verbose => 2 } ) unless $opt{check};

usage_warning() if $opt{'resolve'} && !$opt{'force'};

sub usage_warning {
    print <<END;
This utility can fix some issues with DB by creating or updating. In some
cases there is not enough data to resurect a missing record, but records which
refer to a missing record can be deleted. It's up to you to decide what to do.

In any case it's highly recommended to have a backup before resolving anything.

Press enter to continue.
END
# Read a line of text, any line of text
    <STDIN>;
}

my $dbh = $RT::Handle->dbh;
my $db_type = RT->Config->Get('DatabaseType');

my %TYPE = (
    'Transactions.Field'    => 'text',
    'Transactions.OldValue' => 'text',
    'Transactions.NewValue' => 'text',
);

my @models = qw(
    ACE
    Article
    Attachment
    Attribute
    CachedGroupMember
    CustomField
    CustomFieldValue
    GroupMember
    Group
    Link
    ObjectCustomField
    ObjectCustomFieldValue
    Principal
    Queue
    ScripAction
    ScripCondition
    Scrip
    ObjectScrip
    Template
    Ticket
    Transaction
    User
);

my %redo_on;
$redo_on{'Delete'} = {
    ACL => [],

    Attributes => [],

    Links => [],

    CustomFields => [],
    CustomFieldValues => [],
    ObjectCustomFields => [],
    ObjectCustomFieldValues => [],

    Queues => [],

    Scrips => [],
    ObjectScrips => [],
    ScripActions => [],
    ScripConditions => [],
    Templates => [],

    Tickets => [ 'Tickets -> other', 'Tickets <-> Role Groups' ],
    Transactions => [ 'Attachments -> other' ],

    Principals => ['User <-> ACL equivalence group', 'GMs -> Groups, Members' ],
    Users => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'Principals -> Users' ],
    Groups => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'CGM vs. GM', 'Principals -> Groups' ],

    GroupMembers => [ 'CGM vs. GM' ],
    CachedGroupMembers => [ 'CGM vs. GM' ],
};
$redo_on{'Create'} = {
    Principals => ['User <-> ACL equivalence group', 'GMs -> Groups, Members' ],
    Groups => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'CGM vs. GM' ],
    GroupMembers => [ 'CGM vs. GM' ],
    CachedGroupMembers => [ 'CGM vs. GM' ],
};
$redo_on{'Update'} = {
    Groups => ['User Defined Group Name uniqueness'],
};

my %describe_cb;
%describe_cb = (
    Attachments => sub {
        my $row = shift;
        my $txn_id = $row->{transactionid};
        my $res = 'Attachment #'. $row->{id} .' -> Txn #'. $txn_id;
        return $res .', '. describe( 'Transactions', $txn_id );
    },
    Transactions => sub {
        my $row = shift;
        return 'Transaction #'. $row->{id} .' -> object '. $row->{objecttype} .' #'. $row->{objectid};
    },
);

{ my %cache = ();
sub m2t($) {
    my $model = shift;
    return $cache{$model} if $cache{$model};
    my $class = "RT::$model";
    my $object = $class->new( RT->SystemUser );
    return $cache{$model} = $object->Table;
} }

my (@do_check, %redo_check);

my @CHECKS;
foreach my $table ( qw(Users Groups) ) {
    push @CHECKS, "$table -> Principals" => sub {
        my $msg = "A record in $table refers to a nonexistent record in Principals."
            ." The script can either create the missing record in Principals"
            ." or delete the record in $table.";
        my ($type) = ($table =~ /^(.*)s$/);
        return check_integrity(
            $table, 'id' => 'Principals', 'id',
            join_condition => 't.PrincipalType = ?',
            bind_values => [ $type ],
            action => sub {
                my $id = shift;
                return unless my $a = prompt_action( ['Create', 'delete'], $msg );

                if ( $a eq 'd' ) {
                    delete_record( $table, $id );
                }
                elsif ( $a eq 'c' ) {
                    my $principal_id = create_record( 'Principals',
                        id => $id, PrincipalType => $type, Disabled => 0
                    );
                }
                else {
                    die "Unknown action '$a'";
                }
            },
        );
    };

    push @CHECKS, "Principals -> $table" => sub {
        my $msg = "A record in Principals refers to a nonexistent record in $table."
            ." In some cases it's possible to manually resurrect such records,"
            ." but this utility can only delete records.";

        return check_integrity(
            'Principals', 'id' => $table, 'id',
            condition   => 's.PrincipalType = ?',
            bind_values => [ $table =~ /^(.*)s$/ ],
            action => sub {
                my $id = shift;
                return unless prompt( 'Delete', $msg );

                delete_record( 'Principals', $id );
            },
        );
    };
}

push @CHECKS, 'User <-> ACL equivalence group' => sub {
    my $res = 1;
    # from user to group
    $res *= check_integrity(
        'Users', 'id' => 'Groups', 'Instance',
        join_condition   => 't.Domain = ? AND t.Name = ?',
        bind_values => [ 'ACLEquivalence',  'UserEquiv' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Create', "Found a user that has no ACL equivalence group."
            );

            my $gid = create_record( 'Groups',
                Domain => 'ACLEquivalence', Name => 'UserEquiv', Instance => $id,
            );
        },
    );
    # from group to user
    $res *= check_integrity(
        'Groups', 'Instance' => 'Users', 'id',
        condition   => 's.Domain = ? AND s.Name = ?',
        bind_values => [ 'ACLEquivalence',  'UserEquiv' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a user ACL equivalence group, but there is no user."
            );

            delete_record( 'Groups', $id );
        },
    );
    # one ACL equiv group for each user
    $res *= check_uniqueness(
        'Groups',
        columns     => ['Instance'],
        condition   => '.Domain = ? AND .Name = ?',
        bind_values => [ 'ACLEquivalence',  'UserEquiv' ],
    );
    return $res;
};

# check integrity of Queue role groups
push @CHECKS, 'Queues <-> Role Groups' => sub {
    # XXX: we check only that there is at least one group for a queue
    # from queue to group
    my $res = 1;
    $res *= check_integrity(
        'Queues', 'id' => 'Groups', 'Instance',
        join_condition   => 't.Domain = ?',
        bind_values => [ 'RT::Queue-Role' ],
    );
    # from group to queue
    $res *= check_integrity(
        'Groups', 'Instance' => 'Queues', 'id',
        condition   => 's.Domain = ?',
        bind_values => [ 'RT::Queue-Role' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a role group of a nonexistent queue."
            );

            delete_record( 'Groups', $id );
        },
    );
    return $res;
};

# check integrity of Ticket role groups
push @CHECKS, 'Tickets <-> Role Groups' => sub {
    # XXX: we check only that there is at least one group for a queue
    # from queue to group
    my $res = 1;
    $res *= check_integrity(
        'Tickets', 'id' => 'Groups', 'Instance',
        join_condition   => 't.Domain = ?',
        bind_values => [ 'RT::Ticket-Role' ],
    );
    # from group to ticket
    $res *= check_integrity(
        'Groups', 'Instance' => 'Tickets', 'id',
        condition   => 's.Domain = ?',
        bind_values => [ 'RT::Ticket-Role' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a role group of a nonexistent ticket."
            );

            delete_record( 'Groups', $id );
        },
    );
    return $res;
};

# additional CHECKS on groups
push @CHECKS, 'Role Groups (Instance, Name) uniqueness' => sub {
    # Check that Domain, Instance and Name are unique
    return check_uniqueness(
        'Groups',
        columns     => ['Domain', 'Instance', 'Name'],
        condition   => '.Domain LIKE ?',
        bind_values => [ '%-Role' ],
    );
};

push @CHECKS, 'System internal group uniqueness' => sub {
    return check_uniqueness(
        'Groups',
        columns     => ['Instance', 'Name'],
        condition   => '.Domain = ?',
        bind_values => [ 'SystemInternal' ],
    );
};

# CHECK that user defined group names are unique
push @CHECKS, 'User Defined Group Name uniqueness' => sub {
    return check_uniqueness(
        'Groups',
        columns         => ['Name'],
        condition       => '.Domain = ?',
        bind_values     => [ 'UserDefined' ],
        extra_tables    => ['Principals sp', 'Principals tp'],
        extra_condition => join(" and ", map { "$_.id = ${_}p.id and ${_}p.PrincipalType = ? and ${_}p.Disabled != 1" } qw(s t)),
        extra_values    => ['Group', 'Group'],
        action          => sub {
            return unless prompt(
                'Rename', "Found a user defined group with a non-unique Name."
            );

            my $id = shift;
            my %cols = @_;
            update_records('Groups', { id => $id }, { Name => join('-', $cols{'Name'}, $id) });
        },
    );
};

push @CHECKS, 'Custom Role Name uniqueness' => sub {
    return check_uniqueness(
        'CustomRoles',
        columns         => ['Name'],
        action          => sub {
            return unless prompt(
                'Rename', "Found a custom role with a non-unique Name."
            );

            my $id = shift;
            my %cols = @_;
            update_records('CustomRoles', { id => $id }, { Name => join('-', $cols{'Name'}, $id) });
        },
    );
};

push @CHECKS, 'GMs -> Groups, Members' => sub {
    my $msg = "A record in GroupMembers references an object that doesn't exist."
        ." Maybe you deleted a group or principal directly from the database?"
        ." Usually it's OK to delete such records.";
    my $res = 1;
    $res *= check_integrity(
        'GroupMembers', 'GroupId' => 'Groups', 'id',
        action => sub {
            my $id = shift;
            return unless prompt( 'Delete', $msg );

            delete_record( 'GroupMembers', $id );
        },
    );
    $res *= check_integrity(
        'GroupMembers', 'MemberId' => 'Principals', 'id',
        action => sub {
            my $id = shift;
            return unless prompt( 'Delete', $msg );

            delete_record( 'GroupMembers', $id );
        },
    );
    return $res;
};

# CGM and GM
push @CHECKS, 'CGM vs. GM' => sub {
    my $res = 1;
    # all GM record should be duplicated in CGM
    $res *= check_integrity(
        GroupMembers       => ['GroupId', 'MemberId'],
        CachedGroupMembers => ['GroupId', 'MemberId'],
        join_condition     => 't.ImmediateParentId = t.GroupId AND t.Via = t.id',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Create',
                "Found a record in GroupMembers that has no direct duplicate in CachedGroupMembers table."
            );

            my $gm = RT::GroupMember->new( RT->SystemUser );
            $gm->Load( $id );
            die "Couldn't load GM record #$id" unless $gm->id;
            my $cgm = create_record( 'CachedGroupMembers',
                GroupId => $gm->GroupId, MemberId => $gm->MemberId,
                ImmediateParentId => $gm->GroupId, Via => undef,
                Disabled => 0, # XXX: we should check integrity of Disabled field
            );
            update_records( "CachedGroupMembers", { id => $cgm }, { Via => $cgm } );
        },
    );
    # all first level CGM records should have a GM record
    $res *= check_integrity(
        CachedGroupMembers => ['GroupId', 'MemberId'],
        GroupMembers       => ['GroupId', 'MemberId'],
        condition     => 's.ImmediateParentId = s.GroupId AND s.Via = s.id AND s.GroupId != s.MemberId',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete',
                "Found a record in CachedGroupMembers for a (Group, Member) pair"
                ." that doesn't exist in the GroupMembers table."
            );

            delete_record( 'CachedGroupMembers', $id );
        },
    );
    # each group should have a CGM record where MemberId == GroupId
    $res *= check_integrity(
        Groups => ['id', 'id'],
        CachedGroupMembers => ['GroupId', 'MemberId'],
        join_condition     => 't.ImmediateParentId = t.GroupId AND t.Via = t.id',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Create',
                "Found a record in Groups that has no direct"
                ." duplicate in CachedGroupMembers table."
            );

            my $g = RT::Group->new( RT->SystemUser );
            $g->Load( $id );
            die "Couldn't load group #$id" unless $g->id;
            die "Loaded group by $id has id ". $g->id  unless $g->id == $id;
            my $cgm = create_record( 'CachedGroupMembers',
                GroupId => $id, MemberId => $id,
                ImmediateParentId => $id, Via => undef,
                Disabled => $g->Disabled,
            );
            update_records( "CachedGroupMembers", { id => $cgm }, { Via => $cgm } );
        },
    );

    # and back, each record in CGM with MemberId == GroupId without exceptions
    # should reference a group
    $res *= check_integrity(
        CachedGroupMembers => ['GroupId', 'MemberId'],
        Groups => ['id', 'id'],
        condition => "s.GroupId = s.MemberId",
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete',
                "Found a record in CachedGroupMembers for a group that doesn't exist."
            );

            delete_record( 'CachedGroupMembers', $id );
        },
    );
    # Via
    $res *= check_integrity(
        CachedGroupMembers => 'Via',
        CachedGroupMembers => 'id',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete',
                "Found a record in CachedGroupMembers with Via that references a nonexistent record."
            );

            delete_record( 'CachedGroupMembers', $id );
        },
    );

    # for every CGM where ImmediateParentId != GroupId there should be
    # matching parent record (first level) 
    $res *= check_integrity(
        CachedGroupMembers => ['ImmediateParentId', 'MemberId'],
        CachedGroupMembers => ['GroupId', 'MemberId'],
        join_condition => 't.Via = t.id',
        condition => 's.ImmediateParentId != s.GroupId',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete',
                "Found a record in CachedGroupMembers that references a nonexistent record in CachedGroupMembers table."
            );

            delete_record( 'CachedGroupMembers', $id );
        },
    );

    # for every CGM where ImmediateParentId != GroupId there should be
    # matching "grand" parent record
    $res *= check_integrity(
        CachedGroupMembers => ['GroupId', 'ImmediateParentId', 'Via'],
        CachedGroupMembers => ['GroupId', 'MemberId', 'id'],
        condition => 's.ImmediateParentId != s.GroupId',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete',
                "Found a record in CachedGroupMembers that references a nonexistent record in CachedGroupMembers table."
            );

            delete_record( 'CachedGroupMembers', $id );
        },
    );

    # CHECK recursive records:
    # if we have CGM1 (G1,M1,V1,IP1) then for every GM2(G2, M2), where G2 == M1,
    # we should have CGM3 where G3 = G1, M3 = M2, V3 = ID1, IP3 = M1
    {
        my $query = <<END;
SELECT cgm1.GroupId, gm2.MemberId, cgm1.id AS Via,
    cgm1.MemberId AS ImmediateParentId, cgm1.Disabled
FROM
    CachedGroupMembers cgm1
    CROSS JOIN GroupMembers gm2
    LEFT JOIN CachedGroupMembers cgm3 ON (
            cgm3.GroupId           = cgm1.GroupId
        AND cgm3.MemberId          = gm2.MemberId
        AND cgm3.Via               = cgm1.id
        AND cgm3.ImmediateParentId = cgm1.MemberId )
WHERE cgm1.GroupId != cgm1.MemberId
AND gm2.GroupId = cgm1.MemberId
AND cgm3.id IS NULL
END

        my $action = sub {
            my %props = @_;
            return unless prompt(
                'Create',
                "Found records in CachedGroupMembers table without recursive duplicates."
            );
            my $cgm = create_record( 'CachedGroupMembers', %props );
        };

        my $sth = execute_query( $query );
        while ( my ($g, $m, $via, $ip, $dis) = $sth->fetchrow_array ) {
            $res = 0;
            print STDERR "Principal #$m is member of #$ip when #$ip is member of #$g,";
            print STDERR " but there is no cached GM record that $m is member of #$g.\n";
            $action->(
                GroupId => $g, MemberId => $m, Via => $via,
                ImmediateParentId => $ip, Disabled => $dis,
            );
        }
    }

    return $res;
};

# Tickets
push @CHECKS, 'Tickets -> other' => sub {
    my $res = 1;
    $res *= check_integrity(
        'Tickets', 'EffectiveId' => 'Tickets', 'id',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete',
                "Found a ticket that's been merged into a ticket that no longer exists."
            );

            delete_record( 'Tickets', $id );
        },
    );
    $res *= check_integrity(
        'Tickets', 'Queue' => 'Queues', 'id',
    );
    $res *= check_integrity(
        'Tickets', 'Owner' => 'Users', 'id',
         action => sub {
             my ($id, %prop) = @_;
             return unless my $replace_with = prompt_integer(
                 'Replace',
                 "Column Owner should point to a user, but there is record #$id in Tickets\n"
                 ."where it's not true. It's ok to replace these wrong references with id of any user.\n"
                 ."Note that id you enter is not checked. You can pick any user from your DB, but it's\n"
                 ."may be better to create a special user for this, for example 'user_that_has_been_deleted'\n"
                 ."or something like that.",
                 "Tickets.Owner -> user #$prop{Owner}"
             );
             update_records( 'Tickets', { id => $id, Owner => $prop{Owner} }, { Owner => $replace_with } );
         },
    );
    # XXX: check that owner is only member of owner role group
    return $res;
};


push @CHECKS, 'Transactions -> other' => sub {
    my $res = 1;
    foreach my $model ( @models ) {
        $res *= check_integrity(
            'Transactions', 'ObjectId' => m2t($model), 'id',
            condition   => 's.ObjectType = ?',
            bind_values => [ "RT::$model" ],
            action => sub {
                my $id = shift;
                return unless prompt(
                    'Delete', "Found a transaction without object."
                );

                delete_record( 'Transactions', $id );
            },
        );
    }
    # type = CustomField
    $res *= check_integrity(
        'Transactions', 'Field' => 'CustomFields', 'id',
        condition   => 's.Type = ?',
        bind_values => [ 'CustomField' ],
    );
    # type = Take, Untake, Force, Steal or Give
    $res *= check_integrity(
        'Transactions', 'OldValue' => 'Users', 'id',
        condition   => 's.Type IN (?, ?, ?, ?, ?)',
        bind_values => [ qw(Take Untake Force Steal Give) ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a transaction regarding Owner changes,"
                ." but the User with id stored in OldValue column doesn't exist anymore."
            );

            delete_record( 'Transactions', $id );
        },
    );
    $res *= check_integrity(
        'Transactions', 'NewValue' => 'Users', 'id',
        condition   => 's.Type IN (?, ?, ?, ?, ?)',
        bind_values => [ qw(Take Untake Force Steal Give) ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a transaction regarding Owner changes,"
                ." but the User with id stored in NewValue column doesn't exist anymore."
            );

            delete_record( 'Transactions', $id );
        },
    );
    # type = DelWatcher
    $res *= check_integrity(
        'Transactions', 'OldValue' => 'Principals', 'id',
        condition   => 's.Type = ?',
        bind_values => [ 'DelWatcher' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a transaction describing watcher changes,"
                ." but the User with id stored in OldValue column doesn't exist anymore."
            );

            delete_record( 'Transactions', $id );
        },
    );
    # type = AddWatcher
    $res *= check_integrity(
        'Transactions', 'NewValue' => 'Principals', 'id',
        condition   => 's.Type = ?',
        bind_values => [ 'AddWatcher' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a transaction describing watcher changes,"
                ." but the User with id stored in NewValue column doesn't exist anymore."
            );

            delete_record( 'Transactions', $id );
        },
    );

#   type = DeleteLink or AddLink
#   handled in 'Links: *' checks as {New,Old}Value store URIs

    # type = Set, Field = Queue
    $res *= check_integrity(
        'Transactions', 'NewValue' => 'Queues', 'id',
        condition   => 's.Type = ? AND s.Field = ?',
        bind_values => [ 'Set', 'Queue' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a transaction describing a queue change,"
                ." but the Queue with id stored in the NewValue column doesn't exist anymore."
            );

            delete_record( 'Transactions', $id );
        },
    );
    $res *= check_integrity(
        'Transactions', 'OldValue' => 'Queues', 'id',
        condition   => 's.Type = ? AND s.Field = ?',
        bind_values => [ 'Set', 'Queue' ],
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found a transaction describing a queue change,"
                ." but the Queue with id stored in the OldValue column doesn't exist anymore."
            );

            delete_record( 'Transactions', $id );
        },
    );
    # Reminders
    $res *= check_integrity(
        'Transactions', 'NewValue' => 'Tickets', 'id',
        join_condition => 't.Type = ?',
        condition      => 's.Type IN (?, ?, ?)',
        bind_values    => [ 'reminder', 'AddReminder', 'OpenReminder', 'ResolveReminder' ],
    );
    return $res;
};

# Attachments
push @CHECKS, 'Attachments -> other' => sub {
    my $res = 1;
    $res *= check_integrity(
        Attachments  => 'TransactionId', Transactions => 'id',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found an attachment without a transaction."
            );
            delete_record( 'Attachments', $id );
        },
    );
    $res *= check_integrity(
        Attachments => 'Parent', Attachments => 'id',
        action => sub {
            my $id = shift;
            return unless prompt(
                'Delete', "Found an sub-attachment without its parent attachment."
            );
            delete_record( 'Attachments', $id );
        },
    );
    $res *= check_integrity(
        Attachments => 'Parent',
        Attachments => 'id',
        join_condition => 's.TransactionId = t.TransactionId',
    );
    return $res;
};

push @CHECKS, 'CustomFields and friends' => sub {
    my $res = 1;
    #XXX: ObjectCustomFields needs more love
    $res *= check_integrity(
        'CustomFieldValues', 'CustomField' => 'CustomFields', 'id',
    );
    $res *= check_integrity(
        'ObjectCustomFieldValues', 'CustomField' => 'CustomFields', 'id',
    );
    foreach my $model ( @models ) {
        $res *= check_integrity(
            'ObjectCustomFieldValues', 'ObjectId' => m2t($model), 'id',
            condition   => 's.ObjectType = ?',
            bind_values => [ "RT::$model" ],
        );
    }
    return $res;
};

push @CHECKS, Templates => sub {
    return check_integrity(
        'Templates', 'Queue' => 'Queues', 'id',
    );
};

push @CHECKS, Scrips => sub {
    my $res = 1;
    $res *= check_integrity(
        'Scrips', 'ScripCondition' => 'ScripConditions', 'id',
    );
    $res *= check_integrity(
        'Scrips', 'ScripAction' => 'ScripActions', 'id',
    );
    $res *= check_integrity(
        'Scrips', 'Template' => 'Templates', 'Name',
    );
    $res *= check_integrity(
        'ObjectScrips', 'Scrip' => 'Scrips', 'id',
    );
    $res *= check_integrity(
        'ObjectScrips', 'ObjectId' => 'Queues', 'id',
    );
    return $res;
};

push @CHECKS, Attributes => sub {
    my $res = 1;
    foreach my $model ( @models ) {
        $res *= check_integrity(
            'Attributes', 'ObjectId' => m2t($model), 'id',
            condition   => 's.ObjectType = ?',
            bind_values => [ "RT::$model" ],
        );
    }
    return $res;
};

# Fix situations when Creator or LastUpdatedBy references ACL equivalence
# group of a user instead of user
push @CHECKS, 'FIX: LastUpdatedBy and Creator' => sub {
    my $res = 1;
    my %fix = ();
    foreach my $model ( @models ) {
        my $class = "RT::$model";
        my $object = $class->new( RT->SystemUser );
        foreach my $column ( qw(LastUpdatedBy Creator) ) {
            next unless $object->_Accessible( $column, 'auto' );

            my $table = m2t($model);
            my $query = <<END;
SELECT m.id, g.id, g.Instance
FROM
    Groups g JOIN $table m ON g.id = m.$column
WHERE
    g.Domain = ?
    AND g.Name = ?
END
            my $action = sub {
                my ($gid, $uid) = @_;
                return unless prompt(
                    'Update',
                    "Looks like there were a bug in old versions of RT back in 2006\n"
                    ."that has been fixed. If other checks are ok then it's ok to update\n"
                    ."these records to point them to users instead of groups"
                );
                $fix{ $table }{ $column }{ $gid } = $uid;
            };

            my $sth = execute_query( $query, 'ACLEquivalence', 'UserEquiv' );
            while ( my ($rid, $gid, $uid) = $sth->fetchrow_array ) {
                $res = 0;
                print STDERR "Record #$rid in $table refers to ACL equivalence group #$gid of user #$uid";
                print STDERR " when must reference user.\n";
                $action->( $gid, $uid );
                if ( keys( %fix ) > 1000 ) {
                    $sth->finish;
                    last;
                }
            }
        }
    }

    if ( keys %fix ) {
        foreach my $table ( keys %fix ) {
            foreach my $column ( keys %{ $fix{ $table } } ) {
                my $query = "UPDATE $table SET $column = ? WHERE $column = ?";
                while ( my ($gid, $uid) = each %{ $fix{ $table }{ $column } } ) {
                    update_records( $table, { $column => $gid }, { $column => $uid } );
                }
            }
        }
        $redo_check{'FIX: LastUpdatedBy and Creator'} = 1;
    }
    return $res;
};

push @CHECKS, 'LastUpdatedBy and Creator' => sub {
    my $res = 1;
    foreach my $model ( @models ) {
        my $class = "RT::$model";
        my $object = $class->new( RT->SystemUser );
        my $table = $object->Table;
        foreach my $column ( qw(LastUpdatedBy Creator) ) {
            next unless $object->_Accessible( $column, 'auto' );
            $res *= check_integrity(
                $table, $column => 'Users', 'id',
                action => sub {
                    my ($id, %prop) = @_;
                    return unless my $replace_with = prompt_integer(
                        'Replace',
                        "Column $column should point to a user, but there is record #$id in table $table\n"
                        ."where it's not true. It's ok to replace these wrong references with id of any user.\n"
                        ."Note that id you enter is not checked. You can pick any user from your DB, but it's\n"
                        ."may be better to create a special user for this, for example 'user_that_has_been_deleted'\n"
                        ."or something like that.",
                        "$table.$column -> user #$prop{$column}"
                    );
                    update_records( $table, { id => $id, $column => $prop{$column} }, { $column => $replace_with } );
                },
            );
        }
    }
    return $res;
};

push @CHECKS, 'Links: wrong organization' => sub {
    my $res = 1;
    my @URI_USES = (
        { model => 'Transaction', column => 'OldValue', Additional => { Type => 'DeleteLink' } },
        { model => 'Transaction', column => 'NewValue', Additional => { Type => 'AddLink' } },
        { model => 'Link', column => 'Target' },
        { model => 'Link', column => 'Base' },
    );

    my $right_org = RT->Config->Get('Organization');
    my @rt_uris = rt_uri_modules();
    foreach my $package (@rt_uris) {

        my $rt_uri = $package->new( $RT::SystemUser );
        my $scheme = $rt_uri->Scheme;
        my $prefix = $rt_uri->LocalURIPrefix;

        foreach my $use ( @URI_USES ) {
            my $table = m2t( $use->{'model'} );
            my $column = $use->{'column'};

            my $query = "SELECT id, $column FROM $table WHERE"
              . " $column LIKE ? AND $column NOT LIKE ?";
            my @binds = (sql_escape_like($scheme) ."://%", sql_escape_like($prefix) ."%");

            while ( my ($k, $v) = each %{ $use->{'Additional'} || {} } ) {
                $query .= " AND $k = ?";
                push @binds, $v;
            }
            my $sth = execute_query( $query, @binds );
            while ( my ($id, $value) = $sth->fetchrow_array ) {
                $res = 0;
                print STDERR "Record #$id in $table. Value of $column column most probably is an incorrect link\n";
                my ($wrong_org) = ( $value =~ m{^\Q$scheme\E://(.+)/[^/]+/[0-9]*$} );
                next unless my $replace_with = prompt(
                    'Replace',
                    "Column $column in $table is a link.  There is record #$id that has a"
                    ." local scheme of '$scheme', but its organization is '$wrong_org'"
                    ." instead of '$right_org'.  Most probably the Organization was"
                    ." changed from '$wrong_org' to '$right_org' at some point.  It is"
                    ." generally a good idea to replace these wrong links.\n",
                    "Links: wrong organization $wrong_org"
                                                     );

                print "Updating record(s) in $table\n" if $opt{'verbose'};
                my $wrong_prefix = $scheme . '://'. $wrong_org;
                my $query = "UPDATE $table SET $column = ". sql_concat('?', "SUBSTR($column, ?)")
                  ." WHERE $column LIKE ?";
                execute_query( $query, $prefix, length($wrong_prefix)+1, sql_escape_like($wrong_prefix) .'/%' );

                $redo_check{'Links: wrong organization'} = 1;
                $redo_check{'Links: LocalX for non-ticket'} = 1;
                last; # plenty of chances we covered all cases with one update
            }
        }
    } # end foreach my $package (@rt_uris)
    return $res;
};

push @CHECKS, 'Links: LocalX for non-ticket' => sub {
    my $res = 1;
    my $rt_uri = RT::URI::fsck_com_rt->new( $RT::SystemUser );
    my $scheme = $rt_uri->Scheme;
    my $prefix = $rt_uri->LocalURIPrefix;
    my $table = m2t('Link');

    foreach my $dir ( 'Target', 'Base' ) {
        # we look only at links with correct organization, previouse check deals
        # with incorrect orgs
        my $where = "Local$dir > 0 AND $dir LIKE ? AND $dir NOT LIKE ?";
        my @binds = (sql_escape_like($prefix) ."/%", sql_escape_like($prefix) ."/ticket/%");

        my $sth = execute_query( "SELECT id FROM $table WHERE $where", @binds );
        while ( my ($id, $value) = $sth->fetchrow_array ) {
            $res = 0;
            print STDERR "Record #$id in $table. Value of Local$dir is not 0\n";
            next unless my $replace_with = prompt(
                'Replace',
                "Column Local$dir in $table should be 0 if $dir column is not link"
                ." to a ticket. It's ok to replace with 0.\n",
            );

            print "Updating record(s) in $table\n" if $opt{'verbose'};
            execute_query( "UPDATE $table SET Local$dir = 0 WHERE $where", @binds );
            $redo_check{'Links: wrong organization'} = 1;

            last; # we covered all cases with one update
        }
    }
    return $res;
};

push @CHECKS, 'Links: LocalX != X' => sub {
    my $res = 1;
    my $rt_uri = RT::URI::fsck_com_rt->new( $RT::SystemUser );
    my $scheme = $rt_uri->Scheme;
    my $prefix = $rt_uri->LocalURIPrefix .'/ticket/';
    my $table = m2t('Link');

    foreach my $dir ( 'Target', 'Base' ) {
        # we limit to $dir = */ticket/* so it doesn't conflict with previouse check
        # previouse check is more important as there was a bug in RT when Local$dir
        # was set for not tickets
        # XXX: we have issue with MergedInto links - "LocalX !~ X"
        my $where = "Local$dir > 0 AND $dir LIKE ? AND $dir != ". sql_concat('?', "Local$dir")
            ." AND Type != ?";
        my @binds = (sql_escape_like($prefix) ."%", $prefix, 'MergedInto');

        my $sth = execute_query( "SELECT id FROM $table WHERE $where", @binds );
        while ( my ($id, $value) = $sth->fetchrow_array ) {
            $res = 0;
            print STDERR "Record #$id in $table. Value of $dir doesn't match ticket id in Local$dir\n";
            next unless my $replace_with = prompt(
                'Replace',
                "For ticket links column $dir in $table table should end with"
                ." ticket id from Local$dir. It's probably ok to fix $dir column.\n",
            );

            print "Updating record(s) in $table\n" if $opt{'verbose'};
            execute_query(
                "UPDATE $table SET $dir = ". sql_concat('?', "Local$dir") ." WHERE $where",
                $prefix, @binds
            );

            last; # we covered all cases with one update
        }
    }
    return $res;
};

push @CHECKS, 'Links: missing object' => sub {
    my $res = 1;
    my @URI_USES = (
        { model => 'Transaction', column => 'OldValue', Additional => { Type => 'DeleteLink' } },
        { model => 'Transaction', column => 'NewValue', Additional => { Type => 'AddLink' } },
        { model => 'Link', column => 'Target' },
        { model => 'Link', column => 'Base' },
    );

    my @rt_uris = rt_uri_modules();
    foreach my $package (@rt_uris) {

        my $rt_uri = $package->new( $RT::SystemUser );
        my $scheme = $rt_uri->Scheme;
        my $prefix = $rt_uri->LocalURIPrefix;

        foreach my $use ( @URI_USES ) {
            my $stable = m2t( $use->{'model'} );
            my $scolumn = $use->{'column'};

            foreach my $tmodel ( @models ) {
                my $tclass = 'RT::'. $tmodel;
                my $ttable = m2t($tmodel);

                my $tprefix = $prefix .'/'. ($tclass eq 'RT::Ticket'? 'ticket' : $tclass) .'/';

                $tprefix = $prefix . '/article/' if $tclass eq 'RT::Article';

                my $query = "SELECT s.id FROM $stable s LEFT JOIN $ttable t "
                  ." ON t.id = ". sql_str2int("SUBSTR(s.$scolumn, ?)")
                    ." WHERE s.$scolumn LIKE ? AND t.id IS NULL";
                my @binds = (length($tprefix) + 1, sql_escape_like($tprefix).'%');

                while ( my ($k, $v) = each %{ $use->{'Additional'} || {} } ) {
                    $query .= " AND s.$k = ?";
                    push @binds, $v;
                }

                my $sth = execute_query( $query, @binds );
                while ( my ($sid) = $sth->fetchrow_array ) {
                    $res = 0;
                    print STDERR "Link in $scolumn column in record #$sid in $stable table points"
                      ." to not existing object.\n";
                    next unless prompt(
                        'Delete',
                        "Column $scolumn in $stable table is a link to an object that doesn't exist."
                        ." You can delete such records, however make sure there is no other"
                        ." errors with links.\n",
                        'Link to a missing object in $ttable'
                                      );

                    delete_record($stable, $sid);
                }
            }
        }
    } # end foreach my $package (@rt_uris)
    return $res;
};


my %CHECKS = @CHECKS;

@do_check = do { my $i = 1; grep $i++%2, @CHECKS };

if ($opt{'links-only'}) {
    @do_check = grep { /^Links:/ } @do_check;
}

my $status = 1;
while ( my $check = shift @do_check ) {
    $status *= $CHECKS{ $check }->();

    foreach my $redo ( keys %redo_check ) {
        die "check $redo doesn't exist" unless $CHECKS{ $redo };
        delete $redo_check{ $redo };
        next if grep $_ eq $redo, @do_check; # don't do twice
        push @do_check, $redo;
    }
}
exit 1 unless $status;
exit 0;

=head2 check_integrity

Takes two (table name, column(s)) pairs. First pair
is reference we check and second is destination that
must exist. Array reference can be used for multiple
columns.

Returns 0 if a record is missing or 1 otherwise.

=cut

sub check_integrity {
    my ($stable, @scols) = (shift, shift);
    my ($ttable, @tcols) = (shift, shift);
    my %args = @_;

    @scols = @{ $scols[0] } if ref $scols[0];
    @tcols = @{ $tcols[0] } if ref $tcols[0];

    print "Checking integrity of $stable.{". join(', ', @scols) ."} => $ttable.{". join(', ', @tcols) ."}\n"
        if $opt{'verbose'};

    my $query = "SELECT s.id, ". join(', ', map "s.$_", @scols)
        ." FROM $stable s LEFT JOIN $ttable t"
        ." ON (". join(
            ' AND ', map columns_eq_cond('s', $stable, $scols[$_] => 't', $ttable, $tcols[$_]), (0..(@scols-1))
        ) .")"
        . ($args{'join_condition'}? " AND ( $args{'join_condition'} )": "")
        ." WHERE t.id IS NULL"
        ." AND ". join(' AND ', map "s.$_ IS NOT NULL", @scols);

    $query .= " AND ( $args{'condition'} )" if $args{'condition'};

    my @binds = @{ $args{'bind_values'} || [] };
    if ( $tcols[0] eq 'id' && @tcols == 1 ) {
        my $type = $TYPE{"$stable.$scols[0]"} || 'number';
        if ( $type eq 'number' ) {
            $query .= " AND s.$scols[0] != ?"
        }
        elsif ( $type eq 'text' ) {
            $query .= " AND s.$scols[0] NOT LIKE ?"
        }
        push @binds, 0;
    }

    my $res = 1;

    my $sth = execute_query( $query, @binds );
    while ( my ($sid, @set) = $sth->fetchrow_array ) {
        $res = 0;

        print STDERR "Record #$sid in $stable references a nonexistent record in $ttable\n";
        for ( my $i = 0; $i < @scols; $i++ ) {
            print STDERR "\t$scols[$i] => '$set[$i]' => $tcols[$i]\n";
        }
        print STDERR "\t". describe( $stable, $sid ) ."\n";
        $args{'action'}->( $sid, map { $scols[$_] => $set[$_] } (0 .. (@scols-1)) )
            if $args{'action'};
    }
    return $res;
}

sub describe {
    my ($table, $id) = @_;
    return '' unless my $cb = $describe_cb{ $table };

    my $row = load_record( $table, $id );
    unless ( $row->{id} ) {
        $table =~ s/s$//;
        return "$table doesn't exist";
    }
    return $cb->( $row );
}

sub columns_eq_cond {
    my ($la, $lt, $lc, $ra, $rt, $rc) = @_;
    my $ltype = $TYPE{"$lt.$lc"} || 'number';
    my $rtype = $TYPE{"$rt.$rc"} || 'number';
    return "$la.$lc = $ra.$rc" if $db_type ne 'Pg' || $ltype eq $rtype;

    if ( $rtype eq 'text' ) {
        return "$ra.$rc LIKE CAST($la.$lc AS text)";
    }
    elsif ( $ltype eq 'text' ) {
        return "$la.$lc LIKE CAST($ra.$rc AS text)";
    }
    else { die "don't know how to cast" }
}

sub check_uniqueness {
    my $on = shift;
    my %args = @_;

    my @columns = @{ $args{'columns'} };

    print "Checking uniqueness of ( ", join(', ', map "'$_'", @columns )," ) in table '$on'\n"
        if $opt{'verbose'};

    my ($scond, $tcond);
    if ( $scond = $tcond = $args{'condition'} ) {
        $scond =~ s/(\s|^)\./$1s./g;
        $tcond =~ s/(\s|^)\./$1t./g;
    }

    my $query = "SELECT s.id, t.id, ". join(', ', map "s.$_", @columns)
        ." FROM $on s LEFT JOIN $on t "
        ." ON s.id != t.id AND ". join(' AND ', map "s.$_ = t.$_", @columns)
        . ($tcond? " AND ( $tcond )": "")
        . ($args{'extra_tables'} ? join(", ", "", @{$args{'extra_tables'}}) : "")
        ." WHERE t.id IS NOT NULL "
        ." AND ". join(' AND ', map "s.$_ IS NOT NULL", @columns);
    $query .= " AND ( $scond )" if $scond;
    $query .= " AND ( $args{'extra_condition'} )" if $args{'extra_condition'};

    my $sth = execute_query(
        $query,
        $args{'bind_values'}? (@{ $args{'bind_values'} }, @{ $args{'bind_values'} }): (),
        $args{'extra_values'}? (@{ $args{'extra_values'} }): ()
    );
    my $res = 1;
    while ( my ($sid, $tid, @set) = $sth->fetchrow_array ) {
        $res = 0;
        print STDERR "Record #$tid in $on has the same set of values as $sid\n";
        for ( my $i = 0; $i < @columns; $i++ ) {
            print STDERR "\t$columns[$i] => '$set[$i]'\n";
        }
        $args{'action'}->( $tid, map { $columns[$_] => $set[$_] } (0 .. (@columns-1)) ) if $args{'action'};
    }
    return $res;
}

sub load_record {
    my ($table, $id) = @_;
    my $sth = execute_query( "SELECT * FROM $table WHERE id = ?", $id );
    return $sth->fetchrow_hashref('NAME_lc');
}

sub delete_record {
    my ($table, $id) = (@_);
    print "Deleting record #$id in $table\n" if $opt{'verbose'};
    my $query = "DELETE FROM $table WHERE id = ?";
    $redo_check{ $_ } = 1 foreach @{ $redo_on{'Delete'}{ $table } || [] };
    return execute_query( $query, $id );
}

sub create_record {
    print "Creating a record in $_[0]\n" if $opt{'verbose'};
    $redo_check{ $_ } = 1 foreach @{ $redo_on{'Create'}{ $_[0] } || [] };
    return $RT::Handle->Insert( @_ );
}

sub update_records {
    my $table = shift;
    my $where = shift;
    my $what = shift;

    my (@where_cols, @where_binds);
    while ( my ($k, $v) = each %$where ) { push @where_cols, $k; push @where_binds, $v; }

    my (@what_cols, @what_binds);
    while ( my ($k, $v) = each %$what ) { push @what_cols, $k; push @what_binds, $v; }

    print "Updating record(s) in $table\n" if $opt{'verbose'};
    my $query = "UPDATE $table SET ". join(', ', map "$_ = ?", @what_cols)
        ." WHERE ". join(' AND ', map "$_ = ?", @where_cols);
    $redo_check{ $_ } = 1 foreach @{ $redo_on{'Update'}{ $table } || [] };
    return execute_query( $query, @what_binds, @where_binds );
}

sub execute_query {
    my ($query, @binds) = @_;

    print "Executing query: $query\n\n" if $opt{'verbose'};

    my $sth = $dbh->prepare( $query ) or die "couldn't prepare $query\n\tError: ". $dbh->errstr;
    $sth->execute( @binds ) or die "couldn't execute $query\n\tError: ". $sth->errstr;
    return $sth;
}

sub sql_concat {
    return $_[0] if @_ <= 1;

    my $db_type = RT->Config->Get('DatabaseType');
    if ( $db_type eq 'Pg' || $db_type eq 'SQLite' ) {
        return '('. join( ' || ', @_ ) .')';
    }
    return sql_concat('CONCAT('. join( ', ', splice @_, 0, 2 ).')', @_);
}

sub sql_str2int {
    my $db_type = RT->Config->Get('DatabaseType');
    if ( $db_type eq 'Pg' ) {
        return "($_[0])::integer";
    }
    return $_[0];
}

sub sql_escape_like {
    my ($string) = @_;
    $string =~ s/([%_\\])/\\$1/g;
    return $string;
}

{ my %cached_answer;
sub prompt {
    my $action = shift;
    my $msg = shift;
    my $token = shift || join ':', caller;

    return 0 unless $opt{'resolve'};
    return 1 if $opt{'force'};

    return $cached_answer{ $token } if exists $cached_answer{ $token };

    print $msg, "\n";
    print "$action ALL records with the same defect? [N]: ";
    my $a = <STDIN>;
    return $cached_answer{ $token } = 1 if $a =~ /^(y|yes)$/i;
    return $cached_answer{ $token } = 0;
} }

{ my %cached_answer;
sub prompt_action {
    my $actions = shift;
    my $msg = shift;
    my $token = shift || join ':', caller;

    return '' unless $opt{'resolve'};
    return lc substr $actions->[0], 0, 1 if $opt{'force'};
    return $cached_answer{ $token } if exists $cached_answer{ $token };

    print $msg, "\n";
    print join( ' or ', @$actions ) ." ALL records with the same defect? [do nothing]: ";
    my $a = <STDIN>;
    chomp $a;
    return $cached_answer{ $token } = '' unless $a;
    foreach ( grep rindex(lc $_, lc $a, 0) == 0, @$actions ) {
        return $cached_answer{ $token } = lc substr $a, 0, 1;
    }
    return $cached_answer{ $token } = '';
} }

{ my %cached_answer;
sub prompt_integer {
    my $action = shift;
    my $msg = shift;
    my $token = shift || join ':', caller;

    return 0 unless $opt{'resolve'};
    return 0 if $opt{'force'};

    return $cached_answer{ $token } if exists $cached_answer{ $token };

    print $msg, "\n";
    print "$action ALL records with the same defect? [0]: ";
    my $a = <STDIN>; chomp $a; $a = int($a);
    return $cached_answer{ $token } = $a;
} }

# Find all RT::URI modules RT has loaded

sub rt_uri_modules {
    my @uris = grep /^RT\/URI\/.+\.pm$/, keys %INC;
    my @uri_modules;
    foreach my $uri_path (@uris){
        next if $uri_path =~ /base\.pm$/; # Skip base RT::URI object
        $uri_path = substr $uri_path, 0, -3; # chop off .pm
        push @uri_modules, join '::', split '/', $uri_path;
    }

    return @uri_modules;
}

1;

__END__

=head1 NAME

rt-validator - check and correct validity of records in RT's database

=head1 SYNOPSIS

    rt-validator --check 
    rt-validator --check --verbose
    rt-validator --check --verbose --resolve
    rt-validator --check --verbose --resolve --force

=head1 DESCRIPTION

This script checks integrity of records in RT's DB. May delete some invalid
records or ressurect accidentally deleted.

=head1 OPTIONS

=over

=item check

    mandatory.
    
    it's equal to -c

=item verbose

    print additional info to STDOUT
    it's equal to -v

=item resolve

    enable resolver that can delete or create some records

=item force

    resolve without asking questions

=item links-only 

    only run the Link validation routines, useful if you changed your Organization

=back