lib/Ubic.pm - metacpan.org

package Ubic;
{
  $Ubic::VERSION = '1.44_01';
}

use strict;
use warnings;

# ABSTRACT: polymorphic service manager


use POSIX qw();
use Carp;
use IO::Handle;
use Storable qw(freeze thaw);
use Try::Tiny;
use Scalar::Util qw(blessed);
use Params::Validate qw(:all);

use Ubic::Result qw(result);
use Ubic::Multiservice::Dir;
use Ubic::AccessGuard;
use Ubic::Credentials;
use Ubic::Persistent;
use Ubic::AtomicFile;
use Ubic::SingletonLock;
use Ubic::Settings;

our $SINGLETON;

my $service_name_re = qr{^[\w-]+(?:\.[\w-]+)*$};
my $validate_service = { type => SCALAR, regex => $service_name_re };

# singleton constructor
sub _obj {
    my ($param) = validate_pos(@_, 1);
    if (blessed($param)) {
        return $param;
    }
    if ($param eq 'Ubic') {
        # method called as a class method => singleton
        $SINGLETON ||= Ubic->new({});
        return $SINGLETON;
    }
    die "Unknown argument '$param'";
}

sub new {
    my $class = shift;
    my $options = validate(@_, {
        service_dir =>  { type => SCALAR, optional => 1 },
        data_dir => { type => SCALAR, optional => 1 },
    });

    if (caller ne 'Ubic') {
        warn "Using Ubic->new constructor is discouraged. Just call methods as class methods.";
    }

    for my $key (qw/ service_dir data_dir /) {
        Ubic::Settings->$key($options->{ $key }) if defined $options->{$key};
    }

    Ubic::Settings->check_settings;

    my $self = {};
    $self->{data_dir} = Ubic::Settings->data_dir;
    $self->{service_dir} = Ubic::Settings->service_dir;

    $self->{status_dir} = "$self->{data_dir}/status";
    $self->{lock_dir} = "$self->{data_dir}/lock";
    $self->{tmp_dir} = "$self->{data_dir}/tmp";

    $self->{service_cache} = {};
    return bless $self => $class;
}

sub start($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);

    $self->enable($name);
    my $result = $self->do_cmd($name, 'start');
    $self->set_cached_status($name, $result);
    return $result;
}

sub stop($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);

    $self->disable($name);

    # FIXME - 'stop' command can fail, in this case daemon will keep running.
    # This is bad.
    # We probably need to implement the same logic as when starting:
    # retry stop attempts until actual status matches desired status.
    my $result = $self->do_cmd($name, 'stop');
    return $result;
}

sub restart($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);

    $self->enable($name);
    my $result = $self->do_cmd($name, 'stop');
    $result = $self->do_cmd($name, 'start');

    $self->set_cached_status($name, $result);
    return result('restarted'); # FIXME - should return original status
}

sub try_restart($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);

    unless ($self->is_enabled($name)) {
        return result('down');
    }
    $self->do_cmd($name, 'stop');
    $self->do_cmd($name, 'start');
    return result('restarted');
}

sub reload($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);

    unless ($self->is_enabled($name)) {
        return result('down');
    }

    # if reload isn't implemented, do nothing
    # TODO - would it be better to execute reload as force-reload always? but it would be incompatible with LSB specification...
    my $result = $self->do_cmd($name, 'reload');
    unless ($result->action eq 'reloaded') {
        die $result;
    }
    return $result;
}

sub force_reload($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);

    unless ($self->is_enabled($name)) {
        return result('down');
    }

    my $result = $self->do_cmd($name, 'reload');
    return $result if $result->action eq 'reloaded';

    $self->try_restart($name);
}

sub status($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);

    return $self->do_cmd($name, 'status');
}

sub enable($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);
    my $guard = $self->access_guard($name);

    my $status_obj = $self->status_obj($name);
    $status_obj->{status} = 'unknown';
    $status_obj->{enabled} = 1;
    $status_obj->commit;
    return result('unknown');
}

