check_pgbackrest

#!/usr/bin/env perl
#-----------------------------------------------------------------------------
# This program is open source, licensed under the PostgreSQL license.
# For license terms, see the LICENSE file.
#
# Author: Stefan Fercot
# Copyright: (c) 2018-2020, Dalibo.
#-----------------------------------------------------------------------------

=head1 NAME

check_pgbackrest - pgBackRest backup check plugin for Nagios

=head1 SYNOPSIS

  check_pgbackrest [-s|--service SERVICE] [-S|--stanza NAME]
  check_pgbackrest [-l|--list]
  check_pgbackrest [--help]

=head1 DESCRIPTION

check_pgbackrest is designed to monitor pgBackRest backups from Nagios.

=cut

use vars qw($VERSION $PROGRAM);
use strict;
use warnings;
use POSIX;
use Data::Dumper;
use File::Basename;
use File::Spec;
use File::Find;
use Getopt::Long qw(:config bundling no_ignore_case_always);
use Pod::Usage;
use Config;
use FindBin;

# Display error message if some specific modules are not loaded
BEGIN {
    my(@DBs, @missingDBs, $mod);

    @DBs = qw(JSON);
    for $mod (@DBs) {
        if (eval "require $mod") {
            $mod->import();
        } else {
            push @missingDBs, $mod;
        }
    }
    die "@missingDBs module(s) not loaded.\n" if @missingDBs;
}

# Messing with PATH so pod2usage always finds this script
my @path = split /$Config{'path_sep'}/ => $ENV{'PATH'};
push @path => $FindBin::Bin;
$ENV{'PATH'} = join $Config{'path_sep'} => @path;
undef @path;

# Reference to the output sub
my $output_fmt;

$VERSION = '1.9dev';
$PROGRAM = 'check_pgbackrest';

# Available services and descriptions.
#-----------------------------------------------------------------------------

my %services = (
    'retention' => {
        'sub'  => \&check_retention,
        'desc' => 'Check the retention policy.',
        'stanza-arg' => 1
    },
    'archives' => {
        'sub'  => \&check_wal_archives,
        'desc' => 'Check WAL archives.',
        'stanza-arg' => 1
    },
    'check_pgb_version' => {
        'sub'  => \&check_pgb_version,
        'desc' => 'Check the version of this check_pgbackrest script.',
        'stanza-arg' => 0
    }
);

=over

=item B<-s>, B<--service> SERVICE

The Nagios service to run. See section SERVICES for a description of
available services or use C<--list> for a short service and description
list.

=item B<-S>, B<--stanza> NAME

Name of the stanza to check.

=item B<-O>, B<--output> OUTPUT_FORMAT

The output format. Supported outputs are: C<human>, C<json> and C<nagios> (default).

=item B<-C>, B<--command> FILE

pgBackRest executable file (default: "pgbackrest").

=item B<-c>, B<--config> CONFIGURATION_FILE

pgBackRest configuration file.

=item B<-P>, B<--prefix> COMMAND

Some prefix command to execute the pgBackRest info command 
(eg: "sudo -iu postgres").

=item B<-l>, B<--list>

List available services.

=item B<--debug>

Print some debug messages.

=item B<-V>, B<--version>

Print version and exit.

=item B<-?>, B<--help>

Show this help page.

=back

=cut

my %args = (
    'command' => 'pgbackrest',
    'output' => 'nagios',
    'wal-segsize' => '16MB',
    'default-pgbackrest-config-file' => '/etc/pgbackrest.conf',
);

# Set name of the program without path*
my $orig_name = $0;
$0 = $PROGRAM;

# Die on kill -1, -2, -3 or -15
$SIG{'HUP'} = $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = \&terminate;

# Handle SIG
sub terminate {
    my ($signal) = @_;
    die ("SIG $signal caught.");
}

# Print the version and exit
sub version {
    printf "%s version %s, Perl %vd\n",
        $PROGRAM, $VERSION, $^V;

    exit 0;
}

# List services that can be performed
sub list_services {

    print "List of available services:\n\n";

    foreach my $service ( sort keys %services ) {
        printf "\t%-17s\t%s\n", $service, $services{$service}{'desc'};
    }

    exit 0;
}

# Handle output formats
#-----------------------------------------------------------------------------
sub dprint {
    return unless $args{'debug'};
    foreach (@_) {
        print "DEBUG: $_";
    }
}

sub unknown($;$$$) {
    return $output_fmt->( 3, $_[0], $_[1], $_[2], $_[3] );
}

sub critical($;$$$) {
    return $output_fmt->( 2, $_[0], $_[1], $_[2], $_[3] );
}

sub warning($;$$$) {
    return $output_fmt->( 1, $_[0], $_[1], $_[2], $_[3] );
}

sub ok($;$$$) {
    return $output_fmt->( 0, $_[0], $_[1], $_[2], $_[3] );
}

sub human_output ($$;$$$) {
    my $rc      = shift;
    my $service = shift;
    my $ret;
    my @msg;
    my @longmsg;
    my @human_only_longmsg;

    @msg      = @{ $_[0] } if defined $_[0];
    @longmsg  = @{ $_[1] } if defined $_[1];
    @human_only_longmsg  = @{ $_[2] } if defined $_[2];

    $ret  = sprintf "%-15s: %s\n", 'Service', $service;

    $ret .= sprintf "%-15s: 0 (%s)\n", "Returns", "OK"       if $rc == 0;
    $ret .= sprintf "%-15s: 1 (%s)\n", "Returns", "WARNING"  if $rc == 1;
    $ret .= sprintf "%-15s: 2 (%s)\n", "Returns", "CRITICAL" if $rc == 2;
    $ret .= sprintf "%-15s: 3 (%s)\n", "Returns", "UNKNOWN"  if $rc == 3;

    $ret .= sprintf "%-15s: %s\n", "Message", $_ foreach @msg;
    $ret .= sprintf "%-15s: %s\n", "Long message", $_ foreach @longmsg;
    $ret .= sprintf "%-15s: %s\n", "Long message", $_ foreach @human_only_longmsg;

    print $ret;
    return $rc;
}

