File Coverage

blib/lib/HealthCheck.pm

Criterion	Covered	Total	%
statement	145	145	100.0
branch	74	80	92.5
condition	28	34	82.3
subroutine	20	20	100.0
pod	6	6	100.0
total	273	285	95.7

package HealthCheck;
use parent 'HealthCheck::Diagnostic';

# ABSTRACT: A health check for your code
use version;
our $VERSION = 'v1.9.2'; # VERSION

use 5.010;
use strict;
use warnings;

use Carp;

use Hash::Util::FieldHash;
use List::Util qw(any uniq);

# Create a place outside of $self to store the checks
# as everything in the self hashref will be copied into
# the result.
Hash::Util::FieldHash::fieldhash my %registered_checks;

#pod =head1 SYNOPSIS
#pod
#pod     use HealthCheck;
#pod
#pod     # a check can return a hashref containing anything at all,
#pod     # however some values are special.
#pod     # See the HealthCheck Standard for details.
#pod     sub my_check {
#pod         return {
#pod             anything => "at all",
#pod             id       => "my_check",
#pod             status   => 'WARNING',
#pod         };
#pod     }
#pod
#pod     my $checker = HealthCheck->new(
#pod         id      => 'main_checker',
#pod         label   => 'Main Health Check',
#pod         runbook => 'https://grantstreetgroup.github.io/HealthCheck.html',
#pod         tags    => [qw( fast cheap )],
#pod         checks  => [
#pod             sub { return { id => 'coderef', status => 'OK' } },
#pod             'my_check',          # Name of a method on caller
#pod         ],
#pod     );
#pod
#pod     my $other_checker = HealthCheck->new(
#pod         id      => 'my_health_check',
#pod         label   => "My Health Check",
#pod         runbook => 'https://grantstreetgroup.github.io/HealthCheck.html',
#pod         tags    => [qw( cheap easy )],
#pod         other   => "Other details to pass to the check call",
#pod     )->register(
#pod         'My::Checker',       # Name of a loaded class that ->can("check")
#pod         My::Checker->new,    # Object that ->can("check")
#pod     );
#pod
#pod     # It's possible to add ids, labels, and tags to your checks
#pod     # and they will be copied to the Result.
#pod     $other_checker->register( My::Checker->new(
#pod         id      => 'my_checker',
#pod         label   => 'My Checker',
#pod         runbook => 'https://grantstreetgroup.github.io/HealthCheck.html',
#pod         tags    => [qw( cheap copied_to_the_result )],
#pod     ) );
#pod
#pod     # You can add HealthCheck instances as checks
#pod     # You could add a check to itself to create an infinite loop of checks.
#pod     $checker->register( $other_checker );
#pod
#pod     # A hashref of the check config
#pod     # This whole hashref is passed as an argument
#pod     # to My::Checker->another_check
#pod     $checker->register( {
#pod         invocant    => 'My::Checker',      # to call the "check" on
#pod         check       => 'another_check',    # name of the check method
#pod         runbook     => 'https://grantstreetgroup.github.io/HealthCheck.html',
#pod         tags        => [qw( fast easy )],
#pod         more_params => 'anything',
#pod     } );
#pod
#pod     my @tags = $checker->tags;    # returns fast, cheap
#pod
#pod     my %result = %{ $checker->check( tags => ['cheap'] ) };
#pod        # OR run the opposite checks
#pod        %result = %{ $checker->check( tags => ['!cheap'] ) };
#pod
#pod     # A checker class or object just needs to have either
#pod     # a check method, which is used by default,
#pod     # or another method as specified in a hash config.
#pod     package My::Checker;
#pod
#pod     # Optionally subclass HealthCheck::Diagnostic
#pod     use parent 'HealthCheck::Diagnostic';
#pod
#pod     # and provide a 'run' method, the Diagnostic base class will
#pod     # pass your results through the 'summarize' helper that
#pod     # will add warnings about invalid values as well as
#pod     # summarizing multiple results.
#pod     sub run {
#pod         return {
#pod             id     => ( ref $_[0] ? "object_method" : "class_method" ),
#pod             status => "WARNING",
#pod         };
#pod     }
#pod
#pod     # Any checks *must* return a valid "Health Check Result" hashref.
#pod
#pod     # You can add your own check that doesn't call 'summarize'
#pod     # or, overload the 'check' helper in the parent class.
#pod     sub another_check {
#pod         my ($self, %params) = @_;
#pod         return {
#pod             id      => 'another_check',
#pod             label   => 'A Super custom check',
#pod             runbook => 'https://grantstreetgroup.github.io/HealthCheck.html',
#pod             status  => ( $params{more_params} eq 'fine' ? "OK" : "CRITICAL" ),
#pod         };
#pod     }
#pod
#pod C<%result> will be from the subset of checks run due to the tags.
#pod
#pod     $checker->check(tags => ['cheap']);
#pod
#pod     id      => "main_checker",
#pod     label   => "Main Health Check",
#pod     runbook => 'https://grantstreetgroup.github.io/HealthCheck.html',
#pod     tags    => [ "fast", "cheap" ],
#pod     status  => "WARNING",
#pod     results => [
#pod         {   id     => "coderef",
#pod             status => "OK",
#pod             tags   => [ "fast", "cheap" ]  # inherited
#pod         },
#pod         {   anything => "at all",
#pod             id       => "my_check",
#pod             status   => "WARNING",
#pod             tags     => [ "fast", "cheap" ] # inherited
#pod         },
#pod         {   id      => "my_health_check",
#pod             label   => "My Health Check",
#pod             tags    => [ "cheap", "easy" ],
#pod             status  => "WARNING",
#pod             results => [
#pod                 {   id     => "class_method",
#pod                     tags   => [ "cheap", "easy" ],
#pod                     status => "WARNING",
#pod                 },
#pod                 {   id     => "object_method",
#pod                     tags   => [ "cheap", "easy" ],
#pod                     status => "WARNING",
#pod                 },
#pod                 {   id     => "object_method_1",
#pod                     label  => "My Checker",
#pod                     tags   => [ "cheap", "copied_to_the_result" ],
#pod                     status => "WARNING",
#pod                 }
#pod             ],
#pod         }
#pod     ],
#pod
#pod There is also runtime support,
#pod which can be enabled by adding a truthy C param to the C.
#pod
#pod     $checker->check( tags => [ 'easy', '!fast' ], runtime => 1 );
#pod
#pod     id      => "my_health_check",
#pod     label   => "My Health Check",
#pod     runtime => "0.000",
#pod     runbook => 'https://grantstreetgroup.github.io/HealthCheck.html',
#pod     tags    => [ "cheap", "easy" ],
#pod     status  => "WARNING",
#pod     results => [
#pod         {   id      => "class_method",
#pod             runtime => "0.000",
#pod             tags    => [ "cheap", "easy" ],
#pod             status  => "WARNING",
#pod         },
#pod         {   id      => "object_method",
#pod             runtime => "0.000",
#pod             tags    => [ "cheap", "easy" ],
#pod             status  => "WARNING",
#pod         }
#pod     ],
#pod
#pod =head1 DESCRIPTION
#pod
#pod Allows you to create callbacks that check the health of your application
#pod and return a status result.
#pod
#pod There are several things this is trying to enable:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod A fast HTTP endpoint that can be used to verify that a web app can
#pod serve traffic.
#pod To this end, it may be useful to use the runtime support option,
#pod available in L.
#pod
#pod =item *
#pod A more complete check that verifies all the things work after a deployment.
#pod
#pod =item *
#pod
#pod The ability for a script, such as a cronjob, to verify that it's dependencies
#pod are available before starting work.
#pod
#pod =item *
#pod
#pod Different sorts of monitoring checks that are defined in your codebase.
#pod
#pod =back
#pod
#pod Results returned by these checks should correspond to the GSG
#pod L.
#pod
#pod You may want to use L to simplify writing your
#pod check slightly.
#pod
#pod =head1 METHODS
#pod
#pod =head2 new
#pod
#pod     my $checker = HealthCheck->new( id => 'my_checker' );
#pod
#pod =head3 ATTRIBUTES
#pod
#pod =over
#pod
#pod =item checks
#pod
#pod An arrayref that is passed to L to initialize checks.
#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 =item runbook
#pod
#pod A runbook link to help troubleshooting if the status is not OK.
#pod
#pod =back
#pod
#pod =cut

