File Coverage

lib/ControlFreak.pm

Criterion	Covered	Total	%
statement	108	278	38.8
branch	19	60	31.6
condition	8	57	14.0
subroutine	24	67	35.8
pod	19	35	54.2
total	178	497	35.8

package ControlFreak;

use strict;
use 5.008_001;
our $VERSION = '1.0.0'; ## http://semver.org

use Object::Tiny qw{
    log
    console
    home
};

use Carp;
use ControlFreak::Command;
use ControlFreak::Logger;
use ControlFreak::Service;
use ControlFreak::Proxy;
use File::Spec();
use Params::Util qw{ _ARRAY _CODE };

our $CRLF = "\015\012";

=encoding utf8

=head1 NAME

ControlFreak - a process supervisor

=head1 SYNOPSIS

    ## WARNING
    ## see L and L manpages for how to run ControlFreak from
    ## the shell. This is the programatic interface used by these scripts.

    $ctrl = ControlFreak->new(
        log_config_file => $log_config_file,
    );
    $ctrl->run; # enter the event loop, returns only for exiting

    ## elsewhere in the eventloop
    $ctrl->add_socket($sock);
    $sock = $ctrl->socket($sockname);

    $svc = $ctrl->find_or_create($svcname);
    $ctrl->add_service($svc);
    $svc = $ctrl->service($svcname);

    @svcs = $ctrl->service_by_tag($tag);
    @svcs = $ctrl->services;

    $ctrl->destroy($svcname);

    $ctrl->set_console($con);
    $con = $ctrl->console;
    $log = $ctrl->log;

=head1 DESCRIPTION

This is the programmer documentation. Look into L
for user documentation.

=head1 METHODS

=head2 new(%param)

=over 4

=item * config

The absolute path to a initial config file.

=back

=cut

sub new {
    my $class = shift;
    my %param = @_;
    my $ctrl = $class->SUPER::new(%param);

    my $base = $ctrl->{base} = $param{base};

    $ctrl->{servicemap} = {};
    $ctrl->{socketmap}  = {};
    $ctrl->{proxymap}   = {};

    my $log_config_file;
    my $home = $param{home};
    $log_config_file = File::Spec->rel2abs($param{log_config_file}, $home)
        if defined $param{log_config_file} && $home;

    $ctrl->{log} = ControlFreak::Logger->new(
        config_file => $log_config_file,
    );

    return $ctrl;
}

=head2 services

Returns a list of L instances known to this
controller.

=cut

sub services {
    my $ctrl = shift;
    return values %{ $ctrl->{servicemap} };
}

=head2 sockets

Returns a list of L instances known to this
controller.

=cut

sub sockets {
    my $ctrl = shift;
    return values %{ $ctrl->{socketmap} };
}

=head2 service($name)

Returns the service of name C<$name> or nothing.

=cut

sub service {
    my $ctrl = shift;
    my ($svcname) = shift or return;
    return $ctrl->{servicemap}{$svcname};
}

=head2 proxy($name)

Returns the proxy of name C<$name> or nothing.

=cut

sub proxy {
    my $ctrl = shift;
    my ($proxyname) = shift or return;
    return $ctrl->{proxymap}{$proxyname};
}

=head2 set_console

Takes a L instance in parameter and sets it
as the console.

=cut

sub set_console {
    my $ctrl = shift;
    my $con = shift;

    $ctrl->{console} = $con;
    return;
}

=head2 socket($name)

Returns the L object of name C<$name> or returns
undef.

=cut

sub socket {
    my $ctrl = shift;
    my $name = shift || "";
    return $ctrl->{socketmap}->{$name};
}

=head2 add_socket($socket)

Adds the C<$socket> L object passed in parameters
to the list of socket this controller knows about.

If a socket by that name already exists, it returns undef, otherwise
it returns a true value;

=cut

sub add_socket {
    my $ctrl = shift;
    my $socket = shift;

    my $name = $socket->name || "";
    return if $ctrl->{socketmap}->{$name};
    $ctrl->{socketmap}->{$name} = $socket;
    return 1;
}

=head2 remove_socket($socket_name)

Removes the L object by the name of C<$socket_name>
from the list of sockets this controller knows about.

Returns true if effectively removed.

=cut

sub remove_socket {
    my $ctrl = shift;
    my $socket_name = shift;
    return delete $ctrl->{socketmap}->{$socket_name};
}

=head2 add_proxy($proxy)

Adds the C<$proxy> L object passed in parameters
to the list of proxies this controller knows about.

If a proxy by that name already exists, it returns undef, otherwise
it returns a true value;

=cut

sub add_proxy {
    my $ctrl = shift;
    my $proxy = shift;

    my $name = $proxy->name || "";
    return if $ctrl->{proxymap}->{$name};
    $ctrl->{proxymap}->{$name} = $proxy;
    return 1;
}

=head2 remove_proxy($proxy_name)

Removes the L object by the name of C<$proxy_name>
from the list of proxies this controller knows about.

Returns true if effectively removed.

=cut

sub remove_proxy {
    my $ctrl = shift;
    my $proxy_name = shift;
    return delete $ctrl->{proxymap}->{$proxy_name};
}