sub json_output ($$;$$$) {
    my $rc      = shift;
    my $service = shift;
    my @msg;
    my @longmsg;
    my @human_only_longmsg;

    @msg      = @{ $_[0] } if defined $_[0];
    @longmsg  = @{ $_[1] } if defined $_[1];
    @human_only_longmsg  = @{ $_[2] } if defined $_[2];
	
	my %json_hash = ('service' => $service);
	my @rc_long = ("OK", "WARNING", "CRITICAL", "UNKNOWN");
	$json_hash{'status'}{'code'} = $rc;
	$json_hash{'status'}{'message'} = $rc_long[$rc];
	$json_hash{'message'} = join( ', ', @msg ) if @msg;

	foreach my $msg_to_split (@longmsg, @human_only_longmsg) {
		my ($key, $value) = split(/=/, $msg_to_split);
		$json_hash{'long_message'}{$key} = $value;
	}

	my $json_text = encode_json \%json_hash;
	print "[$json_text]";
    return $rc;
}

sub nagios_output ($$;$$) {
    my $rc  = shift;
    my $ret = shift;
    my @msg;
    my @longmsg;

    $ret .= " OK"       if $rc == 0;
    $ret .= " WARNING"  if $rc == 1;
    $ret .= " CRITICAL" if $rc == 2;
    $ret .= " UNKNOWN"  if $rc == 3;

    @msg      = @{ $_[0] } if defined $_[0];
    @longmsg  = @{ $_[1] } if defined $_[1];

    $ret .= " - ". join( ', ', @msg )    if @msg;
    $ret .= " | ". join( ' ', @longmsg ) if @longmsg;

    print $ret;
    return $rc;
}

# Handle time intervals
#-----------------------------------------------------------------------------

sub is_time($){
    my $str_time = lc( shift() );
    return 1 if ( $str_time
        =~ /^(\s*([0-9]\s*[smhd]?\s*))+$/
    );
    return 0;
}

# Return formatted time string with units.
# Parameter: duration in seconds
sub to_interval($) {
    my $val      = shift;
    my $interval = '';

    return $val if $val =~ /^-?inf/i;

    $val = int($val);
 
    if ( $val > 604800 ) {
        $interval = int( $val / 604800 ) . "w ";
        $val %= 604800;
    }

    if ( $val > 86400 ) {
        $interval .= int( $val / 86400 ) . "d ";
        $val %= 86400;
    }

    if ( $val > 3600 ) {
        $interval .= int( $val / 3600 ) . "h";
        $val %= 3600;
    }

    if ( $val > 60 ) {
        $interval .= int( $val / 60 ) . "m";
        $val %= 60;
    }

    $interval .= "${val}s" if $val > 0;

    return "${val}s" unless $interval; # return a value if $val <= 0

    return $interval;
}

sub to_interval_output_dependent($) {
    my $val      = shift;
    my $interval = '';

    return $val if $val =~ /^-?inf/i;
    $val = int($val);
    return to_interval($val) unless $args{'output'} =~ /^nagios$/;
    return "${val}s";
}

# Return a duration in seconds from an interval (with units).
sub get_time($) {
    my $str_time = lc( shift() );
    my $ts       = 0;
    my @date;

    die(      "Malformed interval: «$str_time»!\n"
            . "Authorized unit are: dD, hH, mM, sS.\n" )
        unless is_time($str_time);

    # no bad units should exist after this line!

    @date = split( /([smhd])/, $str_time );

LOOP_TS: while ( my $val = shift @date ) {

        $val = int($val);
        die("Wrong value for an interval: «$val»!") unless defined $val;

        my $unit = shift(@date) || '';

        if ( $unit eq 'm' ) {
            $ts += $val * 60;
            next LOOP_TS;
        }

        if ( $unit eq 'h' ) {
            $ts += $val * 3600;
            next LOOP_TS;
        }

        if ( $unit eq 'd' ) {
            $ts += $val * 86400;
            next LOOP_TS;
        }

        $ts += $val;
    }

    return $ts;
}

# Handle size units
#-----------------------------------------------------------------------------

# Return a size in bytes from a size with unit.
# If unit is '%', use the second parameter to compute the size in bytes.
sub get_size($;$) {
    my $str_size = shift;
    my $size     = 0;
    my $unit     = '';

    die "Only integers are accepted as size. Adjust the unit to your need.\n"
        if $str_size =~ /[.,]/;

    $str_size =~ /^([0-9]+)(.*)$/;

    $size = int($1);
    $unit = lc($2);

    return $size unless $unit ne '';

    if ( $unit eq '%' ) {
        my $ratio = shift;

        die("Can't compute a ratio without the factor!\n")
            unless defined $unit;

        return int( $size * $ratio / 100 );
    }

    return $size           if $unit eq 'b';
    return $size * 1024    if $unit =~ '^k[bo]?$';
    return $size * 1024**2 if $unit =~ '^m[bo]?$';
    return $size * 1024**3 if $unit =~ '^g[bo]?$';
    return $size * 1024**4 if $unit =~ '^t[bo]?$';
    return $size * 1024**5 if $unit =~ '^p[bo]?$';
    return $size * 1024**6 if $unit =~ '^e[bo]?$';
    return $size * 1024**7 if $unit =~ '^z[bo]?$';

    die("Unknown size unit: $unit\n");
}