sub is_enabled($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);

    die "Service '$name' not found" unless $self->root_service->has_service($name);
    return unless -e $self->status_file($name);

    my $status_obj = $self->status_obj_ro($name);
    if ($status_obj->{enabled} or not exists $status_obj->{enabled}) {
        return 1;
    }
    return;
}

sub disable($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    my $lock = $self->lock($name);
    my $guard = $self->access_guard($name);

    my $status_obj = $self->status_obj($name);
    delete $status_obj->{status};
    $status_obj->{enabled} = 0;
    $status_obj->commit;
}


sub cached_status($$) {
    my ($self) = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);

    my $type;
    unless ($self->is_enabled($name)) {
        $type = 'disabled';
    }
    else {
        $type = $self->status_obj_ro($name)->{status};
    }
    return Ubic::Result::Class->new({ type => $type, cached => 1 });
}

sub do_custom_command($$) {
    my ($self) = _obj(shift);
    my ($name, $command) = validate_pos(@_, $validate_service, 1);

    # TODO - do all custom commands require locks?
    # they can be distinguished in future by some custom_commands_ext method which will provide hash { command => properties }, i think...
    my $lock = $self->lock($name);

    # TODO - check custom_command presence by custom_commands() method first?
    $self->do_sub(sub {
        $self->service($name)->do_custom_command($command); # can custom commands require custom arguments?
    });
}

sub service($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    # this guarantees that : will be unambiguous separator in status filename (what??)
    unless ($self->{service_cache}{$name}) {
        # Service construction is a memory-leaking operation (because of package name randomization in Ubic::Multiservice::Dir),
        # so we need to cache each service which we create.
        $self->{service_cache}{$name} = $self->root_service->service($name);
    }
    return $self->{service_cache}{$name};
}

sub has_service($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    # TODO - it would be safer to do this check without actual service construction
    # but it would require cron-based script which maintains list of all services
    return $self->root_service->has_service($name);
}

sub services($) {
    my $self = _obj(shift);
    return $self->root_service->services();
}

sub service_names($) {
    my $self = _obj(shift);
    return $self->root_service->service_names();
}

sub root_service($) {
    my $self = _obj(shift);
    unless (defined $self->{root}) {
        $self->{root} = Ubic::Multiservice::Dir->new($self->{service_dir}, { protected => 1 });
    }
    return $self->{root};
}

sub compl_services($$) {
    my $self = _obj(shift);
    my $line = shift;
    my @parts = split /\./, $line;
    if ($line =~ /\.$/) {
        push @parts, '';
    }
    if (@parts == 0) {
        return $self->service_names;
    }
    my $node = $self->root_service;
    my $is_subservice = (@parts > 1);
    while (@parts > 1) {
        unless ($node->isa('Ubic::Multiservice')) {
            return;
        }
        my $part = shift @parts;
        return unless $node->has_service($part); # no such service
        $node = $node->service($part);
    }

    my @variants = $node->service_names;
    return
        map {
            ( $is_subservice ? $node->full_name.".".$_ : $_ )
        }
        grep {
            $_ =~ m{^\Q$parts[0]\E}
        }
        @variants;
}

sub set_cached_status($$$) {
    my $self = _obj(shift);
    my ($name, $status) = validate_pos(@_, $validate_service, 1);
    my $guard = $self->access_guard($name);

    if (blessed $status) {
        croak "Wrong status param '$status'" unless $status->isa('Ubic::Result::Class');
        $status = $status->status;
    }
    my $lock = $self->lock($name);

    if ($self->status_obj_ro($name)->{status} eq $status) {
        # optimization - don't update status if nothing changed
        return;
    }

    my $status_obj = $self->status_obj($name);
    $status_obj->{status} = $status;
    $status_obj->commit;
}

