The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
package Ubic::Ping;
{
  $Ubic::Ping::VERSION = '1.49';
}

use strict;
use warnings;

# ABSTRACT: http server which returns service status by it's name or port

use Ubic;
use Ubic::PortMap;
use Params::Validate qw(:all);
use Try::Tiny;

use parent qw(HTTP::Server::Simple::CGI);

sub _print_status($;$) {
    my ($name, $options) = validate_pos(@_, 1, { type => HASHREF, default => {} });

    unless (Ubic->is_enabled($name)) {
        if ($options->{noc}) {
            print "HTTP/1.0 500 Disabled\r\n\r\n";
        }
        else {
            print "HTTP/1.0 200 OK\r\n\r\n";
        }
        print "disabled\n";
        return;
    }
    my $status = Ubic->cached_status($name)->status; # should read status from static file on disk
    if ($status eq 'running') {
        print "HTTP/1.0 200 OK\r\n\r\n";
        print "ok\n";
        return;
    }
    else {
        if ($options->{noc}) {
            if ($status =~ /^[\w ]+$/) {
                print "HTTP/1.0 500 $status\r\n\r\n";
            }
            else {
                # invalid status, fallback to default status message
                print "HTTP/1.0 500 Wrong status\r\n\r\n";
            }
        }
        else {
            print "HTTP/1.0 200 OK\r\n\r\n";
        }
        print "$status\n";
        return;
    }
}

sub handle_request {
    my ($self, $cgi) = @_;

    try {
        if ($cgi->path_info eq '/ping') {
            # ping self
            print "HTTP/1.0 200 OK\r\n\r\n";
            print "ok\n";
            return;
        }
        elsif ( $cgi->path_info =~ m{^/noc/(\d+)/?$}) {
            my $port = $1;
            my $name = Ubic::PortMap::port2name($port);
            unless (defined $name) {
                print "HTTP/1.0 404 Not found\r\n\r\n";
                print "Service at port '$port' not found\n";
                return;
            }
            _print_status($name, { noc => 1 });
            return;
        }
        elsif ($cgi->path_info =~ m{^/status/port/(\d+)/?$}) {
            my $port = $1;
            my $name = Ubic::PortMap::port2name($port);
            unless (defined $name) {
                print "HTTP/1.0 404 Not found\r\n\r\n";
                print "Service at port '$port' not found\n";
                return;
            }
            _print_status($name);
            return;
        }
        elsif (my ($name) = $cgi->path_info =~ m{^/status/service/(.+?)/?$}) {
            unless (Ubic->has_service($name)) {
                print "HTTP/1.0 404 Not found\r\n\r\n";
                print "Service with name '$name' not found\n";
                return;
            }
            _print_status($name);
        }
        else {
            print "HTTP/1.0 404 Not found\r\n\r\n";
            print "Expected /status/service/NAME or /status/port/PORT query\n";
            return;
        }
    }
    catch {
        print "HTTP/1.0 500 Internal error\r\n\r\n";
        print "Error: $_";
    };
}

1;

__END__

=pod

=head1 NAME

Ubic::Ping - http server which returns service status by it's name or port

=head1 VERSION

version 1.49

=head1 AUTHOR

Vyacheslav Matyukhin <mmcleric@yandex-team.ru>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Yandex LLC.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut