File Coverage

blib/lib/HealthCheck/Diagnostic.pm

Criterion	Covered	Total	%
statement	109	111	98.2
branch	72	78	92.3
condition	51	59	86.4
subroutine	15	15	100.0
pod	7	7	100.0
total	254	270	94.0

package HealthCheck::Diagnostic;

# ABSTRACT: A base clase for writing health check diagnositics
use version;
our $VERSION = 'v1.7.0'; # VERSION

use 5.010;
use strict;
use warnings;

use Carp;
use Time::HiRes qw< gettimeofday tv_interval >;

my $rfc3339_timestamp = qr/^(?:
    (?P[0-9]{4})-
    (?P1[0-2]|0[1-9])-
    (?P3[01]|0[1-9]|[12][0-9])
    [tT ]
    (?P2[0-3]|[01][0-9]):
    (?P[0-5][0-9]):
    (?P[0-5][0-9]|60)
    (?: \. (?P[0-9]+) )?
    (? [-+][0-9]{2}:[0-9]{2} | [zZ] )
)$/x;

#pod =head1 SYNOPSIS
#pod
#pod     package HealthCheck::Diagnostic::Sample;
#pod     use parent 'HealthCheck::Diagnostic';
#pod
#pod     # Required implementation of the check
#pod     # or you can override the 'check' method and avoid the
#pod     # automatic call to 'summarize'
#pod     sub run {
#pod         my ( $class_or_self, %params ) = @_;
#pod
#pod         # will be passed to 'summarize' by 'check'
#pod         return { %params, status => 'OK' };
#pod     }
#pod
#pod You can then either instantiate an instance and run the check.
#pod
#pod     my $diagnostic = HealthCheck::Diagnostic::Sample->new( id => 'my_id' );
#pod     my $result     = $diagnostic->check;
#pod
#pod Or as a class method.
#pod
#pod     my $result = HealthCheck::Diagnostic::Sample->check();
#pod
#pod Set C to a truthy value in the params for check and the
#pod time spent checking will be returned in the results.
#pod
#pod     my $result = HealthCheck::Diagnostic::Sample->check( runtime => 1 );
#pod
#pod =head1 DESCRIPTION
#pod
#pod A base class for writing Health Checks.
#pod Provides some helpers for validation of results returned from the check.
#pod
#pod This module does not require that an instance is created to run checks against.
#pod If your code requires an instance, you will need to verify that yourself.
#pod
#pod Results returned by these checks should correspond to the GSG
#pod L.
#pod
#pod Implementing a diagnostic should normally be done in L
#pod to allow use of the helper features that L provides.
#pod
#pod =head1 REQUIRED METHODS
#pod
#pod =head2 run
#pod
#pod     sub run {
#pod         my ( $class_or_self, %params ) = @_;
#pod         return { %params, status => 'OK' };
#pod     }
#pod
#pod A subclass must either implement a C method,
#pod which will be called by L
#pod have its return value passed through L,
#pod or override C and handle all validation itself.
#pod
#pod See the L method documentation for suggestions on when it
#pod might be overridden.
#pod
#pod =head1 METHODS
#pod
#pod =head2 new
#pod
#pod     my $diagnostic
#pod         = HealthCheck::Diagnostic::Sample->new( id => 'my_diagnostic' );
#pod
#pod =head3 ATTRIBUTES
#pod
#pod Attributes set on the object created will be copied into the result
#pod by L, without overriding anything already set in the result.
#pod
#pod =over
#pod
#pod =item collapse_single_result
#pod
#pod If truthy, will collapse a single sub-result into the current result,
#pod with the child result overwriting the values from the parent.
#pod
#pod For example:
#pod
#pod     {   id      => "my_id",
#pod         label   => "My Label",
#pod         results => [ {
#pod             label  => "Sub Label",
#pod             status => "OK",
#pod         } ]
#pod     }
#pod
#pod Collapses to:
#pod
#pod     {   id     => "my_id",
#pod         label  => "Sub Label",
#pod         status => "OK",
#pod     }
#pod
#pod
#pod =item tags
#pod
#pod An arrayref used as the default set of tags for any checks that don't
#pod override them.
#pod
#pod =back
#pod
#pod Any other parameters are included in the "Result" hashref returned.
#pod
#pod Some recommended things to include are:
#pod
#pod =over
#pod
#pod =item id
#pod
#pod The unique id for this check.
#pod
#pod =item label
#pod
#pod A human readable name for this check.
#pod
#pod =back
#pod
#pod =cut