sub get_data_dir($) {
    my $self = _obj(shift);
    validate_pos(@_);
    return $self->{data_dir};
}

sub set_data_dir($$) {
    my ($arg, $dir) = validate_pos(@_, 1, 1);

    my $md = sub {
        my $new_dir = shift;
        mkdir $new_dir or die "mkdir $new_dir failed: $!" unless -d $new_dir;
    };

    $md->($dir);
    # FIXME - directory list is copy-pasted from Ubic::Admin::Setup
    for my $subdir (qw[
        status simple-daemon simple-daemon/pid lock ubic-daemon tmp watchdog watchdog/lock watchdog/status
    ]) {
        $md->("$dir/$subdir");
    }

    Ubic::Settings->data_dir($dir);
    if ($SINGLETON) {
        $SINGLETON->{lock_dir} = "$dir/lock";
        $SINGLETON->{status_dir} = "$dir/status";
        $SINGLETON->{tmp_dir} = "$dir/tmp";
        $SINGLETON->{data_dir} = $dir;
    }
}

sub set_ubic_dir($$);
*set_ubic_dir = \&set_data_dir;

sub set_default_user($$) {
    my ($arg, $user) = validate_pos(@_, 1, 1);

    Ubic::Settings->default_user($user);
}

sub get_service_dir($) {
    my $self = _obj(shift);
    validate_pos(@_);
    return $self->{service_dir};
}

sub set_service_dir($$) {
    my ($arg, $dir) = validate_pos(@_, 1, 1);
    Ubic::Settings->service_dir($dir);
    if ($SINGLETON) {
        $SINGLETON->{service_dir} = $dir;
        undef $SINGLETON->{root}; # force lazy regeneration
    }
}

sub status_file($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    return "$self->{status_dir}/".$name;
}

sub status_obj($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    return Ubic::Persistent->new($self->status_file($name));
}

sub status_obj_ro($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    return Ubic::Persistent->load($self->status_file($name));
}

sub access_guard($$) {
    my $self = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);
    return Ubic::AccessGuard->new(
        Ubic::Credentials->new(service => $self->service($name))
    );
}

sub lock($$) {
    my ($self) = _obj(shift);
    my ($name) = validate_pos(@_, $validate_service);

    my $lock = do {
        my $guard = $self->access_guard($name);
        Ubic::SingletonLock->new($self->{lock_dir}."/".$name);
    };
    return $lock;
}

sub do_sub($$) {
    my ($self, $code) = @_;
    my $result = try {
        $code->();
    } catch {
        die result($_);
    };
    return result($result);
}

sub do_cmd($$$) {
    my ($self, $name, $cmd) = @_;
    $self->do_sub(sub {
        my $service = $self->service($name);

        my $creds = Ubic::Credentials->new( service => $service );

        if ($creds->eq(Ubic::Credentials->new)) {
            # current credentials fit service expectations
            return $service->$cmd();
        }

        # setting just effective uid is not enough, because:
        # - we can accidentally enter tainted mode, and service authors don't expect this
        # - local administrator may want to allow everyone to write their own services, and leaving root as real uid is an obvious security breach
        # (ubic will have to learn to compare service user with service file's owner for such policy to be safe, though - this is not implemented yet)
        $self->forked_call(sub {
            $creds->set();
            return $service->$cmd();
        });
    });
}