sub new {
    my ( $class, %params ) = @_;
    my $checks = delete $params{checks};
    my $self = bless {%params}, $class;
    return $checks ? $self->register($checks) : $self;
}

#pod =head2 register
#pod
#pod     $checker->register({
#pod         invocant => $class_or_object,
#pod         check    => $method_on_invocant_or_coderef,
#pod         more     => "any other params are passed to the check",
#pod     });
#pod
#pod Takes a list or arrayref of check definitions to be added to the object.
#pod
#pod Each registered check must return a valid GSG Health Check response,
#pod either as a hashref or an even-sized list.
#pod See the GSG Health Check Standard (linked in L)
#pod for the fields that checks should return.
#pod
#pod Rather than having to always pass in the full hashref definition,
#pod several common cases are detected and used to fill out the check.
#pod
#pod =over
#pod
#pod =item coderef
#pod
#pod If passed a coderef, this will be called as the C without an C.
#pod
#pod =item object
#pod
#pod If a blessed object is passed in
#pod and it has a C method, use that for the C,
#pod otherwise throw an exception.
#pod
#pod =item string
#pod
#pod If a string is passed in,
#pod check if it is the name of a loaded class that has a C method,
#pod and if so use it as the C with the method as the C.
#pod Otherwise if our L has a method with this name,
#pod the L becomes the C and this becomes the C,
#pod otherwise throws an exception.
#pod
#pod =item full hashref of params
#pod
#pod The full hashref can consist of a C key that the above heuristics
#pod are applied,
#pod or include an C key that is used as either
#pod an C or C.
#pod With the C specified, the now optional C key
#pod defaults to "check" and is used as the method to call on C.
#pod
#pod All attributes other than C and C are passed to the check.
#pod
#pod =back
#pod
#pod =cut

