File Coverage

blib/lib/Net/Prober/Probe/HTTP.pm

Criterion	Covered	Total	%
statement	81	94	86.1
branch	25	46	54.3
condition	15	32	46.8
subroutine	10	10	100.0
pod	0	3	0.0
total	131	185	70.8

package Net::Prober::Probe::HTTP;
{
  $Net::Prober::Probe::HTTP::VERSION = '0.15';
}

use strict;
use warnings;

use base 'Net::Prober::Probe::TCP';

use Carp ();
use Digest::MD5 ();
use LWPx::ParanoidAgent ();

sub defaults {
    my ($self) = @_;
    my $defaults = $self->SUPER::defaults;

    my %http_defaults = (
        %{ $defaults },
        headers      => undef,
        md5          => undef,
        method       => 'GET',
        port         => 80,
        scheme       => 'http',
        url          => '/',
        match        => undef,
        body         => undef,
        up_status_re => '^[23]\d\d$',
    );

    return \%http_defaults;
}

sub agent {

    my $ua = LWPx::ParanoidAgent->new();
    my $ver = $Net::Prober::VERSION || 'dev';
    $ua->agent("Net::Prober/$ver");
    $ua->max_redirect(0);

    return $ua;
}

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

    my ($host, $port, $timeout, $scheme, $url, $method, $body, $headers) =
        $self->parse_args($args, qw(host port timeout scheme url method body headers));

    $method ||= "GET";

    if (defined $scheme) {
        if ($scheme eq 'http') {
            $port ||= 80;
        }
        elsif ($scheme eq 'https') {
            $port ||= 443;
        }
    }

    if (defined $port) {
        $scheme = $port == 443 ? "https" : "http";
    }

    $url =~ s{^/+}{};

    # We don't want to add :80 or :443 because some pesky Asian CDN
    # doesn't like when Host header contains those default ports
    my $probe_url = "$scheme://$host/$url";
    if ($port != 80 && $port != 443) {
        $probe_url = "$scheme://$host:$port/$url";
    }

    my @req_args = ($method, $probe_url);

    if ($headers && ref $headers eq "ARRAY") {
        my $req_headers = HTTP::Headers->new();
        $req_headers->header(@{ $headers });
        push @req_args, $req_headers;
    }

    if ($body) {
        push @req_args, $body;
    }

    return HTTP::Request->new(@req_args);
}

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

    my ($expected_md5, $content_match, $up_status_re, $timeout) =
        $self->parse_args($args, qw(md5 match up_status_re timeout));

    $self->time_now();

    my $ua = $self->agent();

    if (defined $timeout && $timeout > 0) {
        $ua->timeout($timeout);
    }

    my $req = $self->_prepare_request($args);

    # Fire in the hole!
    my $resp = $ua->request($req);

    my $elapsed = $self->time_elapsed();
    my $content = $resp->content();
    my $status = $resp->code();

    my $good = 0;
    my $reason;

    if (! $up_status_re || ! defined $status || ! $status) {
        $good = $resp->is_redirect() || $resp->is_success();
        if (! $good) {
            $reason = "Response HTTP status code wasn't successful (2xx or 3xx)";
        }
    }
    elsif ($up_status_re && defined $status) {
        my $match_re;
        eval {
            $match_re = qr{$up_status_re}ms;
        } or do {
            Carp::croak("Invalid regex for HTTP status match '$up_status_re'\n");
        };
        $good = $status =~ $match_re;
        if (! $good) {
            $reason = "Response HTTP status code didn't match the specified regex ('$up_status_re')";
        }
    }

    if ($good and defined $expected_md5) {
        my $md5 = Digest::MD5::md5_hex($content);
        if ($md5 ne $expected_md5) {
            $good = 0;
            $reason = "Response body MD5 sum wasn't the expected ($expected_md5)";
        }
    }

    if ($good and defined $content_match) {
        my $match_re;
        eval {
            $match_re = qr{$content_match}ms;
        } or do {
            Carp::croak("Invalid regex for http content match '$content_match'\n");
        };
        if ($content !~ $match_re) {
            $good = 0;
            $reason = "Content didn't match the specified '$content_match' regex";
        }
    }

    my %status = (
        status => $resp->status_line,
        content => $content,
        elapsed => $elapsed,
    );

    my $md5 = $content
        ? Digest::MD5::md5_hex($content)
        : undef;

    $status{md5} = $md5 if $md5;
    $status{reason} = $reason if defined $reason;

    if ($good) {
        return $self->probe_ok(%status);
    }

    return $self->probe_failed(%status);
}

1;

__END__