# Interact with pgBackRest
#-----------------------------------------------------------------------------

sub pgbackrest_info {
    my $infocmd = $args{'command'}." info";
    $infocmd .= " --stanza=".$args{'stanza'};
    $infocmd .= " --output=json";

    if(defined $args{'config'}) {
        $infocmd .= " --config=".$args{'config'};
    }    

    if(defined $args{'prefix'}) {
        $infocmd = $args{'prefix'}." $infocmd";
    }

    dprint("pgBackRest info command was : '$infocmd'\n");
    my $json_output = `$infocmd 2>&1 |grep -v WARN |grep -v ERROR`;

    die("Can't get pgBackRest info.\nCommand was '$infocmd'.\n") unless ($? eq 0);
    
    my $decoded_json = decode_json($json_output);

    foreach my $line (@{$decoded_json}) {
        return $line if($line->{'name'} eq $args{'stanza'});
    }

    return;
}

sub pgbackrest_ls {
	my $args_ref = shift;
    my %args = %{ $args_ref };
    my $lscmd = $args{'command'}." ls";
    $lscmd .= " ".$args{'archives_dir'};
    $lscmd .= " --recurse --output=json";

    if(defined $args{'config'}) {
        $lscmd .= " --config=".$args{'config'};
    }    

    if(defined $args{'prefix'}) {
        $lscmd = $args{'prefix'}." $lscmd";
    }

    dprint("pgBackRest ls command was : '$lscmd'\n");
    my $json_output = `$lscmd 2>&1 |grep -v WARN |grep -v ERROR`;

    die("Can't get pgBackRest list.\nCommand was '$lscmd'.\n") unless ($? eq 0);
    
    return decode_json($json_output);
}

sub pgbackrest_version {
    my $args_ref = shift;
    my %args = %{ $args_ref };
    my $version_cmd = $args{'command'}." version";

    if(defined $args{'config'}) {
        $version_cmd .= " --config=".$args{'config'};
    }    

    if(defined $args{'prefix'}) {
        $version_cmd = $args{'prefix'}." $version_cmd";
    }

    dprint("pgBackRest version command was : '$version_cmd'\n");
    my $pgbackrest_version = `$version_cmd | sed -e s/pgBackRest\\ // | sed -e s/dev//`;

    die("Can't get pgBackRest version.\nCommand was '$version_cmd'.\n") unless ($? eq 0);
    
    return $pgbackrest_version;
}

# Services
#-----------------------------------------------------------------------------

=head2 SERVICES

Descriptions and parameters of available services.

=over

=item B<retention>

Fail when the number of full backups is less than the 
C<--retention-full> argument.

Fail when the newest backup is older than the C<--retention-age> 
argument.

Fail when the newest full backup is older than the 
C<--retention-age-to-full> argument.

The following units are accepted (not case sensitive): s (second), m 
(minute), h (hour), d (day). You can use more than one unit per 
given value.

Arguments are not mandatory to only show some information.

=cut

sub check_retention {
    my $me             = 'BACKUPS_RETENTION';
    my %args           = %{ $_[0] };
    my @msg;
    my @warn_msg;
    my @crit_msg;
    my @longmsg;

    my $backups_info = pgbackrest_info();
    die("Can't get pgBackRest info.\n") unless (defined $backups_info);

    if($backups_info->{'status'}->{'code'} == 0) {
        my @full_bck;
        my @diff_bck;
        my @incr_bck;

        foreach my $line (@{$backups_info->{'backup'}}){
            push @full_bck, $line if($line->{'type'} eq "full");
            push @diff_bck, $line if($line->{'type'} eq "diff");
            push @incr_bck, $line if($line->{'type'} eq "incr");
        }

        push @longmsg, "full=".scalar(@full_bck);
        push @longmsg, "diff=".scalar(@diff_bck);
        push @longmsg, "incr=".scalar(@incr_bck);

        # check retention
        if(defined $args{'retention-full'} and scalar(@full_bck) < $args{'retention-full'}){
            push @crit_msg, "not enough full backups, ".$args{'retention-full'}." required";
        }

        # check latest age
        # backup age considered at pg_stop_backup
        my $latest_bck = @{$backups_info->{'backup'}}[-1];
        my $latest_bck_age = time() - $latest_bck->{'timestamp'}->{'stop'};
        push @longmsg, "latest=".$latest_bck->{'type'}.",".$latest_bck->{'label'};
        push @longmsg, "latest_age=".to_interval_output_dependent($latest_bck_age);

        if(defined $args{'retention-age'}){
            my $bck_age_limit = get_time($args{'retention-age'} );
            push @crit_msg, "backups are too old" if $latest_bck_age >= $bck_age_limit;
        }

        # check latest full backup age
        if(defined $args{'retention-age-to-full'}){
            my $latest_full_bck = $full_bck[-1];
            my $latest_full_bck_age = time() - $latest_full_bck->{'timestamp'}->{'stop'};
            push @longmsg, "latest_full=".$latest_full_bck->{'label'};
            push @longmsg, "latest_full_age=".to_interval_output_dependent($latest_full_bck_age);

            my $bck_age_limit = get_time($args{'retention-age-to-full'} );
            push @crit_msg, "full backups are too old" if $latest_full_bck_age >= $bck_age_limit;
        }
    }else{
        push @crit_msg, $backups_info->{'status'}->{'message'};
    }

    return critical($me, \@crit_msg, \@longmsg) if @crit_msg;
    return warning($me, \@warn_msg, \@longmsg) if @warn_msg;
    push @msg, "backups policy checks ok";
    return ok( $me, \@msg, \@longmsg );
}

