
package LedgerSMB::Database::Upgrade;

=head1 NAME

LedgerSMB::Database::Upgrade - upgrade routines factored out of setup.pm

=head1 DESCRIPTION

=cut

use strict;
use warnings;

use LedgerSMB::I18N;
use LedgerSMB::Upgrade_Tests;

use Carp;
use File::Spec;
use File::Temp;
use List::Util qw( any first );
use Log::Any qw( $log );
use Scope::Guard qw( guard );
use Template;
use XML::LibXML;
use XML::LibXML::XPathContext;

use Moose;
use namespace::autoclean;


my %migration_schema = (
    'sql-ledger/2.8' => 'sl28',
    'sql-ledger/3.0' => 'sl30',
    'sql-ledger/3.2' => 'sl32',
    'ledgersmb/1.2'  => 'lsmb12',
    'ledgersmb/1.3'  => 'lsmb13',
    );

my %migration_script = (
    'sql-ledger/2.8' => 'sl2.8',
    'sql-ledger/3.0' => 'sl3.0',
    'sql-ledger/3.2' => undef,
    'ledgersmb/1.2'  => '1.2-1.5',
    'ledgersmb/1.3'  => '1.3-1.5',
    );

my %migration_upto = (
    'sql-ledger/2.8' => 'migration-target-sl',
    'sql-ledger/3.0' => 'migration-target-sl',
    'sql-ledger/3.2' => undef,
    'ledgersmb/1.2'  => 'migration-target-lsmb',
    'ledgersmb/1.3'  => 'migration-target-lsmb',
    );


=head1 ATTRIBUTES

=head2 data_dir

Indicates the path to the directory which holds the 'initial-data.xml' file
containing the reference and static data to be loaded into the base schema.

The default value is relative to the current directory, which is assumed
to be the root of the LedgerSMB source tree.

=cut

has data_dir => (is => 'ro', default => './locale');

=head2 database (required)



=cut

has database => (is => 'ro', required => 1);

=head2 type (required)

The value indicates the source type of the migration C<< <source>/<version> >>,
e.g. C<ledgersmb/1.2>.

=cut

has type => (is => 'ro', required => 1);

=head2 language (optional)

=cut

has language => (is => 'ro', default => 'en');


=head2 logfiles

=cut

has logfiles => (is => 'ro', default => sub { {} });


=head1 METHODS

=head2 applicable_tests

Returns all pre-upgrade tests that apply to the application and version
of the database being upgraded/migrated.

=cut

sub _upgrade_test_is_applicable {
    my ($dbinfo, $test) = @_;

    return (($test->min_version le $dbinfo->{version})
            && ($test->max_version ge $dbinfo->{version})
            && ($test->appname eq $dbinfo->{appname}));
}

sub applicable_tests {
    my $self = shift;
    my $dbinfo = $self->database->get_info;

    my @tests = (
        grep { _upgrade_test_is_applicable($dbinfo, $_) }
        LedgerSMB::Upgrade_Tests->get_tests
        );
    my %consistency;
    for (@tests) { $consistency{$_->name}++ };

    if (scalar @tests != scalar keys %consistency) {
        my $error = 'Inconsistent state fixing data: multiple applicable tests '
            . 'with the same name:';
        for (keys %consistency) { $error .= ' ' . $_ if $consistency{$_} > 1 }
        die $error;
    }

    return @tests;
}

=head2 applicable_test_by_name($name)

Retrieves exactly one test from the set of applicable tests matching
C<$name>. When no matching test is found, C<undef> is returned.

=cut

sub applicable_test_by_name {
    my ($self, $name) = @_;

    return first { $_->name eq $name } ($self->applicable_tests);
}

=head2 run_tests($failure_cb)

Runs the applicable upgrade tests, until the first failing test,
calling C<$failure_cb> on that test.

Returns false-ish when a test failed; true-ish when all tests ran and
no conflicting data was identified (=failed).

=cut

