sqitch-reset.pl

#!/usr/bin/env perl

use strict;
use warnings;

use FindBin qw( $Bin );
use lib "$Bin/lib";

use Script::SqitchReset;

exit Script::SqitchReset->new_with_options->run;

SqitchReset.pm

package Script::SqitchReset;

use v5.24;

use strict;
use warnings;
use feature 'postderef', 'signatures';
use autodie qw( :all );
use namespace::autoclean;

use Carp qw( confess );
use DateTime;
use File::pushd;
use FindBin qw( $Bin );
use IPC::Run3 qw( run3 );
use MooseX::Types::Common::String qw( NonEmptyStr );
use MooseX::Types::Path::Tiny qw( Dir Path );
use Path::Tiny qw( path tempdir );

use Moose;
## no critic (TestingAndDebugging::ProhibitNoWarnings)
no warnings 'experimental::postderef', 'experimental::signatures';

with 'MooseX::Getopt::Dashes';

has service => (
    is            => 'ro',
    isa           => NonEmptyStr,
    required      => 1,
    documentation => 'The name of the service to reset',
);

has _temp_dir => (
    is      => 'ro',
    isa     => Dir,
    lazy    => 1,
    default => sub { tempdir( CLEANUP => 1 ) },
);

has _reset_name => (
    is      => 'ro',
    isa     => NonEmptyStr,
    lazy    => 1,
    default => sub ($self) { 'reset-' . $self->_today },
);

has _dump_file_name => (
    is      => 'ro',
    isa     => NonEmptyStr,
    lazy    => 1,
    default => sub ($self) { $self->_reset_name . '.sql' },
);

has _dump_file => (
    is      => 'ro',
    isa     => Path,
    lazy    => 1,
    default => sub ($self) { $self->_temp_dir->child( $self->_dump_file_name ) },
);

has _deploy_file => (
    is      => 'ro',
    isa     => Path,
    lazy    => 1,
    default => sub ($self) { $self->_db_dir->child( 'deploy', $self->_dump_file_name ) },
);

has _db_dir => (
    is      => 'ro',
    isa     => Dir,
    lazy    => 1,
    default => sub ($self) {
        path($Bin)->parent->parent->child( 'service', $self->service, 'db' )->realpath;
    },
);

has _db_name => (
    is      => 'ro',
    isa     => NonEmptyStr,
    lazy    => 1,
    default => sub ($self) { $self->service . '-sqitch-reset' },
);

has _today => (
    is      => 'ro',
    isa     => NonEmptyStr,
    lazy    => 1,
    default => sub { DateTime->today( time_zone => 'America/Vancouver' )->ymd },
);

sub run ($self) {
    $self->_dump_database;
    $self->_archive_existing_sqitch_files;
    $self->_start_new_sqitch;
    $self->_move_dump;
    $self->_extract_functions;
    $self->_add_verify_and_revert;
    $self->_sqitch_add_dump;
    $self->_write_sqitch_reset_sql;
    return 0;
}

sub _dump_database ($self) {
    $self->_run_or_die( 'createdb', $self->_db_name );

    {
        my $dir = pushd( $self->_db_dir );
        $self->_run_or_die( 'sqitch', 'deploy', '--verify', 'db:pg:///' . $self->_db_name );
    }

    $self->_run_or_die(
        'pg_dump',
        '--exclude-schema=sqitch',
        '--no-owner',
        '--no-privileges',
        '--no-tablespaces',
        '--file=' . $self->_dump_file,
        $self->_db_name,
    );

    $self->_run_or_die( 'dropdb', $self->_db_name );

    return;
}

sub _archive_existing_sqitch_files ($self) {
    my $archive_dir = $self->_db_dir->child( 'archive', $self->_today );
    ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
    $archive_dir->mkpath( 0, 0755 );
    $archive_dir->child('lib')->mkpath( 0, 0755 );

    for my $path (qw( sqitch.plan deploy verify revert lib/for-production )) {
        say "Moving $path to $archive_dir" or die $!;
        $self->_db_dir->child($path)->move( $archive_dir->child($path) );
    }

    return;
}