=item B<archives>

Check if all archived WALs exist between the oldest and the latest 
WAL needed for the recovery.

This service requires the C<--repo-path> argument to specify where 
the archived WALs are stored.

The C<--repo-host> and C<--repo-host-user> arguments allow to list
remote archived WALs using SFTP.

The C<--repo-s3> enables remote archived WALs stored in Amazon S3.

The C<--repo-s3-over-http> switch to HTTP connection instead of HTTPS.

Archives must be compressed (.gz). If needed, use "compress-level=0"
instead of "compress=n".

Use the C<--wal-segsize> argument to set the WAL segment size.

The following units are accepted (not case sensitive):
b (Byte), k (KB), m (MB), g (GB), t (TB), p (PB), e (EB) or Z (ZB). Only
integers are accepted. Eg. C<1.5MB> will be refused, use C<1500kB>.

The factor between units is 1024 bytes. Eg. C<1g = 1G = 1024*1024*1024.> 

Use the C<--ignore-archived-before> argument to ignore the archived 
WALs generated before the provided interval. Used to only check the
latest archives.

Use the C<--ignore-archived-after> argument to ignore the archived 
WALs generated after the provided interval.

The C<--latest-archive-age-alert> argument defines the max age of 
the latest archived WAL as an interval before raising a critical 
alert.

The following units are accepted as interval (not case sensitive):
s (second), m (minute), h (hour), d (day). You can use more than 
one unit per given value. If not set, the last unit is in seconds. 
Eg. "1h 55m 6" = "1h55m6s".

All the missing archives are only shown in the `--debug` mode.

Use `--list-archives` in addition with `--debug` to print the list of all the 
archived WAL segments.

=cut