sub run_tests {
    my ($self, $cb) = @_;

    my $dbh = $self->database->connect({ PrintError => 1, AutoCommit => 0});
    my $guard = guard {
        $dbh->rollback;
        $dbh->disconnect;
    };
    for my $test ($self->applicable_tests) {
        if (not $test->run($dbh, $cb)) {
            return 0;
        }
    }
    $dbh->commit;
    return 1;
}

=head2 required_vars

Returns a hashref where the keys of are the names of required variables
for the migration. The values are arrays with allowable values, or C<undef>
for any allowed value.

=cut

my %migration_required_vars = (
    'ledgersmb/1.2'  => [qw( default_ar default_ap default_country )],
    'ledgersmb/1.3'  => [],
    'sql-ledger/2.8' => [qw( default_ar default_ap default_country slschema )],
    'sql-ledger/3.0' => [qw( default_ar default_ap default_country slschema )],
    );

my %required_vars_values = (
    default_ar      => sub { _linked_accounts($_[1], 'AR') },
    default_ap      => sub { _linked_accounts($_[1], 'AP') },
    default_country => sub { _filtered_languages($_[0]) },
    slschema        => sub { $migration_schema{$_[0]->type} },
    );

my %migration_post_steps = (
    'ledgersmb/1.2'  => [ qw(_post_upgrade_create_roles) ],
    'ledgersmb/1.3'  => [],
    'sql-ledger/2.8' => [],
    'sql-ledger/3.0' => [],
    );