sub new {
    my ($class, @params) = @_;

    # Allow either a hashref or even-sized list of params
    my %params = @params == 1 && ( ref $params[0] || '' ) eq 'HASH'
        ? %{ $params[0] } : @params;

    bless \%params, $class;
}

#pod =head2 collapse_single_result
#pod
#pod Read only accessor for the C attribute.
#pod
#pod =cut

sub collapse_single_result {
    return unless ref $_[0]; return shift->{collapse_single_result};
}

#pod =head2 tags
#pod
#pod Read only accessor that returns the list of tags registered with this object.
#pod
#pod =cut

sub tags { return unless ref $_[0]; @{ shift->{tags} || [] } }

#pod =head2 id
#pod
#pod Read only accessor that returns the id registered with this object.
#pod
#pod =cut

sub id { return unless ref $_[0]; return shift->{id} }

#pod =head2 label
#pod
#pod Read only accessor that returns the label registered with this object.
#pod
#pod =cut

sub label { return unless ref $_[0]; return shift->{label} }

#pod =head2 check
#pod
#pod     my %results = %{ $diagnostic->check(%params) }
#pod
#pod This method is what is normally called by the L runner,
#pod but this version expects you to implement a L method for the
#pod body of your diagnostic.
#pod This thin wrapper
#pod makes sure C<%params> is an even-sided list (possibly unpacking a hashref)
#pod before passing it to L,
#pod trapping any exceptions,
#pod and passing the return value through L unless a falsy
#pod C parameter is passed.
#pod
#pod This could be used to validate parameters or to modify the the return value
#pod in some way.
#pod
#pod     sub check {
#pod         my ( $self, @params ) = @_;
#pod
#pod         # Require check as an instance method
#pod         croak("check cannot be called as a class method") unless ref $self;
#pod
#pod         # Allow either a hashref or even-sized list of params
#pod         my %params = @params == 1 && ( ref $params[0] || '' ) eq 'HASH'
#pod             ? %{ $params[0] } : @params;
#pod
#pod         # Validate any required parameters and that they look right.
#pod         my $required_param = $params{required} || $self->{required};
#pod         return {
#pod             status => 'UNKNOWN',
#pod             info   => 'The "required" parameter is required',
#pod         } unless $required_param and ref $required_param == 'HASH';
#pod
#pod         # Calls $self->run and then passes the result through $self->summarize
#pod         my $res = $self->SUPER::check( %params, required => $required_param );
#pod
#pod         # Modify the result after it has been summarized
#pod         delete $res->{required};
#pod
#pod         # and return it
#pod         return $res;
#pod     }
#pod
#pod =cut

sub check {
    my ( $class_or_self, @params ) = @_;

    # Allow either a hashref or even-sized list of params
    my %params = @params == 1 && ( ref $params[0] || '' ) eq 'HASH'
        ? %{ $params[0] } : @params;

    my $class = ref $class_or_self || $class_or_self;
    croak("$class does not implement a 'run' method")
        unless $class_or_self->can('run');

    my $summarize
        = exists $params{summarize_result}
        ? $params{summarize_result}
        : 1;

    local $@;
    my $start = $params{runtime} ? [ gettimeofday ] : undef;
    my @res = eval { local $SIG{__DIE__}; $class_or_self->run(%params) };
    @res = { status => 'CRITICAL', info => "$@" } if $@;

    if ( @res == 1 && ( ref $res[0] || '' ) eq 'HASH' ) { }    # noop, OK
    elsif ( @res % 2 == 0 ) { @res = {@res}; }
    else {
        carp("Invalid return from $class\->run (@res)");
        @res = { status => 'UNKNOWN' };
    }

    $res[0]->{runtime} = sprintf "%.03f", tv_interval($start) if $start;

    return $res[0] unless $summarize;
    return $class_or_self->summarize(@res);
}

#pod =head2 summarize
#pod
#pod     %result = %{ $diagnostic->summarize( \%result ) };
#pod
#pod Validates, pre-formats, and returns the C so that it is easily
#pod usable by HealthCheck.
#pod
#pod The attributes C, C, and C
#pod get copied from the C<$diagnostic> into the C
#pod if they exist in the former and not in the latter.
#pod
#pod The C and C are summarized when we have multiple
#pod C in the C. All of the C values get appended
#pod together. One C value is selected from the list of C
#pod values.
#pod
#pod Used by L.
#pod
#pod Carps a warning if validation fails on several keys, and sets the
#pod C from C to C.
#pod
#pod =over
#pod
#pod =item status
#pod
#pod Expects it to be one of C, C, C, or C.
#pod
#pod Also carps if it does not exist.
#pod
#pod =item results
#pod
#pod Complains if it is not an arrayref.
#pod
#pod =item id
#pod
#pod Complains if the id contains anything but
#pod lowercase ascii letters, numbers, and underscores.
#pod
#pod =item timestamp
#pod
#pod Expected to look like an
#pod L
#pod which is a more strict subset of an ISO8601 timestamp.
#pod
#pod =back
#pod
#pod Modifies the passed in hashref in-place.
#pod
#pod =cut