sub get_archived_wal_list {
    my $min_wal = shift;
    my $max_wal = shift;
    my $args_ref = shift;
    my %args = %{ $args_ref };
    my $suffix = ".gz";
    my $archives_dir = $args{'archives_dir'};

    my @filelist;
    my @branch_wals;
    my $filename_re = qr/^[0-9A-F]{24}.*$suffix$/;
    my $filename_re_full = qr/[0-9A-F]{24}.*$suffix$/;
    my $start_tl = substr($min_wal, 0, 8);
    my $end_tl   = substr($max_wal, 0, 8);
    my $history_re = qr/$end_tl.history$/;
    my $history_re_full = qr/$end_tl.history$/;

    my $pgbackrest_version=pgbackrest_version(\%args);
    my $activate_pgbackrest_ls_command=0;
    if($pgbackrest_version >= '2.22' && $activate_pgbackrest_ls_command){
        # pgBackRest ls command
        my $list=pgbackrest_ls(\%args);

        foreach my $key (keys $list) {
            next unless $list->{$key}->{'type'} eq 'file';
            my @split_tab = split('/', $key);
            my $filename = $split_tab[-1];

            if($filename =~ /$filename_re_full/){
                # Get stats of the archived wals
                if ( $args{'ignore-archived-after'} or $args{'ignore-archived-before'} ) {
                    my $diff_epoch = time() - $list->{$key}->{'time'};

                    if ( $args{'ignore-archived-after'} && $diff_epoch <= get_time($args{'ignore-archived-after'}) ){
                        dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        return;
                    }
                    
                    if ( $args{'ignore-archived-before'} && $diff_epoch >= get_time($args{'ignore-archived-before'}) ){
                        dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        return;
                    }
                }

                push @filelist, [substr($filename, 0, 24), $filename, $list->{$key}->{'time'}, $list->{$key}->{'size'}, "$archives_dir/$key"];

            }elsif($filename =~ /$history_re_full/ && $start_tl ne $end_tl){
                # Look for the last history file if needed
                dprint("history file to open : $filename\n");

                #FIXME - missing "get_content" of history files
            }
        }
    
    }elsif($args{'repo-host'}){
        # SFTP connection
        require Net::SFTP::Foreign;
        my $sftp;
        if($args{'repo-host-user'}){
            $sftp = Net::SFTP::Foreign->new($args{'repo-host'}, user => $args{'repo-host-user'});
        }else{
            $sftp = Net::SFTP::Foreign->new($args{'repo-host'});
        }
        $sftp->die_on_error("Unable to establish SFTP connection");

        $sftp->find($archives_dir,
            wanted => sub {
                my $file_fullpath = $_[1]->{filename};
                my @split_tab = split('/', $file_fullpath);
                my $filename = $split_tab[-1];

                if($filename =~ /$filename_re/){
                    # Get stats of the archived wals
                    my $attributes = $sftp->stat($_[1]->{filename})
                        or die "remote stat command failed : ".$sftp->status;

                    if ( $args{'ignore-archived-after'} or $args{'ignore-archived-before'} ) {
                        my $diff_epoch = time() - $attributes->mtime;
                        
                        if ( $args{'ignore-archived-after'} && $diff_epoch <= get_time($args{'ignore-archived-after'}) ){
                        	dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        	return;
                        }
                        
                        if ( $args{'ignore-archived-before'} && $diff_epoch >= get_time($args{'ignore-archived-before'}) ){
                        	dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        	return;
                        }
                    }

                    push @filelist, [substr($filename, 0, 24), $filename, $attributes->mtime, $attributes->size, $file_fullpath];

                }elsif($filename =~ /$history_re/ && $start_tl ne $end_tl){
                    # Look for the last history file if needed
                    dprint("history file to open : $filename\n");
                    
                    my $history_content = $sftp->get_content($file_fullpath)
                        or die "remote get_content command failed : ".$sftp->status;

                    my @history_lines = split /\n/, $history_content;
                    foreach my $line ( @history_lines ){ 

                        my $line_re = qr/^\s*(\d)\t([0-9A-F]+)\/([0-9A-F]+)\t.*$/;
                        $line =~ /$line_re/ || next;
                        push @branch_wals =>
                            sprintf("%08d%08s%08X", $1, $2, hex($3)>>24);
                    }
                }             
            }
        );

    }elsif($args{'repo-s3'}){
        require Net::Amazon::S3;
        require Config::IniFiles;

        my $cfg_file=$args{'default-pgbackrest-config-file'};
        if(defined $args{'config'}) {
            $cfg_file=$args{'config'};
        }
        dprint("cfg_file: $cfg_file\n");

        my $cfg = Config::IniFiles->new( -file => $cfg_file );
        my $aws_key = $cfg->val( 'global', 'repo1-s3-key' );
        my $aws_secret = $cfg->val( 'global', 'repo1-s3-key-secret' );
        my $repo1_bucket = $cfg->val( 'global', 'repo1-s3-bucket' );
        my $repo1_endpoint = $cfg->val( 'global', 'repo1-s3-endpoint' );
        dprint("repo1-s3-bucket: $repo1_bucket\n");
        dprint("repo1-s3-endpoint: $repo1_endpoint\n");

        my $secure = defined $args{'repo-s3-over-http'} ? 0 : 1;

        pod2usage(
            -message => 'FATAL: be sure to set repo1-s3-endpoint, repo1-s3-key, repo1-s3-key-secret, and repo1-s3-bucket in the pgBackRest configuration file.',
            -exitval => 127
        ) unless ( defined $aws_key and defined $aws_secret and defined $repo1_bucket and defined $repo1_endpoint );

        my $s3 = Net::Amazon::S3->new(
            aws_access_key_id     => $aws_key,
            aws_secret_access_key => $aws_secret,
            host                  => $repo1_endpoint,
            retry                 => 1,
            secure                => $secure,
        );

        my $client = Net::Amazon::S3::Client->new( s3 => $s3 );
        my $bucket = $client->bucket( name => $repo1_bucket );

        my $stream = $bucket->list({ prefix => $archives_dir, delimiter => '/' });
        until ( $stream->is_done ) {
            foreach my $object ( $stream->items ) {
                my $file_fullpath = $object->key;
                my @split_tab = split('/', $file_fullpath);
                my $filename = $split_tab[-1];

                if($filename =~ /$filename_re/){
                    # Get stats of the archived wals
                    my $dt = $object->last_modified;

                    if ( $args{'ignore-archived-after'} or $args{'ignore-archived-before'} ) {
                        my $diff_epoch = time() - $dt->epoch();

                        if ( $args{'ignore-archived-after'} && $diff_epoch <= get_time($args{'ignore-archived-after'}) ){
                        	dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        	return;
                        }
                        
                        if ( $args{'ignore-archived-before'} && $diff_epoch >= get_time($args{'ignore-archived-before'}) ){
                        	dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        	return;
                        }
                    }

                    push @filelist, [substr($filename, 0, 24), $filename, $dt->epoch(), $object->size, $file_fullpath];

                }elsif($filename =~ /$history_re/ && $start_tl ne $end_tl){
                    # Look for the last history file if needed
                    dprint("history file to open : $filename\n");
                    
                    my $history_content = $object->get;
                    my @history_lines = split /\n/, $history_content;
                    foreach my $line ( @history_lines ){ 

                        my $line_re = qr/^\s*(\d)\t([0-9A-F]+)\/([0-9A-F]+)\t.*$/;
                        $line =~ /$line_re/ || next;
                        push @branch_wals =>
                            sprintf("%08d%08s%08X", $1, $2, hex($3)>>24);
                    }
                }
            }
        }

    }else{
        find ({ wanted => sub {
                return unless -f;
                my $file_fullpath = $File::Find::name;
                my @split_tab = split('/', $file_fullpath);
                my $filename = $split_tab[-1];

                if($filename =~ /$filename_re_full/){
                    # Get stats of the archived wals
                    if ( $args{'ignore-archived-after'} or $args{'ignore-archived-before'} ) {
                        my $diff_epoch = time() - (stat($file_fullpath))[9];

                        if ( $args{'ignore-archived-after'} && $diff_epoch <= get_time($args{'ignore-archived-after'}) ){
                        	dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        	return;
                        }
                        
                        if ( $args{'ignore-archived-before'} && $diff_epoch >= get_time($args{'ignore-archived-before'}) ){
                        	dprint ("ignored file ".$filename." as interval since epoch : ".to_interval($diff_epoch)."\n");
                        	return;
                        }
                    }

                    push @filelist, [substr($filename, 0, 24), $filename, (stat($File::Find::name))[9,7], $file_fullpath];
                
                }elsif($filename =~ /$history_re_full/ && $start_tl ne $end_tl){
                    # Look for the last history file if needed
                    dprint("history file to open : $filename\n");

                    open my $fd, "<", "$file_fullpath"
                        or die "Can't open < $file_fullpath : $!";

                    while ( <$fd> ) {
                        next unless m{^\s*(\d)\t([0-9A-F]+)/([0-9A-F]+)\t.*$};
                        push @branch_wals =>
                            sprintf("%08d%08s%08X", $1, $2, hex($3)>>24);
                    }
                    close $fd; 
                }
            }, no_chdir => 1, follow => 1
        }, $archives_dir );
    }

    my @unique_branch_wals = do { my %seen; grep { !$seen{$_}++ } @branch_wals };
    return(\@filelist, \@unique_branch_wals);
}