=head2 proxies

Returns a list of proxy objects.

=cut

sub proxies {
    my $ctrl = shift;
    return values %{ $ctrl->{proxymap} };
}

=head2 find_or_create_svc($name)

Given a service name in parameter (a string), searches for an existing
defined service with that name, if not found, then a new service is
declared and returned.

=cut

sub find_or_create_svc {
    my $ctrl = shift;
    my $svcname = shift;
    my $svc = $ctrl->{servicemap}{$svcname};
    return $svc if $svc;

    $svc = ControlFreak::Service->new(
        name  => $svcname,
        state => 'stopped',
        ctrl  => $ctrl,
    );
    return unless $svc;

    return $ctrl->{servicemap}{$svcname} = $svc;
}

=head2 find_or_create_sock($name)

Given a socket name in parameter (a string), searches for an existing
defined socket with that name, if not found, then a new socket is
declared and returned.

=cut

sub find_or_create_sock {
    my $ctrl = shift;
    my $sockname = shift;
    my $sock = $ctrl->{socketmap}{$sockname};
    return $sock if $sock;

    $sock = ControlFreak::Socket->new(
        name  => $sockname,
        ctrl  => $ctrl,
    );
    return unless $sock;

    return $ctrl->{socketmap}{$sockname} = $sock;
}

=head2 find_or_create_proxy($name)

Given a proxy name in parameter (a string), searches for an existing
defined proxy with that name, if not found, then a new proxy is
declared and returned.

=cut

sub find_or_create_proxy {
    my $ctrl = shift;
    my $proxyname = shift;
    my $proxy = $ctrl->{proxymap}{$proxyname};
    return $proxy if $proxy;

    $proxy = ControlFreak::Proxy->new(
        name  => $proxyname,
        ctrl  => $ctrl,
    );
    return unless $proxy;

    return $ctrl->{proxymap}{$proxyname} = $proxy;
}

=head2 logger

Returns the logger attached to the controller.

=cut

=head2 services_by_tag($tag)

Given a tag in parameter, returns a list of matching service objects.

=cut

sub services_by_tag {
    my $ctrl = shift;
    my $tag = shift;
    return grep { $_->tags->{$tag} } $ctrl->services;
}

=head2 services_from_args(%param)

Given a list of arguments (typically from the console commands)
returns a list of L instances.

=over 4

=item * args

The list of arguments to analyze.

=item * err

A callback called with the parsing errors of the arguments.

=back

=cut

sub services_from_args {
    my $ctrl = shift;
    my %param = @_;

    my $err  = _CODE($param{err_cb}) || sub {};
    my $args = _ARRAY($param{args})
        or return ();

    my $selector = shift @$args;
    if ($selector eq 'service') {
        unless (scalar @$args == 1) {
            $err->('service selector takes exactly 1 argument: name');
            return ();
        }
        my $name = shift @$args;
        my $svc = $ctrl->service($name);
        return $svc ? ($svc) : ();
    }
    elsif ($selector eq 'tag') {
        return $ctrl->services_by_tag(shift @$args);
    }
    elsif ($selector eq 'all') {
        return $ctrl->services;
    }
    else {
        $err->("unknown selector '$selector'");
    }
    return ();
}


=head2 command_*

All accessible commands to the config and the console.

=cut

sub command_start   { _command_ctrl('start',   @_ ) }
sub command_stop    { _command_ctrl('stop',    @_ ) }
sub command_restart { _command_ctrl('restart', @_ ) }
sub command_down    { _command_ctrl('down',    @_ ) }
sub command_up      { _command_ctrl('up',      @_ ) }

sub _command_ctrl {
    my $meth = shift;
    my $ctrl = shift;
    my %param = @_;

    my $err  = _CODE($param{err_cb}) || sub {};
    my $ok   = _CODE($param{ok_cb})  || sub {};
    my @svcs = $ctrl->services_from_args(
        %param, err_cb => $err, ok_cb => $ok,
    );
    if (! @svcs) {
        return $err->("Couldn't find a valid service. bailing.");
    }
    my $n = 0;
    for (@svcs) {
        $_->$meth(err_cb => $err, ok_cb => sub { $n++ });
    }
    $ok->("done $n");
    return;
}

## for now, at least this is separated.
## but could we imagine a command start all running proxies as well?
sub command_proxyup {
    my $ctrl = shift;
    my %param = @_;

    my $err  = _CODE($param{err_cb}) || sub {};
    my $ok   = _CODE($param{ok_cb})  || sub {};

    my $proxyname = $param{args}[0];

    my $proxy = $ctrl->proxy($proxyname || "");
    if (! $proxy) {
        return $err->("Couldn't find a valid proxy. bailing.");
    }
    $proxy->run;
    $ok->();
    return;
}

sub command_proxydown {
    my $ctrl = shift;
    my %param = @_;

    my $err  = _CODE($param{err_cb}) || sub {};
    my $ok   = _CODE($param{ok_cb})  || sub {};

    my $proxyname = $param{args}[0];

    my $proxy = $ctrl->proxy($proxyname || "");
    if (! $proxy) {
        return $err->("Couldn't find a valid proxy. bailing.");
    }
    $proxy->shutdown;
    $ok->();
    return;
}