sub _linked_accounts {
    my ($dbh, $link) = @_;
    my @accounts;

    my $sth = $dbh->prepare("select id, accno, description
                               from chart where link = '$link'
                                and charttype = 'A'")
        or die $dbh->errstr;

    $sth->execute() or die $sth->errstr;
    while (my $row = $sth->fetchrow_hashref('NAME_lc')) {
        push @accounts, { value => $row->{accno},
                          text => "$row->{accno} - $row->{description}",
        };
    }
    $sth->finish();

    return \@accounts;
}

sub _filtered_languages {
    my $self = shift;
    my $initial = File::Spec->catfile( $self->data_dir, 'initial-data.xml' );
    my $langs = LedgerSMB::I18N::get_country_list($self->language);

    open( my $fh, '<:bytes', $initial )
        or croak "Failed to open schema seed data file ($initial): $!";
    my $doc = XML::LibXML->load_xml( IO => $fh );
    my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
    $xpc->registerNs( 'x', 'http://ledgersmb.org/xml-schemas/initial-data' );
    close( $fh ) or carp "Failed to close seed data file ($initial): $!";

    my @lang_codes = map {
        my $atts = $_->attributes;
        lc($atts->getNamedItem( 'code' )->nodeValue)
    } $xpc->findnodes( './x:countries/x:country' );
    return [
        sort { $a->{text} cmp $b->{text} }
        grep {
            my $value = lc($_->{value});
            any { $value eq $_ } @lang_codes
        } @$langs
    ];
}

sub required_vars {
    my ($self) = @_;
    my $dbh = $self->database->connect({ PrintError => 0, AutoCommit => 0 });
    my $guard = guard {
        $dbh->rollback;
        $dbh->disconnect;
    };

    return {
        map {
            $_ => $required_vars_values{$_}->($self, $dbh)
        } @{$migration_required_vars{$self->type}}
    };
}

=head2 run_upgrade_script($vars)

Runs the upgrade script from the C<sql/upgrade/> directory.

C<$vars> is a hashref to parameters required to run the upgrade script.

=cut

sub run_upgrade_script {
    my ($self, $vars) = @_;
    my $src_schema = $migration_schema{$self->type};
    my $template   = $migration_script{$self->type};
    my $upto       = $migration_upto{$self->type};

    my $dbh = $self->database->connect({ PrintError => 0, AutoCommit => 0 });
    my $temp = $self->database->loader_log_filename();
    $self->logfiles->{out} = $temp . '_stdout';
    $self->logfiles->{err} = $temp . '_stderr';

    my $schema = $self->database->schema;
    my $guard = Scope::Guard->new(
        sub {
            $dbh->rollback;
            $dbh->do(
                qq{DROP SCHEMA $schema CASCADE;
                   ALTER SCHEMA $src_schema
                         RENAME TO $schema});
            $dbh->commit;
        });

    $dbh->do("ALTER SCHEMA $schema RENAME TO $src_schema;
              CREATE SCHEMA $schema;
              GRANT ALL ON SCHEMA $schema TO PUBLIC")
    or die "Failed to create schema $schema (" . $dbh->errstr . ')';
    $dbh->commit;

    $self->database->load_base_schema(
        log     => $self->logfiles->{out},
        errlog  => $self->logfiles->{err},
        upto_tag=> $upto
        );

    $dbh->do(q(
       INSERT INTO defaults (setting_key, value)
                     VALUES ('migration_ok', 'no')
     ));
    $dbh->do(qq(
       INSERT INTO defaults (setting_key, value)
                     VALUES ('migration_src_schema', '$src_schema')
     ));
    $dbh->commit;


    my $engine = Template->new(
        INCLUDE_PATH => [ 'sql/upgrade' ],
        ENCODING     => 'utf8',
        TRIM         => 1,
        );

    my $tempfile = File::Temp->new();
    $engine->process("$template.sql",
                     {
                         %$vars
                     },
                     $tempfile)
       or die q{Failed to create upgrade instructions to be sent to 'psql': }
               . $engine->error;
    close $tempfile
       or warn 'Failed to close temporary file';

    $self->database->run_file(
        file => $tempfile->filename,
        stdout_log => $self->logfiles->{out},
        errlog => $self->logfiles->{err},
        );

    my $sth = $dbh->prepare(q(select value='yes'
                                 from defaults
                                where setting_key='migration_ok'));
    $sth->execute();

    my ($success) = $sth->fetchrow_array();
    $sth->finish();

    if (not $success) {
        die "Upgrade failed; logs can be found in
             ${temp}_stdout and ${temp}_stderr";
    }

    $dbh->do(q{delete from defaults where setting_key like 'migration_%'});
    $dbh->commit;

    $guard->dismiss;
    $dbh->disconnect;
    return;
}

=head2 run_post_upgrade_steps

Runs the post upgrade script steps.

=cut

sub _post_upgrade_create_roles {
    my ($self, $dbh) = @_;

    my $usth =
        $dbh->prepare(q{SELECT username FROM users u
                         WHERE NOT EXISTS (SELECT 1 FROM pg_roles r
                      WHERE u.username = r.rolname)})
        or die $dbh->errstr;
    my $csth =
        $dbh->prepare(q{CREATE ROLE ? WITH LOGIN NOSUPERUSER
                                           NOCREATEDB NOCREATEROLE
                                      ENCRYPTED PASSWORD 'whatever'
                                      VALID UNTIL 'yesterday'})
        or die $dbh->errstr;

    $usth->execute
        or die $usth->errstr;

    while (my ($username) = $usth->fetch_rowarray) {
        $csth->execute($username)
            or die $csth->errstr;
    }

    ###TODO check users to see if they comply with the above definition
    # and warn if not...
}

sub run_post_upgrade_steps {
    my $self = shift;
    my $steps = $migration_post_steps{$self->type};

    my $dbh = $self->database->connect({ PrintError => 0, AutoCommit => 0 });
    my $guard = Scope::Guard->new(
        sub {
            $dbh->rollback;
            $dbh->disconnect;
        });

    for my $step (@$steps) {
        $self->$step($dbh);
    }
    $guard->dismiss;
    $dbh->commit;
    $dbh->disconnect;

    return 0;
}

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2011-2020 The LedgerSMB Core Team

This file is licensed under the GNU General Public License version 2, or at your
option any later version.  A copy of the license should have been included with
your software.

=cut

__PACKAGE__->meta->make_immutable;

1;