sub register {
    my ($self, @checks) = @_;
    croak("register cannot be called as a class method") unless ref $self;
    return $self unless @checks;
    my $class = ref $self;

    @checks = @{ $checks[0] }
        if @checks == 1 and ( ref $checks[0] || '' ) eq 'ARRAY';

    # If the check that was passed in is just the name of a method
    # we are going to use our caller as the invocant.
    my $caller;
    my $find_caller = sub {
        my ( $i, $c ) = ( 1, undef );
        do { ($c) = caller( $i++ ) } while $c->isa(__PACKAGE__);
        $c;
    };

    foreach (@checks) {
        my $type = ref $_ || '';
        my %c
            = $type eq 'HASH'  ? ( %{$_} )
            : $type eq 'ARRAY' ? ( check => $class->register($_) )
            :                    ( check => $_ );

        croak("check parameter required") unless $c{check};

        # If it's not a coderef,
        # it must be the name of a method to call on an invocant.
        unless ( ( ref $c{check} || '' ) eq 'CODE' ) {

            # If they passed in an object or a class that can('check')
            # then we want to set that as the invocant so the check
            # runner does the right thing.
            if ( $c{check} and not $c{invocant} and do {
                    local $@;
                    eval { $c{check}->can('check') };
                } )
            {
                $c{invocant} = $c{check};
                $c{check}    = 'check';
            }

            # If they just passed in a method name,
            # we can see if the caller has that method.
            unless ($c{invocant}) {
                $caller ||= $find_caller->();

                if ($caller->can($c{check}) ) {
                    $c{invocant} = $caller;
                }
                else {
                    croak("Can't determine what to do with '$c{check}'");
                }
            }

            croak("'$c{invocant}' cannot '$c{check}'")
                unless $c{invocant}->can( $c{check} );
        }

        push @{ $registered_checks{$self} }, \%c;
    }

    return $self;
}

#pod =head2 check
#pod
#pod     my %results = %{ $checker->check(%params) }
#pod
#pod Calls all of the registered checks and returns a hashref of the results of
#pod processing the checks passed through L.
#pod Passes the L as an even-sized list to the check,
#pod without the C or C keys.
#pod This hashref is shallow merged with and duplicate keys overridden by
#pod the C<%params> passed in.
#pod
#pod If there is both an C and C in the params,
#pod it the C is called as a method on the C,
#pod otherwise C is used as a callback coderef.
#pod
#pod If only a single check is registered,
#pod the results from that check are merged with, and will override
#pod the L set on the object instead of being put in
#pod a C arrayref.
#pod
#pod Throws an exception if no checks have been registered.
#pod
#pod =head3 run
#pod
#pod Main implementation of the checker is here.
#pod
#pod Passes C<< summarize_result => 0 >> to each registered check
#pod unless overridden to avoid running C multiple times.
#pod See L.
#pod
#pod =cut

sub check {
    my ( $self, @params ) = @_;
    croak("check cannot be called as a class method") unless ref $self;
    croak("No registered checks") unless @{ $registered_checks{$self} || [] };
    $self->SUPER::check(@params);
}

#pod =head2 get_registered_tags
#pod
#pod Read-only accessor that returns the list of 'top-level' tags registered with
#pod this object. Sub-check tags are not included - only those which will result in
#pod checks being run when passed to L on the given object.
#pod
#pod =cut

sub get_registered_tags {
    my ($self) = @_;

    my @checks = @{ $registered_checks{$self} || [] };
    my @tags;
    for my $check (@checks) {
        $self->_set_check_response_defaults($check);
        push @tags, @{ $check->{_respond}{tags} || [] };
    }
    push @tags, $self->tags;

    return uniq sort @tags;
}