sub _start_new_sqitch ($self) {
    my $dir = pushd( $self->_db_dir );
    $self->_run_or_die( qw( sqitch init ), $self->service );
    return;
}

sub _move_dump ($self) {
    $self->_dump_file->copy( $self->_deploy_file );
    return;
}

#use re 'debug';

my $func_re = qr/
\Q--
-- Name: \E(?<name>[^;]+)\([^\)]*\)\Q; Type: FUNCTION; Schema: public; Owner: -
--

\E
(?<definition>
CREATE\ FUNCTION\ .+?
\n
BEGIN
\n
.+?
\n
END;
\n
\$_?\$;)
\n+
/sx;

my $comment_re = qr/
\Q--
-- Name: FUNCTION \E[^;]+\Q; Type: COMMENT; Schema: public; Owner: -
--\E
\n+
(?<comment>COMMENT\ ON\ FUNCTION\ .+?;)
\n+
/sx;

sub _extract_functions ($self) {
    my $lib_dir = $self->_db_dir->child( 'lib', 'for-production' );
    ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
    $lib_dir->mkpath( 0, 0755 );

    my $sql = $self->_deploy_file->slurp_utf8;
    while ( $sql =~ s{$func_re(?:$comment_re)?\n*}{\\ir ../lib/for-production/$+{name}.v1.sql\n\n} )
    {
        my $func    = $+{definition};
        my $name    = $+{name};
        my $comment = $+{comment} // q{};

        $func =~ s/\n$//;
        $comment =~ s/\n$//;

        my $file = $lib_dir->child("$name.v1.sql");
        $file->spew_utf8( $func . "\n\n" . $comment . "\n" );
    }

    $self->_deploy_file->spew_utf8($sql);

    return;
}

sub _add_verify_and_revert ($self) {
    $self->_db_dir->child( 'verify', $self->_dump_file_name )->spew_utf8(<<'EOF');
-- There is nothing to verify for this migration.
EOF

    $self->_db_dir->child( 'revert', $self->_dump_file_name )->spew_utf8(<<'EOF');
-- To revert simply drop the database.
EOF
}

sub _sqitch_add_dump ($self) {
    my $dir = pushd( $self->_db_dir );
    $self->_run_or_die(
        'sqitch',        'add',
        '--change-name', $self->_reset_name,
        '--note',        'Reset sqitch to schema as it exists on ' . $self->_today,
    );
    return;
}

sub _write_sqitch_reset_sql ($self) {
    my $project    = $self->service;
    my $reset_name = $self->_reset_name;

    # from https://gist.github.com/theory/e7d432e69296e3672446
    say <<"EOF" or die $!;
BEGIN;
DELETE FROM sqitch.tags WHERE change_id IN (
    SELECT change_id FROM sqitch.changes WHERE project = '$project'
);
DELETE FROM sqitch.dependencies WHERE change_id IN (
    SELECT change_id FROM sqitch.changes WHERE project = '$project'
);
DELETE FROM sqitch.changes WHERE project = '$project';
DELETE FROM sqitch.changes WHERE project = '$project';
DELETE FROM sqitch.events WHERE project = '$project';
DELETE FROM sqitch.projects WHERE project = '$project';
COMMIT;

Then run this command:

sqitch deploy --log-only \$db_uri
EOF
}

sub _run_or_die ( $, @cmd ) {
    run3(
        \@cmd,
        undef,
        \*STDOUT,
        \*STDERR,
    );
    if ($?) {
        my $cmd = join q{ }, @cmd;
        my $err = "Error running $cmd\n";
        $err .= "  * Got a non-zero exit code from $cmd: " . ( $? >> 8 ) . "\n";
        confess $err;
    }

    return;
}

__PACKAGE__->meta->make_immutable;

1;