#!/usr/bin/perl -wT

# simple pg_basebackup front-end
#
# Copyright (C) 2021 Christoph Berg <myon@debian.org>
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program 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.

use strict;
use warnings;
use Fcntl qw(LOCK_EX);
use Getopt::Long;
use JSON;
use PgCommon;
use POSIX qw(strftime);

my ($version, $cluster);

# untaint environment
$ENV{'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
chdir '/';
umask 027;

sub help () {
    print "Syntax: $0 [options] <version> <cluster> <action>
Actions:
  createdirectory        Create /var/backups/version-cluster
  basebackup             Backup using pg_basebackup
  dump                   Backup using pg_dump
  expiredumps <N>        Remove all but last N dumps
  expirebasebackups <N>  Remove all but last N basebackups
  receivewal             Launch pg_receivewal
  compresswal            Compress WAL files in archive
  archivecleanup         Remove obsolete WAL files from archive
  list                   Show dumps, basebackups, and WAL
Options:
  -k --keep-on-error     Keep faulty backup directory on error
  -v --verbose           Verbose output
";
}

my $keep_on_error;
my $verbose;

exit 1 unless GetOptions (
    'k|keep-on-error' => \$keep_on_error,
    'v|verbose' => \$verbose,
);

$verbose = 1 if (-t 1); # verbose output when running on terminal

# accept both "version cluster action" and "version[-/]cluster action"
if (@ARGV >= 2 and $ARGV[0] =~ m!^(\d+\.?\d)[-/]([^/]+)$!) {
    ($version, $cluster) = ($1, $2);
    shift @ARGV;
} elsif (@ARGV >= 3 and $ARGV[0] =~ /^(\d+\.?\d)$/) {
    $version = $1;
    ($cluster) = ($ARGV[1]) =~ m!^([^/]+)$!;
    shift @ARGV;
    shift @ARGV;
} else {
    help();
    exit 1;
}
my $action = $ARGV[0];

error "specified cluster $version $cluster does not exist" unless $version && $cluster && cluster_exists $version, $cluster;

my %info = cluster_info($version, $cluster);
validate_cluster_owner \%info;

my $rootdir = "/var/backups/postgresql";
my $clusterdir = "$rootdir/$version-$cluster";
my $waldir = "$clusterdir/wal";

# functions to be run as root

sub create_directory() {
    if (! -d $rootdir) {
        my ($pg_uid, $pg_gid) = (getpwnam 'postgres')[2,3];
        ($pg_uid and $pg_gid) or error "getpwnam postgres: $!";
        mkdir $rootdir, 0755 or error "mkdir $rootdir: $!";
        chown $pg_uid, $pg_gid, $rootdir or error "chown $rootdir: $!";
    }
    if (! -d $clusterdir) {
        mkdir($clusterdir, 0750) or error "mkdir $clusterdir: $!";
        chown $info{owneruid}, $info{ownergid}, $clusterdir or error "chown $clusterdir: $!";
    }
}

sub switch_to_cluster_owner() {
    change_ugid $info{owneruid}, $info{ownergid};
}

# backup functions

sub get_backupdir($) {
    my $suffix = shift;
    my $timestamp = strftime("%FT%H%M%SZ", gmtime);
    my $backupdir = "$clusterdir/$timestamp.$suffix";
    error "$backupdir already exists" if (-d $backupdir);
    print "Creating $suffix in $backupdir\n" if ($verbose);
    return $backupdir;
}

sub remove_backup_on_error($) {
    my $backupdir = shift;
    if ($keep_on_error) {
        print "Not removing $backupdir (--keep-on-error)\n";
    } else {
        print "Removing $backupdir ...\n" if ($verbose);
        system_or_error "rm", "-rf", $backupdir;
    }
}

sub create_basebackup($) {
    my $backupdir = shift;

    system_or_error "pg_basebackup",
        "--cluster", "$version/$cluster",
        "--verbose",
        (-t 2 ? "--progress" : ()),
        "--format", "tar", "--gzip",
        ($version < 10 ? "--xlog" : ()),
        "-D", $backupdir;
}

sub create_dumpall($) {
    my $backupdir = shift;
    mkdir($backupdir, 0750) or error "mkdir $backupdir: $!";

    my $clusterquery = "SELECT concat(
  format('--encoding %s --lc-collate %s --lc-ctype %s', pg_catalog.pg_encoding_to_char(encoding), datcollate, datctype),
  CASE WHEN current_setting('data_checksums')::boolean THEN ' -- --data-checksums' END)
FROM pg_database WHERE datname = 'template0'";
    system_or_error "psql",
        "--cluster", "$version/$cluster",
        "-XAtc", $clusterquery,
        "-o", "$backupdir/createcluster.opts";

    system_or_error "pg_dumpall",
        "--cluster", "$version/$cluster",
        "--globals-only",
        "--file", "$backupdir/globals.sql";

    my $dbquery = "/* database creation */
SELECT
  format('CREATE DATABASE %I WITH OWNER = %I TEMPLATE = template0 ENCODING = %L LC_COLLATE %L LC_CTYPE %L;', datname, rolname, pg_encoding_to_char(encoding), datcollate, datctype) AS command
FROM pg_database
LEFT JOIN pg_roles r ON r.oid = datdba
WHERE datallowconn AND datname NOT IN ('postgres', 'template1')

UNION ALL

/* database options */
SELECT
  CASE
    WHEN rolname IS NULL THEN format('ALTER DATABASE %I', datname)
    ELSE format('ALTER ROLE %I IN DATABASE %I', rolname, datname)
  END ||
  format(' SET %I = ', match[1]) ||
  CASE
    WHEN match[1] IN ('local_preload_libraries', 'search_path', 'session_preload_libraries', 'shared_preload_libraries', 'temp_tablespaces', 'unix_socket_directories')
    THEN match[2]
    ELSE quote_literal(match[2])
  END ||
  ';' AS command
FROM pg_db_role_setting s
JOIN pg_database d ON d.oid = setdatabase
LEFT JOIN pg_roles r ON r.oid = setrole,
unnest(setconfig) u(setting),
regexp_matches(setting, '(.+)=(.+)') m(match)";
    system_or_error "psql",
        "--cluster", "$version/$cluster",
        "-XAtc", $dbquery,
        "-o", "$backupdir/databases.sql";

    my $dblist = 'SELECT datname FROM pg_database WHERE datallowconn ORDER BY datname';
    my $databases = `psql --cluster '$version/$cluster' -XAtc '$dblist'`;
    for my $datname ($databases =~ /(.+)/g) {
        print "Dumping $datname to $backupdir/$datname.dump ...\n" if ($verbose);
        system_or_error "pg_dump",
            "--cluster", "$version/$cluster",
            "--format=custom",
            "--file", "$backupdir/$datname.dump",
            $datname;
    }
}