sub summarize {
    my ( $self, $result ) = @_;

    $self->_set_default_fields($result, qw(id label tags));

    return $self->_summarize( $result, $result->{id} // 0 );
}

sub _set_default_fields {
    my ($self, $target, @fields) = @_;
    if ( ref $self ) {
        $target->{$_} = $self->{$_}
            for grep { not exists $target->{$_} }
            grep     { exists $self->{$_} } @fields;
    }
}

sub _summarize {
    my ($self, $result, $id) = @_;

    # Indexes correspond to Nagios Plugin Return Codes
    # https://assets.nagios.com/downloads/nagioscore/docs/nagioscore/3/en/pluginapi.html
    state $forward = [ qw( OK WARNING CRITICAL UNKNOWN ) ];

    # The order of preference to inherit from a child. The highest priority
    # has the lowest number.
    state $statuses = { map { state $i = 1; $_ => $i++ } qw(
        CRITICAL
        WARNING
        UNKNOWN
        OK
    ) };

    my $status = uc( $result->{status} || '' );
    $status = '' unless exists $statuses->{$status};

    my @results;
    if ( exists $result->{results} ) {
        if ( ( ref $result->{results} || '' ) eq 'ARRAY' ) {
            @results = @{ $result->{results} };

            # Merge if there is only a single result.
            if ( @results == 1 and $self->collapse_single_result ) {
                my ($r) = @{ delete $result->{results} };
                %{$result} = ( %{$result}, %{$r} );

                # Now that we've merged, need to redo everything again
                return $self->_summarize($result, $id);
            }
        }
        else {
            my $disp
                = defined $result->{results}
                ? "invalid results '$result->{results}'"
                : 'undefined results';
            carp("Result $id has $disp");
        }
    }

    my %seen_ids;
    foreach my $i ( 0 .. $#results ) {
        my $r = $results[$i];
        $self->_summarize( $r, "$id-" . ( $r->{id} // $i ) );

        # If this result has an ID we have seen already, append a number
        if ( exists $r->{id} and my $i = $seen_ids{ $r->{id} // '' }++ ) {
            $r->{id} .= defined $r->{id} && length $r->{id} ? "_$i" : $i;
        }

        if ( defined( my $s = $r->{status} ) ) {
            $s = uc $s;
            $s = $forward->[$s] if $s =~ /^[0-3]$/;

            $status = $s
                if exists $statuses->{$s}
                and $statuses->{$s} < ( $statuses->{$status} // 5 );
        }
    }

    # If we've found a valid status in our children,
    # use that if we don't have our own.
    # Removing the // here will force "worse" status inheritance
    $result->{status} //= $status if $status;

    my @errors;

    if ( exists $result->{id} ) {
        my $rid = $result->{id};
        unless ( defined $rid and $rid =~ /^[a-z0-9_]+$/ ) {
            push @errors, defined $rid ? "invalid id '$rid'" : 'undefined id';
        }
    }

    if ( exists $result->{timestamp} ) {
        my $ts = $result->{timestamp};
        unless ( defined $ts and $ts =~ /$rfc3339_timestamp/ ) {
            my $disp_timestamp
                = defined $ts
                ? "invalid timestamp '$ts'"
                : 'undefined timestamp';
            push @errors, "$disp_timestamp";
        }
    }

    if ( not exists $result->{status} ) {
        push @errors, "missing status";
    }
    elsif ( not defined $result->{status} ) {
        push @errors, "undefined status";
    }
    elsif ( not exists $statuses->{ uc( $result->{status} // '' ) } ) {
        push @errors, "invalid status '$result->{status}'";
    }

    $result->{status} = 'UNKNOWN'
        unless defined $result->{status} and length $result->{status};

    if (@errors) {
        carp("Result $id has $_") for @errors;
        $result->{status} = 'UNKNOWN'
            if $result->{status}
            and $statuses->{ $result->{status} }
            and $statuses->{UNKNOWN} < $statuses->{ $result->{status} };
        $result->{info} = join "\n", grep {$_} $result->{info}, @errors;
    }

    return $result;
}

1;

__END__