Sponsoring The Perl Toolchain Summit 2025: Help make this important event another success Learn more

package Ubic;
{
$Ubic::VERSION = '1.57_01';
}
use strict;
# ABSTRACT: polymorphic service manager
use POSIX qw();
use Carp;
use Storable qw(freeze thaw);
use Scalar::Util qw(blessed);
use Params::Validate qw(:all);
use Ubic::Result qw(result);
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);
unless (-e $self->status_file($name)) {
return $self->service($name)->auto_start();
}
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;
if (not $self->is_enabled($name)) {
$type = 'disabled';
}
elsif (-e $self->status_file($name)) {
$type = $self->status_obj_ro($name)->{status};
} else {
$type = 'autostarting';
}
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 (-e $self->status_file($name) and $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 writable
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
=encoding UTF-8
=head1 NAME
Ubic - polymorphic service manager
=head1 VERSION
version 1.57_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>
Oleg Komarov <komarov@cpan.org>
Andrew Kirkpatrick <ubermonk@gmail.com>
=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) 2014 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