sub create_configbackup($) {
    my $backupdir = shift;
    $info{configdir} or error "cluster has no configdir";
    system_or_error "tar",
        "-C", $info{configdir},
        "-cz", "-f", "$backupdir/config.tar.gz",
        ".";
}

sub create_status($$$$) {
    my ($type, $starttime, $backupdir, $status) = @_;
    my $statusfile = "$backupdir/status";
    my $endtime = time;
    my $statusjson = {
        cluster => $cluster,
        duration => $endtime - $starttime,
        end => scalar(gmtime($endtime)),
        start => scalar(gmtime($starttime)),
        status => $status,
        type => $type,
        version => $version,
    };

    open F, '>', $statusfile or error "$statusfile: $!";
    print F encode_json($statusjson) . "\n" or error "$statusfile: $!";
    close F or error "$$statusfile: $!";
}

sub sync($) {
    my $backupdir = shift;
    system_or_error "sync $backupdir/*";
}

sub expire_backups($$) {
    my ($suffix, $number) = @_;
    my @backups = glob("$clusterdir/*.$suffix");
    my $found = 0;
    for my $backup (reverse @backups) {
        # iterate reversely over backups until we have found enough valid ones
        if ($found >= $number) {
            print "Removing $backup ...\n" if ($verbose);
            $backup =~ /(.*)/; # untaint
            system_or_error "rm", "-rf", $1;
        } else {
            if (-f "$backup/status") {
                $found++;
            }
        }
    }
}

sub delete_broken() {
    my @backups = (glob("$clusterdir/*.backup"), glob("$clusterdir/*.dump"));
    for my $backup (@backups) {
        if (! -f "$backup/status") {
            print "Removing $backup ...\n" if ($verbose);
            $backup =~ /(.*)/; # untaint
            system_or_error "rm", "-rf", $1;
        }
    }
}

# wal handling

sub create_wal_directory() {
    if (! -d $waldir) {
        mkdir($waldir, 0750) or error "mkdir $waldir: $!";
    }
}

sub receivewal() {
    my $pg_receivewal = $version >= 10 ? 'pg_receivewal' : 'pg_receivexlog';

    # create slot
    system_or_error $pg_receivewal, "--cluster=$version/$cluster", "--slot", "pg_receivewal_service", "--create-slot", "--if-not-exists";

    # launch pg_receivewal
    $ENV{PGAPPNAME} = "pg_receivewal\@$version-$cluster.service";
    my @cmd = ($pg_receivewal, "--cluster", "$version/$cluster",
        "-D", $waldir, "--slot", "pg_receivewal_service");
    push @cmd, "--compress=5" if ($version >= 10);
    exec {$pg_receivewal} @cmd or error "exec $pg_receivewal: $!";
}