sub run {
    my ($self, %params) = @_;

    # If we are going to summarize things, no need for our children to
    $params{summarize_result} = 0 unless exists $params{summarize_result};

    my @results = $self->_run_checks(
        [
            grep { $self->should_run( $_, %params ) }
            @{ $registered_checks{$self} || [] }
        ],
        \%params,
    );

    return unless @results; # don't return undef, instead an empty list
    return $results[0] if @{ $registered_checks{$self} || [] } == 1;
    return { results => \@results };
}

sub _run_checks {
    my ( $self, $checks, $params ) = @_;

    return map { $self->_run_check( $_, $params ) } @$checks;
}

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

    my %c = %{ $check };
    $self->_set_check_response_defaults(\%c);
    my $defaults = delete $c{_respond};
    my $i        = delete $c{invocant} || '';
    my $m        = delete $c{check}    || '';

    my @r;
    # Exceptions will probably not contain child health check's metadata,
    # as HealthCheck::Diagnostic->summarize would normally populate these
    # and was not called.
    # This could theoretically be a pain for prodsupport. If we find this
    # happening frequently, we should reassess our decision not to attempt
    # to call summarize here
    # (for fear of exception-catching magic and rabbitholes).
    {
        local $@;
        @r = eval { $i ? $i->$m( %c, %$params ) : $m->( %c, %$params ) };
        @r = { status => 'CRITICAL', info => $@ } if $@ and not @r;
    }

    @r
        = @r == 1 && ref $r[0] eq 'HASH' ? $r[0]
        : @r % 2 == 0                    ? {@r}
        : do {
            my $c = $i ? "$i->$m" : "$m";
            carp("Invalid return from $c (@r)");
            ();
        };

    if (@r) { @r = +{ %$defaults, %{ $r[0] } } }

    return @r;
}

sub _set_check_response_defaults {
    my ($self, $c) = @_;
    return if exists $c->{_respond};

    my %defaults;
    FIELD: for my $field ( qw(id label runbook tags) ) {
        if (exists $c->{$field}) {
            $defaults{$field} = $c->{$field};
            next FIELD;
        }

        if ( $c->{invocant} && $c->{invocant}->can($field) ) {
            my $val;
            if ( $field eq 'tags' ) {
                if (my @tags = $c->{invocant}->$field) {
                    $val = [@tags];
                }
            }
            else {
                $val = $c->{invocant}->$field;
            }

            if (defined $val) {
                $defaults{$field} = $val;
                next FIELD;
            }
        }

        # we only copy tags from the checker to the sub-checks,
        # and only if they don't exist.
        $self->_set_default_fields(\%defaults, $field)
            if $field eq 'tags';
    }

    # deref the tags, just in case someone decides to adjust them later.
    $defaults{tags} = [ @{ $defaults{tags} } ] if $defaults{tags};

    $c->{_respond} = \%defaults;
}


#pod =head1 INTERNALS
#pod
#pod These methods may be useful for subclassing,
#pod but are not intended for general use.
#pod
#pod =head2 should_run
#pod
#pod     my $bool = $checker->should_run( \%check, tags => ['apple', '!banana'] );
#pod
#pod Takes a check definition hash and paramters and returns true
#pod if the check should be run.
#pod Used by L to determine which checks to run.
#pod
#pod Supported parameters:
#pod
#pod =over
#pod
#pod =item tags
#pod
#pod Tags can be either "positive" or "negative". A negative tag is indicated by a
#pod leading C.
#pod A check is run if its tags match any of the passed in positive tags and none
#pod of the negative ones.
#pod If no tags are passed in, all checks will be run.
#pod
#pod If the C C and there are no tags in the
#pod L then the return value of that method is used.
#pod
#pod If a check has no tags defined, will use the default tags defined
#pod when the object was created.
#pod
#pod =back
#pod
#pod =cut

sub _has_tags {
    my ($self, $check, @want_tags) = @_;

    $self->_set_check_response_defaults($check);

    # Look at what the check responds to, not what was initially specified
    # (in case tags are inherited)
    my %have_tags = map { $_ => 1 } @{ $check->{_respond}{tags} || [] };

    return any { $have_tags{$_} } @want_tags;
}

sub should_run {
    my ( $self, $check, %params ) = @_;

    my (@positive_tags, @negative_tags);
    for my $tag ( @{ $params{tags} } ) {
        if ( $tag =~ /^!/ ) {
            push @negative_tags, substr($tag, 1);
        }
        else {
            push @positive_tags, $tag;
        }
    }

    return 0 if @negative_tags && $self->_has_tags($check, @negative_tags);
    return 1 unless @positive_tags;
    return $self->_has_tags($check, @positive_tags);
}

1;

__END__