sub command_list {
    my $ctrl = shift;
    my %param = @_;
    my $ok = _CODE($param{ok_cb}) || sub {};
    my @out = map { $_->name } $ctrl->services;
    $ok->(join "\n", @out);
}

sub command_desc {
    my $ctrl = shift;
    my %param = @_;

    my $ok = _CODE($param{ok_cb}) || sub {};

    my $args = $param{args} || [ 'all' ];
    $args = ['all'] unless @$args;

    my @svcs = $ctrl->services_from_args(
        %param, ok_cb => $ok,
    );
    my @out = map { $_->desc_as_text } @svcs;
    $ok->(join "\n", @out);
}

sub command_version {
    my $ctrl = shift;
    my %param = @_;
    my $ok = _CODE($param{ok_cb}) || sub {};
    $ok->($VERSION);
}

sub command_status {
    my $ctrl = shift;
    my %param = @_;

    my $ok   = _CODE($param{ok_cb}) || sub {};

    my $args = $param{args} || [ 'all' ];
    $args = ['all'] unless @$args;
    my @svcs = $ctrl->services_from_args(%param, args => $args);

    my @out;
    for (@svcs) {
        push @out, $_->status_as_text;
    }
    $ok->(join "\n", @out);
}

sub command_pids {
    my $ctrl = shift;
    my %param = @_;

    my $ok      = _CODE($param{ok_cb}) || sub {};

    my $args = $param{args} || [ 'all' ];
    $args = ['all'] unless @$args;
    my @svcs = $ctrl->services_from_args(%param, args => $args);
    my %seen;
    my @out;
    for (@svcs) {
        my $svcname = $_->name;
        next if $seen{$svcname}++;
        my @pids = ($_->pid);
        if (my $proxy = $_->proxy) {
            my $ppid = $proxy->pid;
            unshift @pids, $ppid if $ppid;
        }
        push @out, "$svcname: " . join (", ", @pids);
    }
    $ok->(join "\n", @out);
}

sub command_proxystatus {
    my $ctrl = shift;
    my %param = @_;

    my $ok      = _CODE($param{ok_cb}) || sub {};
    my @proxies = $ctrl->proxies;
    my @out;
    for my $p ($ctrl->proxies) {
        push @out, $p->status_as_text;
    }
    $ok->(join "\n", @out);
}

sub command_bind {
    my $ctrl = shift;
    my %param = @_;
    my $args = $param{args} || [];
    my $err = _CODE($param{err_cb}) || sub {};
    my $ok  = _CODE($param{ok_cb})  || sub {};
    my $sockname = shift @$args || "";
    my $sock = $ctrl->socket($sockname);
    unless ($sock) {
        return $err->("unknown socket '$sockname'");
    }
    $sock->bind();
    $ok->();
    return;
}

sub command_shutdown {
    ## I'm tired of killing my procs.
    ## might not stay in the future
    my $ctrl = shift;
    $ctrl->shutdown;
    $ctrl->{exit_cv} = AE::timer 1, 0, sub { exit };
}

sub command_destroy {
    my $ctrl = shift;
    my %param = @_;

    my $err = _CODE($param{err_cb}) || sub {};
    my $ok  = _CODE($param{ok_cb})  || sub {};

    my @svcs = $ctrl->services_from_args(
        %param, err_cb => $err, ok_cb => $ok,
    );
    my %errors;
    for my $svc (@svcs) {
        my $svcname = $svc->name;
        $svc->down(
            on_stop => sub { $ctrl->destroy($svc) },
            err_cb => sub {
                $errors{$svcname}++;
            },
        );
    }
    if (keys %errors) {
        my $list = join ", ", keys %errors;
        $err->("Coudn't destroy: $list");
    }
    else {
        return $ok->()
    }
    return;
}

=head2 destroy($svc)

Removes any reference to $svc in the controller. The concerned
service must be down in the first place.

=cut

sub destroy {
    my $ctrl = shift;
    my $svc  = shift;
    my $svcname = $svc->name;
    return unless $svc->is_down;
    if ($svc->is_backoff) {
        $svc->stop;
    }
    $ctrl->log->info("Destroying service '$svcname'");
    return delete $ctrl->{servicemap}{$svcname};
}

=head2 shutdown

Cleanly exits all running commands, close all sockets etc...

=cut

sub shutdown {
    my $ctrl = shift;

    $_->down     for $ctrl->services;
    $_->shutdown for $ctrl->proxies;
    $_->unbind   for $ctrl->sockets;
}

=head1 AUTHOR

Yann Kerherve [e-mail]

=head1 LICENSE

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

=head1 SEE ALSO

I think the venerable (but hatred) daemontools is the ancestor of all
supervisor processes. In the same class there is also runit and monit.

More recent modules which inspired ControlFreak are God and Supervisord
in Python. Surprisingly I didn't find any similar program in Perl. Some
ideas in ControlFreak are subtely different though.

EDIT: I've spotted Ubic recently on CPAN

"If you have kids you probably know what I mean";