sub compresswal() {
    chdir $waldir or return; # ok if not yet created
    open my $lock, $waldir or error "open $waldir: $!"; # protect against concurrent runs
    flock $lock, LOCK_EX or error "flock $waldir: $!";

    for my $wal (glob "0???????????????????????") {
        $wal =~ /^([0-9A-F]+)$/ or continue;
        $wal = $1; # untaint
        if (-f "$wal.gz") {
            print STDERR "$waldir/$wal.gz already exists, skipping compression\n";
            next;
        }
        system_or_error "if ! gzip < $wal > $wal.tmp.gz; then rm -f $wal.tmp.gz; exit 1; fi";
        system_or_error "touch --reference=$wal $wal.tmp.gz";
        system_or_error "mv $wal.tmp.gz $wal.gz";
        system_or_error "sync", "$wal.gz";
        unlink $wal;
    }

    close $lock;
}

sub archivecleanup() {
    chdir $waldir or return; # ok if not yet created
    my @backups = sort glob "$clusterdir/*.backup";
    for my $backup (@backups) {
        next unless (-f "$backup/status");

        $backup =~ /(.*)/; # untaint
        my $basetar = "$1/base.tar.gz";
        my $backup_label = `tar --extract --occurrence=1 --to-stdout --file '$basetar' backup_label` or error "failed to extract backup_label from $basetar";

        # START WAL LOCATION: 0/2B000028 (file 00000001000000000000002B)
        $backup_label =~ /^START WAL LOCATION: .* \(file ([0-9A-F]+)\)/ or error "no start wal location in $basetar";
        my $keep_file = $1;
        system_or_error "pg_archivecleanup", "-x", ".gz", $waldir, $keep_file;

        return 0; # process first backup only
    }
    error "no valid basebackups found in $clusterdir";
}

# info functions

sub dirsize($) {
    my $dir = shift;
    my $size = 0;
    my $files = 0;
    for my $f (glob "$dir/*") {
        $size += (stat $f)[7];
        $files++;
    }
    return $size, $files;
}

sub list() {
    print "Cluster $version $cluster backups in $clusterdir:\n";
    my $totalsize = 0;
    print "Dumps:\n";
    for my $dir (sort glob "$clusterdir/*.dump") {
        my ($size, $files) = dirsize($dir);
        my $status = -f "$dir/status" ? '' : ' BROKEN';
        print "  $dir: $size Bytes$status\n";
        $totalsize += $size;
    }
    print "Basebackups:\n";
    for my $dir (sort glob "$clusterdir/*.backup") {
        my ($size, $files) = dirsize($dir);
        my $status = -f "$dir/status" ? '' : ' BROKEN';
        print "  $dir: $size Bytes$status\n";
        $totalsize += $size;
    }
    if (-d "$clusterdir/wal") {
        print "WAL:\n";
        my ($size, $files) = dirsize("$clusterdir/wal");
        print "  $clusterdir/wal: $size Bytes, $files Files\n";
        $totalsize += $size;
    }
    print "Total: $totalsize Bytes\n";
}

# main

if ($action eq 'createdirectory') {
    create_directory();

} elsif ($action eq 'basebackup') {
    error "basebackups of pre-9.1 servers are not supported" if ($version < 9.1);
    my $starttime = time;
    create_directory();
    switch_to_cluster_owner();
    my $backupdir = get_backupdir('backup');
    $SIG{__DIE__} = sub { remove_backup_on_error($backupdir) };
    create_basebackup($backupdir);
    create_configbackup($backupdir);
    create_status($action, $starttime, $backupdir, 'ok');
    $SIG{__DIE__} = undef;
    sync($backupdir);
    compresswal();

} elsif ($action eq 'dump') {
    error "dumps of pre-9.3 servers are not supported" if ($version < 9.3);
    my $starttime = time;
    create_directory();
    switch_to_cluster_owner();
    my $backupdir = get_backupdir('dump');
    $SIG{__DIE__} = sub { remove_backup_on_error($backupdir) };
    create_dumpall($backupdir);
    create_configbackup($backupdir);
    create_status($action, $starttime, $backupdir, 'ok');
    $SIG{__DIE__} = undef;
    sync($backupdir);

} elsif ($action eq 'expiredumps' and @ARGV == 2 and $ARGV[1] =~ /^(\d+)$/) {
    switch_to_cluster_owner();
    expire_backups('dump', $1);

} elsif ($action eq 'expirebasebackups' and @ARGV == 2 and $ARGV[1] =~ /^(\d+)$/) {
    switch_to_cluster_owner();
    expire_backups('backup', $1);
    archivecleanup();
    compresswal();

} elsif ($action eq 'deletebroken') {
    switch_to_cluster_owner();
    delete_broken();

} elsif ($action eq 'receivewal') {
    create_directory();
    switch_to_cluster_owner();
    create_wal_directory();
    compresswal();
    receivewal();

} elsif ($action eq 'compresswal') {
    switch_to_cluster_owner();
    compresswal();

} elsif ($action eq 'archivecleanup') {
    switch_to_cluster_owner();
    archivecleanup();
    compresswal();

} elsif ($action eq 'list') {
    switch_to_cluster_owner();
    list();

} else {
    help();
    exit(1);
}