sub generate_needed_wal_archives_list {
    my $min_wal = shift;
    my $max_wal = shift;
    my $branch_wals_ref = shift;
    my @branch_wals = @{ $branch_wals_ref };
    my $seg_per_wal = shift;
    my $start_tl = substr($min_wal, 0, 8);
    my $end_tl   = substr($max_wal, 0, 8);
    my $timeline = hex($start_tl);
    my $wal = hex(substr($min_wal, 8, 8));
    my $seg = hex(substr($min_wal, 16, 8));

    # Generate list
    my $curr = $min_wal;
    my @needed_wal_archives_list;
    # dprint("$min_wal WAL needed\n");
    push @needed_wal_archives_list, $min_wal;

    for ( my $i=0, my $j=1; $curr lt $max_wal ; $i++, $j++ ) {
        $curr = sprintf('%08X%08X%08X',
            $timeline,
            $wal + int(($seg + $j)/$seg_per_wal),
            ($seg + $j)%$seg_per_wal
        );

        # dprint("$curr WAL needed\n");
        push @needed_wal_archives_list, $curr;

        if ( grep /$curr/, @branch_wals ) {
            dprint("found a boundary @ '$curr' !\n");
            $timeline++;
            $j--;
            next;
        }
    }

    my @unique_needed_wal_archives_list = do { my %seen; grep { !$seen{$_}++ } @needed_wal_archives_list };
    return sort @unique_needed_wal_archives_list;
}