sub forked_call {
    my ($self, $callback) = @_;
    my $tmp_file = $self->{tmp_dir}."/".time.".$$.".rand(1000000);
    my $child;
    unless ($child = fork) {
        unless (defined $child) {
            die "fork failed";
        }
        my $result;
        try {
            $result = { ok => $callback->() };
        }
        catch {
            $result = { error => $_ };
        };

        try {
            Ubic::AtomicFile::store( freeze($result) => $tmp_file );
            STDOUT->flush;
            STDERR->flush;
            POSIX::_exit(0); # don't allow to lock to be released - this process was forked from unknown environment, don't want to run unknown destructors
        }
        catch {
            # probably tmp_file is not writtable
            warn $_;
            POSIX::_exit(1);
        };
    }
    waitpid($child, 0);
    unless (-e $tmp_file) {
        die "temp file $tmp_file not found after fork";
    }
    open my $fh, '<', $tmp_file or die "Can't read $tmp_file: $!";
    my $content = do { local $/; <$fh>; };
    close $fh or die "Can't close $tmp_file: $!";
    unlink $tmp_file;
    my $result = thaw($content);
    if ($result->{error}) {
        die $result->{error};
    }
    else {
        return $result->{ok};
    }
}


1;

__END__
=pod

=head1 NAME

Ubic - polymorphic service manager

=head1 VERSION

version 1.44_01

=head1 SYNOPSIS

    Configure ubic:
    $ ubic-admin setup

    Write the service config:
    $ cat >/etc/ubic/service/foo.ini
    [options]
    bin = /usr/bin/foo.pl

    Start your service:
    $ ubic start foo

    Enjoy your daemonized, monitored service.

=head1 DESCRIPTION

This module is a perl frontend to ubic services.

It is a singleton OOP class. All of its methods should be invoked as class methods:

    Ubic->start('foo');
    Ubic->stop('foo');
    my $status = Ubic->status('foo');

=head1 INTRODUCTION

Ubic is a polymorphic service manager.

Further directions:

if you are looking for a general introduction to Ubic, see L<Ubic::Manual::Intro>;

if you want to use ubic from the command line, see L<ubic>;

if you want to manage ubic services from the perl scripts, read this POD;

if you want to write your own service, see L<Ubic::Service> and other C<Ubic::Service::*> modules.

=head1 CONSTRUCTOR

=over

=item B<< Ubic->new({ ... }) >>

All methods in this package can be invoked as class methods, but sometimes you may need to override some status dirs. In this case you should construct your own C<Ubic> instance.

Note that you can't create several instances in one process and have them work independently. So, this constructor is actually just a weird way to override service_dir and data_dir.

Constructor options (all of them are optional):

=over

=item I<service_dir>

Name of dir with service descriptions (which will be used to construct root C<Ubic::Multiservice::Dir> object).

=item I<data_dir>

Dir into which ubic stores all of its data (locks, status files, tmp files).

=back

=back

=head1 LSB METHODS

See L<LSB documentation|http://refspecs.freestandards.org/LSB_3.1.0/LSB-Core-generic/LSB-Core-generic/iniscrptact.html> for init-script method specifications.

Following methods are trying to conform, except that all dashes in method names are replaced with underscores.

These methods return the result objects, i.e., instances of the C<Ubic::Result::Class> class.

=over

=item B<start($name)>

Start the service.

=item B<stop($name)>

Stop the service.

=item B<restart($name)>

Restart the service; start it if it's not running.

=item B<try_restart($name)>

Restart the service if it is enabled.

=item B<reload($name)>

Reload the service.

This method will do reloading if the service implements C<reload()>; it will throw an exception otherwise.

=item B<force_reload($name)>

Reload the service if reloading is implemented, otherwise restart it.

Does nothing if service is disabled.

=item B<status($name)>

Get the service status.

=back

=head1 OTHER METHODS

=over

=item B<enable($name)>

Enable the service.

Enabled service means that service B<should> be running.

Watchdog will periodically check its status, attempt to restart it and mark it as I<broken> if it won't succeed.

=item B<is_enabled($name)>

Check whether the service is enabled.

Returns true or false.

=item B<disable($name)>

Disable the service.

Disabled service means that the service is ignored by ubic.

Its state will no longer be checked by the watchdog, and C<ubic status> will report that the service is I<down>.

=item B<cached_status($name)>

Get cached status of the service.

Unlike other methods, it can be invoked by any user.