__END__

=head1 NAME

pg_backupcluster - simple pg_basebackup and pg_dump front-end

=head1 SYNOPSIS

B<pg_backupcluster> [I<options>] I<version> I<cluster> I<action>

=head1 DESCRIPTION

B<pg_backupcluster> provides a simple interface to create PostgreSQL cluster
backups using L<pg_basebackup(1)> and L<pg_dump(1)>.

To ease integration with B<systemd> operation, the alternative syntax
"B<pg_basebackup> I<version>B<->I<cluster> I<action>" is also supported.

=head1 ACTIONS

=over 4

=item B<createdirectory>

Create /var/backups and /var/backups/I<version>-I<cluster>.
This action can be run as root to create the directories required for backups.
All other actions will also attempt to create the directories when missing, but
can of course only do that when running as root. They will switch to the
cluster owner after this step.

=item B<basebackup>

Backup using L<pg_basebackup(1)>. The resulting basebackup contains the WAL
files required to run recovery on startup.

=item B<dump>

Backup using L<pg_dump(1)>. Global objects (users, tablespaces) are dumped
using L<pg_dumpall(1)> B<--globals-only>. Individual databases are dumped into
PostgreSQL's custom format.

=item B<expirebasebackups> I<N>

Remove all but last the I<N> basebackups.

=item B<expiredumps> I<N>

Remove all but last the I<N> dumps.

=item B<receivewal>

Launch pg_receivewal. WAL files are gzip-compressed in PG 10+.

=item B<compresswal>

Compress WAL files in archive.

=item B<archivecleanup>

Remove obsolete WAL files from archive using L<pg_archivecleanup(1)>.

=item B<list>

Show dumps, basebackups, and WAL, with size.

=back

=head1 OPTIONS

=over 4

=item B<-k --keep-on-error>

Keep faulty backup directory on error. By default backups are delete on error.

=item B<-v --verbose>

Verbose output, even when not running on a terminal.

=back

=head1 FILES

=over 4

=item /var/backups

Default root directory for cluster backup directories.

=item /var/backups/I<version>-I<cluster>

Default directory for cluster backups.

=item /var/backups/I<version>-I<cluster>/I<timestamp>B<.basebackup>

Backup from B<pg_backupcluster ... basebackup>.

=over 4

=item C<config.tar.gz>

Tarball of cluster configuration directory (postgresql.conf, pg_hba.conf, ...)
in /etc/postgresql.

=item I<tablespace>C<.tar.gz>, C<pg_wal.tar.gz>, C<backup_manifest>

Tablespace and WAL tarballs and backup info written by B<pg_basebackup>.

=item C<status>

Completion timestamp of backup run.

=back

=item /var/backups/I<version>-I<cluster>/I<timestamp>B<.dump>

Backup from B<pg_backupcluster ... dump>.

=over 4

=item C<config.tar.gz>

Tarball of cluster configuration directory (postgresql.conf, pg_hba.conf, ...)
in /etc/postgresql.

=item C<createcluster.opts>

Options (encoding, locale, data checksums) to be passed to B<pg_createcluster>
for restoring this cluster.

=item C<globals.sql>

Global objects (roles, tablespaces) from B<pg_dumpall --globals-only>.

=item C<databases.sql>

SQL commands to create databases and restore database-level options.

=item I<database>C<.dump>

Database dumps from B<pg_dump --format=custom>.

=item C<status>

Completion timestamp of backup run.

=back

=item /var/backups/I<version>-I<cluster>/B<wal>

WAL files from B<pg_receivewal>.

=back

=head1 CAVEATS

For dump-style backups, not all properties of the original cluster are preserved:

=over 2

=item * In PostgreSQL 10 and earlier, ALTER ROLE ... IN DATABASE is not supported.

=item * Not all B<initdb> options are carried over. Currently supported are B<--encoding>,
B<--lc-collate>, B<--lc-collate>, and B<-k --data-checksums>.

=back

The earliest PostgreSQL version supported for dumps is 9.3.
For basebackups, the earliest supported version is 9.1.
B<receivewal> (and hence archive recovery) are supported in 9.5 and later.

=head1 SEE ALSO

L<pg_restorecluster(1)>,
L<pg_dump(1)>, L<pg_dumpall(1)>,
L<pg_basebackup(1)>, L<pg_receivewal(1)>, L<pg_archivecleanup(1)>.

=head1 AUTHOR

Christoph Berg L<E<lt>myon@debian.orgE<gt>>