#!/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;

# core
use MIME::Base64;
use Socket qw(SOCK_STREAM);

# The regexes are ripped out of AnyEvent::HTTP.
# They were modified to extract username and password.
# It returns the hostname,
# if present, username:password or an empty string otherwise,
# a clean version of the given URL for errror reports and logging.
sub parse_url {
    my ($url) = @_;

    my ($uscheme, $uauthority, $upath, $query, $fragment) = $url =~ m|^
            ([^:]+):       # scheme
            (?://          # // is used in http
                ([^/?\#]*) # user, pass, hostname, port
            )?
            ([^?\#]*)      # path
            (\?[^\#]*)?    # query
            (\#.*)?        # fragment
            $|x;

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

    $query    //= '';
    $fragment //= '';
    $port     //= '';

    my $clean_url =
        $uscheme . '://' . $hostname . $port . $upath . $query . $fragment;

    # TODO: error out in a way which the main process understands
    return ($hostname, $user_pass, $clean_url);
}

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) = @_;
    my (undef, $user_pass, $clean_url) = parse_url($url);

    $user_pass = 'Basic ' . encode_base64($user_pass) if defined($user_pass);

    http_get(
        $clean_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',
            'Authorization' => $user_pass,
        },
        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 $clean_url ($ip)",
                    [ 'http', $url, $ip, $hdr->{Status} ]);
                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 $clean_url ($ip) does not match regexp $input",
                                [ 'http', $url, $ip, 'body' ]);
                        }
                    } else {
                        if (!$check->($body)) {
                            signal_error(
                                'critical',
"HTTP body of $clean_url ($ip) does not match code $input",
                                [ 'http', $url, $ip, 'body' ]);
                        }
                    }
                }
            }
        });
}

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",
            [ 'http', $url, 'dns' ]);
        return;
    }
    for my $record (@_) {
        my ($service, $host) =
            AnyEvent::Socket::unpack_sockaddr($record->[3]);
        verify_availability(format_address($host), $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) = parse_url($url);
        if ($conf->obj('family')->value('ipv4')) {
            AnyEvent::Socket::resolve_sockaddr(
                $host, "http", "tcp", 4, SOCK_STREAM,
                sub { resolved('A', $host, $url, @_) });
        }
        if ($conf->obj('family')->value('ipv6')) {
            AnyEvent::Socket::resolve_sockaddr(
                $host, "http", "tcp", 6, SOCK_STREAM,
                sub { resolved('AAAA', $host, $url, @_) });
        }
    }
}

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

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