#!/usr/bin/env perl
# -*- Mode: CPerl;
# cperl-indent-level: 4;
# cperl-continued-statement-offset: 4;
# cperl-indent-parens-as-block: t;
# cperl-tabs-always-indent: t;
# cperl-indent-subs-specially: nil;
# -*-

# To make development easier.
use lib qw(lib);

use Kanla::Plugin;

# libanyevent-http-perl
use AnyEvent::HTTP;

# libanyevent-perl
use AnyEvent;
use AnyEvent::Socket;
use AnyEvent::DNS;

# This code is ripped out of AnyEvent::HTTP. We need to get the hostname from
# an URL to resolve it via IPv4 _and_ IPv6.
sub host_from_url {
    my ($url) = @_;

    my ($uscheme, $uauthority, $upath, $query, undef) =    # ignore fragment
        $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|;

    $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x or
        die "Unparsable URL";

    # TODO: error out in a way which the main process understands
    return lc $1;
}

my @urls;
if (!$conf->is_array('url')) {
    @urls = ($conf->value('url'));
} else {
    @urls = $conf->array('url');
}

my @body;
if ($conf->exists('body')) {
    if (!$conf->is_array('body')) {
        @body = ($conf->value('body'));
    } else {
        @body = $conf->array('body');
    }

    # Convert strings to regular expressions or coderefs, depending on
    # their content.
    for my $idx (0 .. @body - 1) {
        my $body = $body[$idx];
        if (my ($re) = ($body =~ m,^/(.*)/$,)) {
            $body[$idx] = [ $body, qr/$re/ ];
        } elsif ($body =~ /^sub/) {
            $body[$idx] = [ $body, eval $body ];
        } else {
            die "Invalid “body” value: $body";
        }
    }
}

my $timeout = ($conf->exists('timeout') ? $conf->value('timeout') : 10);

# Ensure timeout is an int and > 0.
$timeout += 0;
$timeout ||= 1;

sub verify_availability {
    my ($ip, $url) = @_;
    http_get(
        $url,
        # This timeout is for each individual stage,
        # e.g. for connecting,
        # for waiting for a response,
        # etc.
        # It is not a global timeout.
        timeout => $timeout,
        headers => {
            # TODO: configurable User-Agent
            'User-Agent' => 'kanla',
        },
        tcp_connect => sub {
            my (undef, $port, $connect_cb, $prepare_cb) = @_;

            # Wrap around tcp_connect,
            # replacing the host
            # with our resolved one.
            AnyEvent::Socket::tcp_connect($ip, $port, $connect_cb, $prepare_cb);
        },
        sub {
            my ($body, $hdr) = @_;

            # HTTP 4xx is Client Errors,
            # HTTP 5xx is Server Errors.
            if ($hdr->{Status} =~ /^[4-5]/) {
                signal_error(
                    'critical',
                    'HTTP reply ' . $hdr->{Status} . " for $url ($ip)"
                );
                return;
            }

            # Perform body checks, if any.
            if (@body > 0) {
                for my $elm (@body) {
                    my ($input, $check) = @$elm;
                    if (ref $check eq 'Regexp') {
                        if ($body !~ $check) {
                            signal_error(
                                'critical',
"HTTP body of $url ($ip) does not match regexp $input"
                            );
                        }
                    } else {
                        if (!$check->($body)) {
                            signal_error(
                                'critical',
"HTTP body of $url ($ip) does not match code $input"
                            );
                        }
                    }
                }
            }
        });
}

sub resolved {
    # family is either A or AAAA
    my $family   = shift;
    my $hostname = shift;
    my $url      = shift;
    if (@_ == 0) {
        signal_error(
            'critical',
            "Cannot resolve $family DNS record for $hostname"
        );
        return;
    }
    for my $ip (@_) {
        verify_availability($ip, $url);
    }
}

sub run {
    for my $url (@urls) {
        # XXX: We re-resolve all the time because it is assumed that you are
        # using a local caching nameserver, which is a good idea anyways and
        # allows us to correctly pick up new addresses once the old ones
        # expire.

        # Since AnyEvent::HTTP offers no way to specify whether we want to
        # access the website via IPv4 or IPv6, we need to resolve the hostname
        # on our own and specifically connect to the resolved IP address.
        my $host = host_from_url($url);
        if ($conf->obj('family')->value('ipv4')) {
            AnyEvent::DNS::a $host, sub { resolved('A', $host, $url, @_) };
        }
        if ($conf->obj('family')->value('ipv6')) {
            AnyEvent::DNS::aaaa $host,
                sub { resolved('AAAA', $host, $url, @_) };
        }
    }
}

# Run forever.
AnyEvent->condvar->recv;

# vim:ts=4:sw=4:expandtab
