The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Ubic::Daemon;
{
  $Ubic::Daemon::VERSION = '1.48';
}

use strict;
use warnings;

# ABSTRACT: daemon management utilities


use IO::Handle;
use POSIX qw(setsid :sys_wait_h);
use Time::HiRes qw(sleep);
use Params::Validate qw(:all);
use Carp;
use Config;

use Ubic::Lockf;
use Ubic::AccessGuard;
use Ubic::Daemon::Status;
use Ubic::Daemon::PidState;

use parent qw(Exporter);
our @EXPORT_OK = qw(start_daemon stop_daemon check_daemon);
our %EXPORT_TAGS = (
    all => \@EXPORT_OK,
);

our $OS;
sub import {
    my %module = (
        linux   => 'Linux',
    );

    # UBIC_DAEMON_OS support is here only for tests
    my $module = $ENV{UBIC_DAEMON_OS} || $module{$^O} || 'POSIX';

    require "Ubic/Daemon/OS/$module.pm";
    $OS = eval "Ubic::Daemon::OS::$module->new";
    unless ($OS) {
        die "failed to initialize OS-specific module $module: $@";
    }
    __PACKAGE__->export_to_level(1, @_);
}

{
    my @signame;
    sub _signame {
        my $signum = shift;
        unless (@signame) {
            @signame = split /\s+/, $Config{sig_name};
        }
        return $signame[$signum];

    }
}

sub _log {
    my $fh = shift;
    return unless defined $fh;
    print {$fh} '[', scalar(localtime), "]\t$$\t", @_, "\n";
}

sub _log_exit_code {
    my ($fh, $code, $pid) = @_;
    if ($code == 0) {
        _log($fh, "daemon $pid exited");
        return;
    }

    my $msg = "daemon $pid failed with \$? = $?";
    if (my $signal = $? & 127) {
        my $signame = _signame($signal);
        if (defined $signame) {
            $msg = "daemon $pid failed with signal $signame ($signal)";
        }
        else {
            $msg = "daemon $pid failed with signal $signal";
        }
    }
    elsif ($? & 128) {
        $msg = "daemon $pid failed, core dumped";
    }
    elsif (my $code = $? >> 8) {
        $msg = "daemon $pid failed, exit code $code";
    }
    _log($fh, $msg);
}

sub stop_daemon($;@) {
    my ($pidfile, @tail) = validate_pos(@_, { type => SCALAR }, 0);
    my $options = validate(@tail, {
        timeout => { default => 30, regex => qr/^\d+$/ },
    });
    my $timeout = $options->{timeout} if defined $options->{timeout};

    # TODO - move this check into Ubic::Daemon::PidState
    my $pid_state = Ubic::Daemon::PidState->new($pidfile);
    return 'not running' if $pid_state->is_empty;

    my $piddata = $pid_state->read;
    unless ($piddata) {
        return 'not running';
    }
    my $pid = $piddata->{pid};

    unless (check_daemon($pidfile)) {
        return 'not running';
    }
    kill 15 => $pid;
    my $trial = 1;
    {
        my $sleep = 0.1;
        my $total_sleep = 0;
        while (1) {
            unless (check_daemon($pidfile)) {
                return 'stopped';
            }
            last if $total_sleep >= $timeout;
            sleep($sleep);
            $total_sleep += $sleep;
            $sleep += 0.1 * $trial if $sleep < 1;
            $trial++;
        }
    }
    unless (check_daemon($pidfile)) {
        return 'stopped';
    }
    die "failed to stop daemon with pidfile '$pidfile' (pid $pid, timeout $timeout, trials $trial)";
}

