File Coverage

blib/lib/HealthCheck/Diagnostic/WebRequest.pm

Criterion	Covered	Total	%
statement	85	86	98.8
branch	34	42	80.9
condition	26	42	61.9
subroutine	13	13	100.0
pod	3	5	60.0
total	161	188	85.6

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

# ABSTRACT: Make HTTP/HTTPS requests to web servers to check connectivity
use version;
our $VERSION = 'v1.4.1'; # VERSION

use strict;
use warnings;

use Carp;
use LWP::UserAgent;
use HTTP::Request;
use Scalar::Util 'blessed';

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

    my %params = @params == 1 && ( ref $params[0] || '' ) eq 'HASH'
        ? %{ $params[0] } : @params;

    my @bad_params = grep {
        !/^(  content_regex
            | id
            | label
            | no_follow_redirects
            | options
            | request
            | status_code
            | status_code_eval
            | tags
            | timeout
            | url
        )$/x
    } keys %params;

    carp("Invalid parameter: " . join(", ", @bad_params)) if @bad_params;

    die "No url or HTTP::Request specified!" unless ($params{url} ||
        ($params{request} && blessed $params{request} &&
            $params{request}->isa('HTTP::Request')));
    die "The 'request' and 'url' options are mutually exclusive!"
        if $params{url} && $params{request};

    # Process and serialize the status code checker
    $params{status_code} ||= '200';
    my (@and, @or);
    foreach my $part (split qr{\s*,\s*}, $params{status_code}) {
        # Strict validation of each part, since we're throwing these into an eval
        my ($op, $code) = $part =~ m{\A\s*(>=|>|<=|<|!=|!)?\s*(\d{3})\z};

        die "The 'status_code' condition '$part' is not in the correct format!"
            unless defined $code;
        $op = '!=' if defined $op && $op eq '!';

        unless ($op) { push @or,  '$_ == '.$code;    }
        else         { push @and, '$_ '."$op $code"; }
    }
    push @or, '('.join(' && ', @and).')' if @and;  # merge @and as one big condition into @or
    $params{status_code_eval} = join ' || ', @or;

    $params{request}        //= HTTP::Request->new('GET', $params{url});
    $params{options}        //= {};
    $params{options}{agent} //= LWP::UserAgent->_agent .
        " HealthCheck-Diagnostic-WebRequest/" . ( $class->VERSION || '0' );
    $params{options}{timeout} //= 7;    # Decided by committee

    return $class->SUPER::new(
        label => 'web_request',
        %params,
    );
}

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

    croak("check cannot be called as a class method")
        unless ref $self;
    return $self->SUPER::check(@args);
}

sub run {
    my ( $self, %params ) = @_;
    my $ua = LWP::UserAgent->new( %{$self->{options}} );

    $ua->requests_redirectable([]) if $self->{'no_follow_redirects'};

    my $response = $ua->request( $self->{request} );

    my @results = $self->check_status( $response );
    push @results, $self->check_content( $response )
        if $results[0]->{status} eq 'OK';

    my $info = join '; ', map { $_->{info} } @results;

    return { info => $info, results => \@results };
}

sub check_status {
    my ( $self, $response ) = @_;
    my $status;

    my $client_warning = $response->header('Client-Warning') // '';
    my $proxy_error    = $response->header('X-Squid-Error')  // '';

    # Eval the status checker
    my $success;
    {
        local $_ = $response->code;
        $success = eval $self->{status_code_eval};
    }

    # An unfortunate post-constructor die, but this would be a validation bug (ie: our fault)
    die "Status code checker eval '".$self->{status_code_eval}."' failed: $@" if $@;

    $status = $success ? 'OK' : 'CRITICAL';

    # Proxy error is an automatic failure
    $status = 'CRITICAL' if $proxy_error;

    my $info  = sprintf( "Requested %s and got%s status code %s",
        $self->{request}->uri,
        $status eq 'OK' ? ' expected' : '',
        $response->code,
    );
    $info .= " from proxy with error '$proxy_error'" if $proxy_error;
    $info .= ", expected ".$self->{status_code}      unless $status eq 'OK' || $proxy_error;

    # If LWP returned 'Internal response', the status code doesn't actually mean anything
    if ($client_warning && $client_warning eq 'Internal response') {
        $status = 'CRITICAL';
        $info   = "User Agent returned: ".$response->message;
    }

    return { status => $status, info => $info };
}

sub check_content {
    my ( $self, $response ) = @_;

    return unless $self->{content_regex};

    my $regex      = $self->{content_regex};
    my $content    = $response->content;
    my $status     = $content =~ /$regex/ ? 'OK' : 'CRITICAL';
    my $successful = $status eq 'OK' ? 'matches' : 'does not match';

    return {
        status => $status,
        info   => "Response content $successful /$regex/",
    };
}

1;

__END__