=item B<do_custom_command($name, $command)>

Execute the custom command C<$command> for the given service.

=item B<service($name)>

Get service object by name.

=item B<< has_service($name) >>

Check whether the service named C<$name> exists.

=item B<services()>

Get the list of all services.

=item B<service_names()>

Get the list of all service names.

=item B<root_service()>

Get the root multiservice object.

Root service doesn't have a name and returns all top-level services with C<services()> method. You can use it to traverse the whole service tree.

=item B<compl_services($line)>

Get the list of autocompletion variants for a given service prefix.

=item B<set_cached_status($name, $status)>

Write the new status into the service's status file.

=item B<< get_data_dir() >>

Get the data dir.

=item B<< set_data_dir($dir) >>

Set the data dir, creating it if necessary.

Data dir is a directory with service statuses and locks. (See C<Ubic::Settings> for more details on how it's chosen).

This setting will be propagated into subprocesses using environment, so the following code works:

    Ubic->set_data_dir('tfiles/ubic');
    Ubic->set_service_dir('etc/ubic/service');
    system('ubic start some_service');
    system('ubic stop some_service');

=item B<< set_ubic_dir($dir) >>

Deprecated. This method got renamed to C<set_data_dir()>.

=item B<< set_default_user($user) >>

Set default user for all services.

This is a simple proxy for C<< Ubic::Settings->default_user($user) >>.

=item B<< get_service_dir() >>

Get the ubic services dir.

=item B<< set_service_dir($dir) >>

Set the ubic services dir.

=back

=head1 INTERNAL METHODS

You shouldn't call these from a code which doesn't belong to core Ubic distribution.

These methods can be changed or removed without further notice.

=over

=item B<status_file($name)>

Get the status file name by a service's name.

=item B<status_obj($name)>

Get the status persistent object by a service's name.

It's a bad idea to call this from any other class than C<Ubic>, but if you'll ever want to do this, at least don't forget to create C<Ubic::AccessGuard> first.

=item B<status_obj_ro($name)>

Get the readonly, nonlocked status persistent object (see L<Ubic::Persistent>) by a service's name.

=item B<access_guard($name)>

Get an access guard (L<Ubic::AccessGuard> object) for the given service.

=item B<lock($name)>

Acquire lock object for given service.

You can lock one object twice from the same process, but not from different processes.

=item B<< do_sub($code) >>

Run any code and wrap any result or exception into a result object.

=item B<< do_cmd($name, $cmd) >>

Run C<$cmd> method from the service named C<$name> and wrap any result or exception in a result object.

=item B<< forked_call($callback) >>

Run a C<$callback> in a subprocess and return its return value.

Interaction happens through a temporary file in C<< $ubic->{tmp_dir} >> dir.

=back

=head1 CONTRIBUTORS

Andrei Mishchenko <druxa@yandex-team.ru>

Yury Zavarin <yury.zavarin@gmail.com>

Dmitry Yashin

Christian Walde <walde.christian@googlemail.com>

Ivan Bessarabov <ivan@bessarabov.ru>

=head1 SEE ALSO

Most Ubic-related links are collected on github wiki: L<http://github.com/berekuk/Ubic/wiki>.

L<Daemon::Control> and L<Proc::Launcher> provide the start/stop/status style mechanisms for init scripts and apachectl-style commands.

L<Server::Control> is an apachectl-style, heavyweight subclassable module for handling network daemons.

L<ControlFreak> - process supervisor, similar to Ubic in its command-line interface.

There are also L<App::Daemon>, L<App::Control> and L<Supervisor>.

=head1 SUPPORT

Our IRC channel is irc://irc.perl.org#ubic.

There's also a mailing list at ubic-perl@googlegroups.com. Send an empty message to ubic-perl+subscribe@googlegroups.com to subscribe.

=head1 AUTHOR

Vyacheslav Matyukhin <mmcleric@yandex-team.ru>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 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
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)