sub start_daemon($) {
    my %options = validate(@_, {
        bin => { type => SCALAR | ARRAYREF, optional => 1 },
        function => { type => CODEREF, optional => 1 },
        name => { type => SCALAR, optional => 1 },
        pidfile => { type => SCALAR },
        stdout => { type => SCALAR, default => '/dev/null' },
        stderr => { type => SCALAR, default => '/dev/null' },
        ubic_log => { type => SCALAR, optional => 1 },
        term_timeout => { type => SCALAR, default => 10, regex => qr/^\d+$/ },
        cwd => { type => SCALAR, optional => 1 },
        env => { type => HASHREF, optional => 1 },
        credentials => { isa => 'Ubic::Credentials', optional => 1 },
        start_hook => { type => CODEREF, optional => 1 },
    });
    my           ($bin, $function, $name, $pidfile, $stdout, $stderr, $ubic_log, $term_timeout, $cwd, $env, $credentials, $start_hook)
    = @options{qw/ bin   function   name   pidfile   stdout   stderr   ubic_log   term_timeout   cwd   env   credentials   start_hook /};
    if (not defined $bin and not defined $function) {
        croak "One of 'bin' and 'function' should be specified";
    }
    if (defined $bin and defined $function) {
        croak "Only one of 'bin' and 'function' should be specified";
    }
    unless (defined $name) {
        if (ref $bin) {
            $name = join ' ', @$bin;
        }
        else {
            $name = $bin || 'anonymous';
        }
    }

    if (check_daemon($pidfile)) {
        croak "Daemon with pidfile $pidfile already running, can't start";
    }

    my $pid_state = Ubic::Daemon::PidState->new($pidfile);
    $pid_state->init;

    my $stdin = '/dev/null';

    pipe my ($read_pipe, $write_pipe) or die "pipe failed";
    my $child;

    unless ($child = fork) {
        die "fork failed" unless defined $child;

        my $ubic_fh;
        my $lock;
        my $instant_exit = sub {
            close($ubic_fh) if $ubic_fh;
            STDOUT->flush;
            STDERR->flush;
            undef $lock;
            POSIX::_exit(0); # don't allow any cleanup to happen - this process was forked from unknown environment, don't want to run unknown destructors
        };

        eval {
            close($read_pipe) or die "Can't close read pipe: $!";
            # forking child - will reopen standard streams, daemonize itself, fork into daemon binary and wait for it

            {
                my $tmp_pid = fork() and POSIX::_exit(0); # detach from parent process
                die "fork failed" unless defined $tmp_pid;
            }

            # Close all inherited filehandles except $write_pipe (it will be closed explicitly).
            # Do not close fh if uses 'function' option instead of 'bin'
            # ('function' support should be removed altogether because of this, actually; it's evil).
            if ($bin) {
                my $write_pipe_fd_num = fileno($write_pipe);
                $OS->close_all_fh($write_pipe_fd_num); # except pipe
            }

            {
                my $guard;
                $guard = Ubic::AccessGuard->new($credentials) if $credentials;
                open STDOUT, ">>", $stdout or die "Can't write to '$stdout': $!";
                open STDERR, ">>", $stderr or die "Can't write to '$stderr': $!";
            }
            open STDIN, "<", $stdin or die "Can't read from '$stdin': $!";
            if (defined $ubic_log) {
                open $ubic_fh, ">>", $ubic_log or die "Can't write to '$ubic_log': $!";
                $ubic_fh->autoflush(1);
            }
            $SIG{HUP} = 'ignore';
            $0 = "ubic-guardian $name";
            setsid; # ubic-daemon gets it's own session
            _log($ubic_fh, "guardian name: $0");

            _log($ubic_fh, "obtaining lock...");

            # We're passing 'timeout' option to lockf call to get rid of races.
            # There should be no races when Ubic::Daemon is used in context of
            # ubic service, because services have an additional lock, but
            # Ubic::Daemon can be useful without services as well.
            $lock = $pid_state->lock(5) or die "Can't lock $pid_state";

            $pid_state->remove;
            _log($ubic_fh, "got lock");

            my $child;
            if ($child = fork) {
                # guardian

                _log($ubic_fh, "guardian pid: $$");
                _log($ubic_fh, "daemon pid: $child");

                my $child_guid = $OS->pid2guid($child);
                unless ($child_guid) {
                    if ($OS->pid_exists($child)) {
                        die "Can't detect guid";
                    }
                    $? = 0;
                    unless (waitpid($child, WNOHANG) == $child) {
                        die "No pid $child but waitpid didn't collect $child status";
                    }
                    _log_exit_code($ubic_fh, $?, $child);
                    $pid_state->remove();
                    die "daemon exited immediately";
                }
                _log($ubic_fh, "child guid: $child_guid");
                $pid_state->write({ pid => $child, guid => $child_guid });

                my $kill_sub = sub {
                    if ($term_timeout) {
                        _log($ubic_fh, "SIGTERM timeouted after $term_timeout second(s)");
                    }
                    _log($ubic_fh, "sending SIGKILL to $child");
                    kill -9 => $child;
                    _log($ubic_fh, "daemon $child probably killed by SIGKILL");
                    $pid_state->remove();
                    $instant_exit->();
                };

                my $sigterm_sent;
                $SIG{TERM} = sub {
                    if ($term_timeout > 0) {
                        $SIG{ALRM} = $kill_sub;
                        alarm($term_timeout);
                        _log($ubic_fh, "sending SIGTERM to $child");
                        kill -15 => $child;
                        $sigterm_sent = 1;
                    }
                    else {
                        $kill_sub->();
                    }
                };
                print {$write_pipe} "pidfile written\n" or die "Can't write to pipe: $!";
                close $write_pipe or die "Can't close pipe: $!";
                undef $write_pipe;

                $? = 0;
                waitpid($child, 0);
                my $code = $?;
                if ($sigterm_sent and ($code & 127) == &POSIX::SIGTERM) {
                    # it's ok, we probably sent this signal ourselves
                    _log($ubic_fh, "daemon $child exited by sigterm");
                }
                else {
                    _log_exit_code($ubic_fh, $code, $child);
                }
                $pid_state->remove;
            }
            else {
                # daemon

                die "fork failed" unless defined $child;

                # start new process group - become immune to kills at parent group and at the same time be able to kill all processes below
                setpgrp;
                $0 = "ubic-daemon $name";

                if (defined $cwd) {
                    chdir $cwd or die "chdir to '$cwd' failed: $!";
                }
                if (defined $env) {
                    for my $key (keys %{ $env }) {
                        $ENV{$key} = $env->{$key};
                    }
                }
                $start_hook->() if $start_hook;
                $credentials->set() if $credentials;

                close($ubic_fh) if defined $ubic_fh;
                $lock->dissolve;

                print {$write_pipe} "execing into daemon\n" or die "Can't write to pipe: $!";
                close($write_pipe) or die "Can't close pipe: $!";
                undef $write_pipe;

                # finally, run underlying binary
                if (ref $bin) {
                    exec(@$bin) or die "exec failed: $!";
                }
                elsif ($bin) {
                    exec($bin) or die "exec failed: $!";
                }
                else {
                    $function->();
                }
            }
        };
        if ($write_pipe) {
            print {$write_pipe} "Error: $@\n";
            $write_pipe->flush;
        }
        $instant_exit->();
    }
    waitpid($child, 0); # child should've exited immediately
    close($write_pipe) or die "Can't close write_pipe: $!";

    my $out = '';
    while ( my $data = <$read_pipe>) {
        $out .= $data;
    }
    close($read_pipe) or die "Can't close read_pipe: $!";
    if ($out =~ /^execing into daemon$/m and $out =~ /^pidfile written$/m) {
        # TODO - check daemon's name to make sure that exec happened
        return;
    }
    die "Failed to create daemon: '$out'";
}