sub check_wal_archives {
    my $me             = 'WAL_ARCHIVES';
    my %args           = %{ $_[0] };
    my @msg;
    my @warn_msg;
    my @crit_msg;
    my @longmsg;
    my @human_only_longmsg;

    pod2usage(
        -message => 'FATAL: you must provide --repo-path.',
        -exitval => 127
    ) if ( not defined $args{'repo-path'} );

    my $start_time = time();
    my $backups_info = pgbackrest_info();
    die("Can't get pgBackRest info.\n") unless (defined $backups_info);
    dprint("!> pgBackRest info took ".(time() - $start_time)."s\n");

    if($backups_info->{'status'}->{'code'} == 0) {
        my $archives_dir = $args{'repo-path'}."/".$args{'stanza'}."/".$backups_info->{'archive'}[0]->{'id'};
        dprint("archives_dir: $archives_dir\n");
        $args{'archives_dir'} = $archives_dir;
        push @human_only_longmsg, "archives_dir=$archives_dir";
        my $min_wal = $backups_info->{'archive'}[0]->{'min'};
        my $max_wal = $backups_info->{'archive'}[0]->{'max'};

        # Get all the WAL archives and history files
        $start_time = time();
        dprint("Get all the WAL archives and history files...\n");
        my ($filelist_ref, $branch_wals_ref) = &get_archived_wal_list($min_wal, $max_wal, \%args);
        my @filelist;
        @filelist = @{ $filelist_ref } if $filelist_ref;
        my @branch_wals;
        @branch_wals = @{ $branch_wals_ref } if $branch_wals_ref;
        return unknown $me, ['no archived WAL found'] unless @filelist;
		dprint("!> Get all the WAL archives and history files took ".(time() - $start_time)."s\n");

        # Sort by filename
        my @filelist_sorted = sort { $a->[0] cmp $b->[0] }
            grep{ (defined($_->[0]) and defined($_->[1]))
                or die "Can't read WAL files."
            } @filelist;

        my @filelist_simplified;
		my %filelist_simplified_hash;
        foreach my $elem (@filelist_sorted) {
            push @filelist_simplified, $elem->[0];
            $filelist_simplified_hash{ $elem->[0] } = $elem;
        }

        # Refresh after archives scan, assume pgBackRest info cmd returns very fast
        $start_time = time();
        $backups_info = pgbackrest_info();
        $max_wal = $backups_info->{'archive'}[0]->{'max'};
        dprint("!> Refresh pgBackRest info took ".(time() - $start_time)."s\n");

        # Change min_wal if some archived are ignored
        if ( $args{'ignore-archived-before'} && $min_wal ) {
            $min_wal = substr($filelist_sorted[0][0], 0, 24);
            dprint ("min_wal changed to ".$min_wal."\n");
        }
        push @human_only_longmsg, "min_wal=$min_wal" if $min_wal;

        # Change max_wal if some archived are ignored
        if ( $args{'ignore-archived-after'} && $max_wal ) {
            $max_wal = substr($filelist_sorted[-1][0], 0, 24);
            dprint ("max_wal changed to ".$max_wal."\n");
        }
        push @human_only_longmsg, "max_wal=$max_wal" if $max_wal;

        # Check min/max exists, start = min, last = max ?
        return critical $me, ['min WAL not found: '.$min_wal] if($min_wal && ! grep( /^$min_wal$/, @filelist_simplified ));
        return critical $me, ['max WAL not found: '.$max_wal] if($max_wal && ! grep( /^$max_wal$/, @filelist_simplified ));
        push @warn_msg, "min WAL is not the oldest archive" if($min_wal && ! grep( /^$min_wal/, $filelist_sorted[0][0] ));
        push @warn_msg, "max WAL is not the latest archive" if($max_wal && ! grep( /^$max_wal/, $filelist_sorted[-1][0] ));
        push @human_only_longmsg, "oldest_archive=".$filelist_sorted[0][0];
        push @human_only_longmsg, "latest_archive=".$filelist_sorted[-1][0];

        my $latest_archive_age = time() - $filelist_sorted[-1][2];
        my $num_archives = scalar(@filelist_sorted);
        push @longmsg, "latest_archive_age=".to_interval_output_dependent($latest_archive_age);
        push @longmsg, "num_archives=$num_archives";

        # Is the latest archive too old ?
        if ( $args{'latest-archive-age-alert'} && $latest_archive_age > get_time($args{'latest-archive-age-alert'})){
            push @crit_msg => "latest_archive_age (".to_interval($latest_archive_age).") exceeded";
        }
        push @msg, "$num_archives WAL archived";
        push @msg, "latest archived since ". to_interval($latest_archive_age);

        # Get all the needed wal archives based on min/max pgBackRest info
        my $wal_segsize = $args{'wal-segsize'};
        my $walsize = '4GB'; # 4 TB -> bytes
        my $seg_per_wal = get_size($walsize) / get_size($wal_segsize); #Only for PG >= 9.3
        my $dbver=($backups_info->{'db'}[0]->{'version'}+0)*10;
        $seg_per_wal-- if $dbver <= 92;
        dprint("Get all the needed wal archives...\n");
        $start_time = time();
        my @needed_wal_archives_list=&generate_needed_wal_archives_list($min_wal, $max_wal, \@branch_wals, $seg_per_wal);
		dprint("!> Get all the needed wal archives took ".(time() - $start_time)."s\n");

        # Get the latest backup info
        my $latest_bck = @{$backups_info->{'backup'}}[-1];
        my $latest_bck_archive_start = $latest_bck->{'archive'}->{'start'};
        push @human_only_longmsg, "latest_bck_archive_start=".$latest_bck_archive_start;
        push @human_only_longmsg, "latest_bck_type=".$latest_bck->{'type'};

        my @warn_missing_files;
        my @crit_missing_files;
        # Go through needed wal list and check if it exists in the file list
        $start_time = time();
        foreach my $needed_wal (@needed_wal_archives_list) {
            unless ( $filelist_simplified_hash{ $needed_wal } ) {
                if($needed_wal lt $latest_bck_archive_start) {
                    push @warn_missing_files => $needed_wal;
                }else{
                    push @crit_missing_files => $needed_wal;
                }
            }
        }
        dprint("!> Go through needed wal list and check took ".(time() - $start_time)."s\n");

        # Go through each backup to check their needed wal archives
        $start_time = time();
        foreach my $line (@{$backups_info->{'backup'}}){
            dprint("Get all the needed wal archives for ".$line->{'label'}."...\n");
            foreach my $needed_wal (&generate_needed_wal_archives_list($line->{'archive'}->{'start'}, $line->{'archive'}->{'stop'}, \@branch_wals, $seg_per_wal)) {
                unless ( $filelist_simplified_hash{ $needed_wal } ) {
                    push @crit_missing_files => $needed_wal;
                }
            }
        }
        dprint("!> Go through each backup, get the needed wal and check took ".(time() - $start_time)."s\n");

        # Generate @warn_msg and @crit_msg with missing files (sorted and unique)
        my @unique_warn_missing_files = do { my %seen; grep { !$seen{$_}++ } @warn_missing_files };
        my @unique_warn_missing_files_sorted = sort @unique_warn_missing_files;
        my $num_missing_archives = scalar(@unique_warn_missing_files_sorted);
        my $oldest_missing_archive = $unique_warn_missing_files_sorted[0] || '000000000000000000000000';
        my $latest_missing_archive = $unique_warn_missing_files_sorted[-1] || '000000000000000000000000';
        push @warn_msg, "wrong sequence, $num_missing_archives missing file(s) ($oldest_missing_archive / $latest_missing_archive)" if @warn_missing_files;
        
        push @crit_missing_files, @warn_missing_files if @warn_missing_files and @crit_missing_files;
        my @unique_crit_missing_files = do { my %seen; grep { !$seen{$_}++ } @crit_missing_files };
        my @unique_crit_missing_files_sorted = sort @unique_crit_missing_files;
        $num_missing_archives = scalar(@unique_crit_missing_files_sorted);
        $oldest_missing_archive = $unique_crit_missing_files_sorted[0] || $oldest_missing_archive || '000000000000000000000000';
        $latest_missing_archive = $unique_crit_missing_files_sorted[-1] || $latest_missing_archive || '000000000000000000000000';
        push @crit_msg, "wrong sequence, $num_missing_archives missing file(s) ($oldest_missing_archive / $latest_missing_archive)" if @crit_missing_files;
        push @longmsg, "num_missing_archives=$num_missing_archives" if $num_missing_archives;
        push @longmsg, "oldest_missing_archive=$oldest_missing_archive" if $num_missing_archives;
        push @longmsg, "latest_missing_archive=$latest_missing_archive" if $num_missing_archives;

        # DEBUG print all missing archives
        if(@warn_missing_files and not @crit_missing_files) {
        	foreach (@unique_warn_missing_files_sorted) { dprint("missing $_\n"); }
        
        }elsif(@crit_missing_files) {
        	foreach (@unique_crit_missing_files_sorted) { dprint("missing $_\n"); }
        }

        # DEBUG print all archives
        if($args{'list-archives'}) {
            my @unique_wals = do { my %seen; grep { !$seen{$_}++ } @filelist_simplified };
            foreach (@unique_wals) { dprint("found $_\n"); }
        }

    }else{
        push @crit_msg, $backups_info->{'status'}->{'message'};
    }

    return critical($me, \@crit_msg, \@longmsg, \@human_only_longmsg) if @crit_msg;
    return warning($me, \@warn_msg, \@longmsg, \@human_only_longmsg) if @warn_msg;
    return ok( $me, \@msg, \@longmsg, \@human_only_longmsg);
}

=item B<check_pgb_version>

Check if this script is running a given version.

You must provide the expected version using C<--target-version>.

=cut

