File Coverage

lib/Ubic.pm

Criterion	Covered	Total	%
statement	196	297	65.9
branch	25	68	36.7
condition	6	11	54.5
subroutine	46	60	76.6
pod	33	33	100.0
total	306	469	65.2

package Ubic;
$Ubic::VERSION = '1.59';
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);
    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__