sub check_daemon {
    my $pidfile = shift;
    my $options = validate(@_, {
        quiet => { optional => 1 },
    });

    my $print = sub {
        print @_, "\n" unless $options->{quiet};
    };

    my $pid_state = Ubic::Daemon::PidState->new($pidfile);
    return undef if $pid_state->is_empty;

    my $lock = $pid_state->lock;
    my $piddata = $pid_state->read;
    unless ($lock) {
        # locked => daemon is alive
        return Ubic::Daemon::Status->new({ pid => $piddata->{daemon} });
    }

    unless ($piddata) {
        return undef;
    }

    # acquired lock when pidfile exists
    # checking whether just ubic-guardian died or whole process group
    if ($piddata->{format} and $piddata->{format} eq 'old') {
        die "deprecated pidfile format detected\n";
    }
    unless ($piddata->{daemon}) {
        use Data::Dumper;
        die "pidfile $pidfile exists, but daemon pid is not saved in it, so existing unguarded daemon can't be killed (piddata: ".Dumper($piddata).")";
    }
    unless ($OS->pid_exists($piddata->{daemon})) {
        $pid_state->remove;
        $print->("pidfile $pidfile removed - daemon with cached pid $piddata->{daemon} not found");
        return undef;
    }

    # TODO - wrap in eval and return undef if pid2cmd fails?
    my $daemon_cmd = $OS->pid2cmd($piddata->{daemon});

    my $guid = $OS->pid2guid($piddata->{daemon});
    unless ($guid) {
        $print->("daemon '$daemon_cmd' from $pidfile just disappeared");
        return undef;
    }
    if ($guid eq $piddata->{guid}) {
        $print->("killing unguarded daemon '$daemon_cmd' with pid $piddata->{daemon} from $pidfile");
        kill -9 => $piddata->{daemon};
        $pid_state->remove;
        $print->("pidfile $pidfile removed");
        return undef;
    }
    $print->("daemon pid $piddata->{daemon} cached in pidfile $pidfile, ubic-guardian not found");
    $print->("current process '$daemon_cmd' with pid $piddata->{daemon} has wrong guid ($piddata->{guid}, expected $guid) and will not be killed");
    $print->("removing pidfile $pidfile");
    $pid_state->remove;
    return undef;
}