sub check_pgb_version {
    my $me             = 'CHECK_PGBACKREST_VERSION';
    my %args           = %{ $_[0] };
    my @msg;
    my @warn_msg;
    my @crit_msg;
    my @longmsg;

    pod2usage(
        -message => 'FATAL: you must provide --target-version.',
        -exitval => 127
    ) if not defined $args{'target-version'};

    pod2usage(
        -message => "FATAL: given version does not look like a $PROGRAM version!",
        -exitval => 127
    ) if ( defined $args{'target-version'} and $args{'target-version'} !~ m/^\d\.\d+(?:_?(?:dev|beta|rc)\d*)?$/ );

    if (defined $args{'target-version'} and $VERSION ne $args{'target-version'}){
        push @crit_msg, sprintf("%s version should be %s", $PROGRAM, $args{'target-version'});
        push @longmsg, sprintf("%s version %s, Perl %vd", $PROGRAM, $VERSION, $^V);
    }

    return critical($me, \@crit_msg, \@longmsg) if @crit_msg;
    return warning($me, \@warn_msg, \@longmsg) if @warn_msg;

    push @msg, sprintf("%s version %s, Perl %vd", $PROGRAM, $VERSION, $^V);
    return ok( $me, \@msg, \@longmsg );
}

# End of SERVICE section in pod doc
=pod

=back

=cut

Getopt::Long::Configure('bundling');
GetOptions(
    \%args,
        'command|C=s',
        'config|c=s',
        'debug!',
        'output|O=s',
        'help|?!',
        'ignore-archived-after=s',
        'ignore-archived-before=s',
        'latest-archive-age-alert=s',
        'list|l!',
        'list-archives|L!',
        'prefix|P=s',
        'repo-s3!',
        'repo-s3-over-http!',
        'repo-host=s',
        'repo-host-user=s',
        'repo-path=s',
        'retention-age=s',
        'retention-age-to-full=s',
        'retention-full=i',
        'service|s=s',
        'stanza|S=s',
        'target-version=s',
        'version|V!',
        'wal-segsize=s'
) or pod2usage( -exitval => 127 );

list_services() if $args{'list'};
version()       if $args{'version'};
pod2usage( -verbose => 2 ) if $args{'help'};
pod2usage( -verbose => 1 ) unless defined $args{'service'};

# Check that the given service exists.
pod2usage(
    -message => "FATAL: service $args{'service'} does not exist.\n"
        . "    Use --list to show the available services.",
    -exitval => 127
) unless exists $services{ $args{'service'} };

# The stanza name must be given if a service is specified and 'stanza-arg' is required
pod2usage(
    -message => "FATAL: you must specify a stanza name.\n"
        . "    See -S or --stanza command line option.",
    -exitval => 127
) if defined $args{'service'} and $services{$args{'service'}}{'stanza-arg'} and not defined $args{'stanza'};

# Check "retention" specific args --retention-age, --retention-age-to-full and --retention-full
pod2usage(
    -message => 'FATAL: "retention-age", "retention-age-to-full" and "retention-full" are only allowed with "retention" service.',
    -exitval => 127
) if ( $args{'retention-age'} or $args{'retention-age-to-full'} or $args{'retention-full'} )
    and $args{'service'} ne 'retention';

# Check "archives" specific args --repo-path, --repo-host, --repo-host-user, --repo-s3 and --repo-s3-over-http
pod2usage(
    -message => 'FATAL: "repo-path", "repo-host", "repo-host-user", "repo-s3" and "repo-s3-over-http" are only allowed with "archives" service.',
    -exitval => 127
) if ( $args{'repo-path'} or $args{'repo-host'} or $args{'repo-host-user'} or $args{'repo-s3'}  or $args{'repo-s3-over-http'} )
    and $args{'service'} ne 'archives';

# Check "archives" specific args --ignore-archived-after, --ignore-archived-before and --latest-archive-age-alert
pod2usage(
    -message => 'FATAL: "ignore-archived-after", "ignore-archived-before" and "latest-archive-age-alert" are only allowed with "archives" service.',
    -exitval => 127
) if ( $args{'ignore-archived-after'} or $args{'ignore-archived-before'} or $args{'latest-archive-age-alert'} )
    and $args{'service'} ne 'archives';

# Check "archives" specific arg --list-archives
pod2usage(
    -message => 'FATAL: "list-archives" is only allowed with "archives" service and "debug" option.',
    -exitval => 127
) if $args{'list-archives'} and ( $args{'service'} ne 'archives' or ! $args{'debug'} );

# Check "check_pgb_version" specific arg --target-version
pod2usage(
    -message => 'FATAL: "target-version" is only allowed with "check_pgb_version" service.',
    -exitval => 127
) if $args{'target-version'} and $args{'service'} ne 'check_pgb_version';

# Output format
for ( $args{'output'} ) {
       if ( /^human$/         ) { $output_fmt = \&human_output  }
    elsif ( /^json$/        ) { $output_fmt = \&json_output }
    elsif ( /^nagios$/        ) { $output_fmt = \&nagios_output }
    else {
        pod2usage(
            -message => "FATAL: unrecognized output format \"$_\" (see \"--output\")",
            -exitval => 127
        );
    }
}

exit $services{ $args{'service'} }{'sub'}->( \%args );

__END__

=head1 CONTRIBUTING

check_pgbackrest is an open project. Any contribution to improve it is welcome.

=head1 VERSION

check_pgbackrest version 1.8, released on Mon Mar 16 2020.

=head1 LICENSING

This program is open source, licensed under the PostgreSQL license.
For license terms, see the LICENSE file.

=head1 AUTHORS

Author: Stefan Fercot.

Logo: Damien Cazeils (www.damiencazeils.com).

Copyright: (c) 2018-2020, Dalibo.

=cut