1;

__END__

=pod

=head1 NAME

Ubic::Daemon - daemon management utilities

=head1 VERSION

version 1.48

=head1 SYNOPSIS

    use Ubic::Daemon qw(start_daemon stop_daemon check_daemon);

    start_daemon({bin => '/bin/sleep', pidfile => "/var/lib/something/pid"});
    stop_daemon("/var/lib/something/pid");

    $daemon_status = check_daemon("/var/lib/something/pid");

=head1 DESCRIPTION

This module provides functions which let you daemonize any binary or perl coderef.

Main source of knowledge if daemon is still running is pidfile, which is locked all the time after daemon was created.

Note that pidfile format is unreliable and can change in future releases (it's actually even not a file, it's a dir with several files inside it),
so if you need to get daemon's pid, don't try to read pidfile directly, use C<check_daemon()> function.

=over

=item B<stop_daemon($pidfile)>

=item B<stop_daemon($pidfile, $options)>

Stop daemon which was started with C<$pidfile>.

It sends I<SIGTERM> to process with pid specified in C<$pidfile> until it will stop to exist (according to C<check_daemon()> method).

If it fails to stop process after several seconds, exception will be raised (this should never happen, assuming you have enough grants).

Options:

=over

=item I<timeout>

Number of seconds to wait before raising exception that daemon can't be stopped.

=back

Return value: C<not running> if daemon is already not running; C<stopped> if daemon is stopped by I<SIGTERM>.

=item B<start_daemon($params)>

Start daemon.

Throws exception if anything fails.

Successful completion doesn't mean much, though, since daemon can fail any moment later, and we have no idea when its initialization stage finishes.

Parameters:

=over

=item I<bin>

Binary which will be daemonized.

Can be string or arrayref with arguments. Arrayref-style values are recommended in complex cases, because otherwise C<exec()> can invoke sh shell which will immediately exit on sigterm.

=item I<function>

Function which will be daemonized. One and only one of I<function> and I<bin> must be specified.

Function daemonization is a dangerous feature and will probably be deprecated and removed in future.

=item I<name>

Name of guardian process. Guardian will be named "ubic-guardian $name".

If not specified, I<bin>'s value will be used, or C<anonymous> when daemonizing perl code.

=item I<pidfile>

Pidfile is a dir in local filesystem which will be used as a storage of daemon's info.

It will be created if necessary, assuming that its parent dir exists.

=item I<stdout>

Write all daemon's output to given file. If not specified, all output will be redirected to C</dev/null>.

=item I<stderr>

Write all daemon's error output to given file. If not specified, all stderr will be redirected to C</dev/null>.

=item I<ubic_log>

Optional filename of ubic log. Log will contain some technical information about running daemon.

If not specified, this logging facility will be disabled.

=item I<cwd>

Change working directory before starting a daemon. Optional.

=item I<env>

Modify environment before starting a daemon. Optional. Must be a plain hashref if specified.

=item I<credentials>

Set given credentials before execing into a daemon. Optional, must be an C<Ubic::Credentials> object.

=item I<start_hook>

Optional callback that will be executed before execing into a daemon.

This option is a generalization of I<cwd> and I<env> options. One useful application of it is setting ulimits: they won't affect your main process, since this hook will be executed in the context of double-forked process.

Note that hook is called *before* the credentials are set. Raising the ulimits won't work otherwise.

=item I<term_timeout>

Can contain integer number of seconds to wait between sending I<SIGTERM> and I<SIGKILL> to daemon.

Zero value means that guardian will send sigkill to daemon immediately.

Default is 10 seconds.

=back

=item B<check_daemon($pidfile)>

Check whether daemon is running.

Returns instance of L<Ubic::Daemon::Status> class if daemon is alive, and false otherwise.

=back

=head1 BUGS AND CAVEATS

Probably. But it definitely is ready for production usage.

This module is not compatible with Windows by now. It can be fixed by implementing correct C<Ubic::Daemon::OS::Windows> module.

If you wonder why there are C<ubic-guardian> processes in your C<ps> output, see L<Ubic::Manual::FAQ>, answer is there.

=head1 SEE ALSO

L<Ubic::Service::SimpleDaemon> - simplest ubic service which uses Ubic::Daemon

There are also a plenty of other daemonizers on CPAN:

L<MooseX::Daemonize>, L<Proc::Daemon>, L<Daemon::Generic>, L<Net::Server::Daemonize>.

=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