Server::Control - Flexible apachectl style control for servers

    use Server::Control::Apache;

    my $apache = Server::Control::Apache->new(
        conf_file => '/my/apache/dir/conf/httpd.conf'
    );
    if ( !$apache->is_running() ) {
        $apache->start();
    }

   package Server::Control::Plugin::EmailOnStatusChange;
   use Moose::Role;

   has 'email_status_to' => ( is => 'ro', isa => 'Str', required => 1 );

   after 'successful_start' => sub {
       shift->send_email("server started");
   };
   after 'successful_stop' => sub {
       shift->send_email("server stopped");
   };

   __PACKAGE__->meta->make_immutable();

   sub send_email {
       my ( $self, $subject ) = @_;

       ...;
   }

   1;

   my $apache = Server::Control::Apache->new_with_traits(
       traits          => ['EmailOnStatusChange'],
       email_status_to => 'joe@domain.org',
       conf_file       => '/my/apache/dir/conf/httpd.conf'
   );

package Server::Control;
BEGIN {
  $Server::Control::VERSION = '0.15';
}
use Capture::Tiny;
use File::Basename;
use File::Slurp qw(read_file);
use File::Spec::Functions qw(catdir);
use Getopt::Long;
use Hash::MoreUtils qw(slice_def);
use IPC::System::Simple qw();
use Log::Any qw($log);
use Log::Dispatch::Screen;
use Moose;
use MooseX::StrictConstructor;
use Moose::Util::TypeConstraints;
use Pod::Usage;
use Time::HiRes qw(usleep);
use Server::Control::Util
  qw(is_port_active kill_children something_is_listening_msg process_table);
use YAML::Any;
use strict;
use warnings;

# Gives us new_with_traits - only if MooseX::Traits is installed
#
eval {
    with 'MooseX::Traits';
    has '+_trait_namespace' => ( default => 'Server::Control::Plugin' );
};
if ( my $moosex_traits_error = $@ ) {
    __PACKAGE__->meta->add_method(
        new_with_traits => sub {
            die "MooseX::Traits could not be loaded - $moosex_traits_error";
        }
    );
}

#
# ATTRIBUTES
#

# Note: In some cases we use lazy_build rather than specifying required or a
# default, to make life easier for subclasses.
#
has 'bind_addr'   => ( is => 'ro', isa => 'Str', lazy_build => 1 );
has 'description' =>
( is => 'ro', isa => 'Str', lazy_build => 1, init_arg => undef );

has 'error_log'            => ( is => 'ro', isa => 'Str', lazy_build => 1 );
has 'log_dir'              => ( is => 'ro', isa => 'Str', lazy_build => 1 );
has 'name'                 => ( is => 'ro', isa => 'Str', lazy_build => 1 );
has 'pid_file'             => ( is => 'ro', isa => 'Str', lazy_build => 1 );
has 'poll_for_status_secs' => ( is => 'ro', isa => 'Num', default => 0.2 );
has 'port'                 => ( is => 'ro', isa => 'Int', lazy_build => 1 );
has 'restart_method' =>
( is => 'ro', isa => enum( [qw(hup stopstart)] ), default => 'stopstart' );

has 'server_root'          => ( is => 'ro', isa => 'Str' );
has 'use_sudo'             => ( is => 'ro', isa => 'Bool', lazy_build => 1 );
has 'wait_for_hup_secs'    => ( is => 'ro', isa => 'Num', default => 0.5 );
has 'wait_for_status_secs' => ( is => 'ro', isa => 'Int', default => 10 );

# These are only for command-line. Would like to prevent their use from regular new()...
#
has 'action' => ( is => 'ro', isa => 'Str' );

foreach
  my $method (qw(successful_start successful_stop failed_start failed_stop))
{
    __PACKAGE__->meta->add_method( $method => sub { } );
}

__PACKAGE__->meta->make_immutable();

use constant {
    INACTIVE  => 0,
    RUNNING   => 1,
    LISTENING => 2,
    ACTIVE    => 3,
};

#
# CONSTRUCTION
#

sub BUILDARGS {
    my $class  = shift;
    my %params = @_;

    $class->_handle_serverctlrc( \%params );
    $class->_log_constructor_params( \%params );

    return $class->SUPER::BUILDARGS(%params);
}

# See if there is an rc_file, in serverctlrc parameter or in
# server_root/serverctl.yml; if so, read from it and merge with parameters
# passed to constructor.
#
sub _handle_serverctlrc {
    my ( $class, $params ) = @_;

    my $rc_file;
    if ( $rc_file = delete( $params->{serverctlrc} ) ) {
        die sprintf( "no such rc file '%s'", $rc_file ) if !-f $rc_file;
    }
    else {
        if ( defined( $params->{server_root} ) ) {
            my $default_rc_file =
              join( "/", $params->{server_root}, "serverctl.yml" );
            $rc_file = $default_rc_file if -f $default_rc_file;
        }
    }
    if ( defined $rc_file ) {
        if ( defined( my $rc_params = YAML::Any::LoadFile($rc_file) ) ) {
            die "expected hashref from rc_file '$rc_file', got '$rc_params'"
              unless ref($rc_params) eq 'HASH';
            %$rc_params =
              map { my $val = $rc_params->{$_}; s/\-/_/g; ( $_, $val ) }
              keys(%$rc_params);
            %$params = ( %$rc_params, %$params );
            $log->debugf( "found rc file '%s' with these parameters: %s",
                $rc_file, $rc_params )
              if $log->is_debug;
        }
    }
}

sub _log_constructor_params {
    my ( $class, $params ) = @_;

    $log->debugf( "constructing Server::Control with these params: %s",
        $params )
      if $log->is_debug;
}

#
# ATTRIBUTE BUILDERS
#

sub _build_bind_addr {
    return "localhost";
}

sub _build_error_log {
    my $self = shift;
    return
      defined( $self->log_dir ) ? catdir( $self->log_dir, "error_log" ) : undef;
}

sub _build_description {
    my $self = shift;
    my $name = $self->name;
    return "server '$name'";
}

sub _build_log_dir {
    my $self = shift;
    return defined( $self->server_root )
      ? catdir( $self->server_root, "logs" )
      : undef;
}

sub _build_name {
    my $self = shift;
    my $name;
    if ( defined( my $server_root = $self->server_root ) ) {
        $name = basename($server_root);
    }
    else {
        ( $name = ref($self) ) =~ s/^Server::Control:://;
    }
    return $name;
}

sub _build_pid_file {
    die "cannot determine pid_file";
}

sub _build_port {
    die "cannot determine port";
}

sub _build_use_sudo {
    my $self = shift;
    return $self->port < 1024;
}

#
# PUBLIC METHODS
#

sub start {
    my $self = shift;

    if ( !$self->_running_before_start() && !$self->_listening_before_start() )
    {
        my $error_size_start = $self->_start_error_log_watch();

        eval { $self->do_start() };
        if ( my $err = $@ ) {
            $log->errorf( "error while trying to start %s: %s",
                $self->description(), $err );
            $self->_report_error_log_output($error_size_start);
        }
        else {
            if (
                $self->_wait_for_status( ACTIVE, 'start', \$error_size_start ) )
            {
                ( my $status = $self->status_as_string() ) =~
                  s/running/now running/;
                $log->info($status);
                if ( $self->validate_server() ) {
                    $self->successful_start();
                    return 1;
                }
                else {
                    $self->_report_error_log_output($error_size_start);
                }
            }
        }
    }
    $self->failed_start();
    return 0;
}

sub _running_before_start {
    my $self = shift;

    if ( my $proc = $self->is_running() ) {
        ( my $status = $self->status_as_string() ) =~
          s/running/already running/;
        $log->warnf($status);
        return 1;
    }
    return 0;
}

sub _listening_before_start {
    my $self = shift;

    if ( $self->is_listening() ) {
        $log->warnf(
            "cannot start %s - pid file '%s' does not exist, but %s",
            $self->description(),
            $self->pid_file(),
            something_is_listening_msg( $self->port, $self->bind_addr )
        );
        return 1;
    }
    return 0;
}

sub stop {
    my ($self) = @_;

    my $error_size_start = $self->_start_error_log_watch();

    my $proc = $self->_ensure_is_running() or return 0;
    $self->_warn_if_different_user($proc);

    eval { $self->do_stop($proc) };
    if ( my $err = $@ ) {
        $log->errorf( "error while trying to stop %s: %s",
            $self->description(), $err );
        $self->_report_error_log_output($error_size_start);
    }
    elsif ( $self->_wait_for_status( INACTIVE, 'stop', $error_size_start ) ) {
        $log->infof( "%s has stopped", $self->description() );
        $self->successful_stop();
        return 1;
    }
    $self->failed_stop();
    return 0;
}

sub restart {
    my ($self) = @_;

    if ( !$self->is_running() ) {
        return $self->start();
    }
    else {
        my $restart_method = $self->restart_method;
        $self->$restart_method();
    }
}

sub hup {
    my ($self) = @_;

    my $proc = $self->_ensure_is_running() or return 0;
    my $error_size_start = $self->_start_error_log_watch();
    unless ( kill( 1, $proc->pid ) ) {
        $log->errorf( "could not signal process %d", $proc->pid );
        return 0;
    }
    $log->infof( "sent HUP to process %d", $proc->pid );
    usleep( $self->wait_for_hup_secs() * 1_000_000 );
    if ( $self->_wait_for_status( ACTIVE, 'restart', \$error_size_start ) ) {
        $log->info( $self->status_as_string() );
        if ( $self->validate_server() ) {
            $self->successful_start();
            return 1;
        }
        else {
            $self->_report_error_log_output($error_size_start);
        }
    }
    return 0;
}

sub stopstart {
    my ($self) = @_;

    if ( $self->is_running() ) {
        unless ( $self->stop() ) {
            $log->infof( "could not stop %s, will not attempt start",
                $self->description() );
            return 0;
        }
    }
    return $self->start();
}

sub refork {
    my ($self) = @_;

    my $proc = $self->_ensure_is_running() or return;
    my @child_pids = kill_children( $proc->pid );
    $log->debugf( "sent TERM to children of pid %d (%s)",
        $proc->pid, join( ", ", @child_pids ) )
      if $log->is_debug;
    $log->infof( "reforked %s", $self->description() );
    return @child_pids;
}

sub ping {
    my ($self) = @_;

    $log->info( $self->status_as_string() );
}

sub do_start {
    die "must be provided by subclass";
}

sub do_stop {
    my ( $self, $proc ) = @_;

    kill 15, $proc->pid;
}

sub status {
    my $self = shift;

    # Can pass in is_running() result, else we'll do it here
    my $is_running = (@_) ? shift(@_) : $self->is_running();
    return ( $is_running    ? RUNNING   : 0 ) |
      ( $self->is_listening ? LISTENING : 0 );
}

sub status_as_string {
    my ($self) = @_;

    my $port   = $self->port;
    my $proc   = $self->is_running();
    my $status = $self->status($proc);
    my $msg =
        ( $status == INACTIVE ) ? "is not running"
      : ( $status == RUNNING )
      ? sprintf( "appears to be running (pid %d), but not listening to port %d",
        $proc->pid, $port )
      : ( $status == LISTENING )
      ? sprintf( "pid file '%s' does not exist, but %s",
        $self->pid_file,
        something_is_listening_msg( $self->port, $self->bind_addr ) )
      : ( $status == ACTIVE )
      ? sprintf( "is running (pid %d) and listening to port %d",
        $proc->pid, $port )
      : die "invalid status: $status";
    return join( " ", $self->description(), $msg );
}

sub is_running {
    my ($self) = @_;

    my $pid_file = $self->pid_file();
    my $pid_contents = eval { read_file($pid_file) };
    if ($@) {
        $log->debugf( "pid file '%s' does not exist", $pid_file )
          if $log->is_debug && !$self->{_suppress_logs};
        return undef;
    }
    else {
        my ($pid) = ( $pid_contents =~ /^\s*(\d+)\s*$/ );
        unless ( defined($pid) ) {
            $log->infof( "pid file '%s' does not contain a valid process id!",
                $pid_file );
            $self->_handle_corrupt_pid_file();
            return undef;
        }

        my $ptable = process_table();
        if ( my ($proc) = grep { $_->pid == $pid } @{ $ptable->table } ) {
            $log->debugf( "pid file '%s' exists and has valid pid %d",
                $pid_file, $pid )
              if $log->is_debug && !$self->{_suppress_logs};
            return $proc;
        }
        else {
            if ( -f $pid_file ) {
                $log->infof(
                    "pid file '%s' contains a non-existing process id '%d'!",
                    $pid_file, $pid );
                $self->_handle_corrupt_pid_file();
                return undef;
            }
        }
    }
}

sub is_listening {
    my ($self) = @_;

    my $is_listening = is_port_active( $self->port(), $self->bind_addr() );
    if ( $log->is_debug ) {
        $log->debugf(
            "%s is listening to %s:%d",
            $is_listening ? "something" : "nothing",
            $self->bind_addr(), $self->port()
        ) if $log->is_debug && !$self->{_suppress_logs};
    }
    return $is_listening;
}

sub validate_server {
    my ($self) = @_;

    # Validate running server, in a server-specific way. By default just assume valid.
    #
    return 1;
}

sub run_system_command {
    my ( $self, $cmd ) = @_;

    if ( $self->use_sudo() ) {
        $cmd = "sudo $cmd";
    }
    $log->debug("running '$cmd'") if $log->is_debug;
    IPC::System::Simple::run($cmd);
}

sub valid_cli_actions {
    return qw(start stop restart ping hup stopstart refork);
}

my @save_argv;

sub handle_cli {
    my $class = shift;
    @save_argv = @ARGV if !@save_argv;

    # Allow caller to specify subclass with -c|--class and include paths with -I
    #
    my ( $subclass, @includes );
    $class->_cli_get_options(
        [ 'c|class=s' => \$subclass, 'I=s' => \@includes ],
        [ 'pass_through', 'no_ignore_case' ] );
    unshift( @INC, @includes );
    if ( defined $subclass ) {
        my $full_subclass =
            substr( $subclass, 0, 1 ) eq '+'
          ? substr( $subclass, 1 )
          : "Server::Control::$subclass";
        Class::MOP::load_class($full_subclass);
        return $full_subclass->handle_cli();
    }

    # Create object based on @ARGV options. Restore @ARGV afterwards, as
    # some subclasses need it, e.g. Net::Server needs @ARGV intact for HUP.
    #
    my $self = $class->new_with_options(@_);
    @ARGV = @save_argv;

    # Validate and perform specified action
    #
    $self->_perform_cli_action();
}

# This method and its helpers are modelled after MooseX::Getopt, which
# unfortunately I found both too flaky and not completely suited to my needs.
# If and when things improve, we can hopefully drop it in as a replacement.
#
sub new_with_options {
    my ( $class, %passed_params ) = @_;

    # Get params from command-line
    #
    my %option_pairs = $class->_cli_option_pairs();
    my %cli_params   = $class->_cli_parse_argv( \%option_pairs );

    # Start logging to stdout with appropriate log level
    #
    $class->_setup_cli_logging( \%cli_params );
    delete( @cli_params{qw(quiet verbose)} );

    # Combine passed and command-line params, pass to constructor
    #
    my %params = ( %passed_params, %cli_params );
    return $class->new_from_cli(%params);
}

# This method gives subclasses an opportunity to examine the full set
# of parameters (both specified on the cli passed to handle_cli) and issue
# a cli-specific error, before moving onto the regular constructor.
#
sub new_from_cli {
    my $class = shift;

    return $class->new(@_);
}

#
# PRIVATE METHODS
#

sub _start_error_log_watch {
    my ($self) = @_;

    return defined( $self->error_log ) ? ( -s $self->error_log() || 0 ) : 0;
}

sub _wait_for_status {
    my ( $self, $status, $action, $error_size_start ) = @_;

    # $error_size_start can be undef, a number, or a reference to a number.
    # In the last case we are expected to update it.
    my $error_size_start_ref =
      ( ref($error_size_start) ? $error_size_start : \$error_size_start );

    $log->infof("waiting for server $action");
    my $wait_until = time() + $self->wait_for_status_secs();
    my $poll_delay = $self->poll_for_status_secs() * 1_000_000;
    local $self->{_suppress_logs} = 1;    # Suppress logs during this loop
    while ( time() < $wait_until ) {
        if ( defined($$error_size_start_ref) ) {
            if ( $self->_report_error_log_output($$error_size_start_ref) ) {
                $$error_size_start_ref = $self->_start_error_log_watch();
            }
        }
        if ( $self->status == $status ) {
            return 1;
        }
        else {
            usleep($poll_delay);
        }
    }

    $log->warnf(
        "after %d secs, %s",
        $self->wait_for_status_secs(),
        $self->status_as_string()
    );
    return 0;
}

sub _report_error_log_output {
    my ( $self, $error_size_start ) = @_;

    if ( defined( my $error_log = $self->error_log() ) ) {
        if ( -f $error_log ) {
            my ( $fh, $buf );
            my $error_size_end = ( -s $error_log );
            if ( $error_size_end > $error_size_start ) {
                open( $fh, $error_log );
                seek( $fh, $error_size_start, 0 );
                read( $fh, $buf, $error_size_end - $error_size_start );
                my @lines = grep { /\S/ } split( "\n", $buf );
                foreach my $line (@lines) {
                    $log->infof( "error log: %s", $line );
                }
                return 1;
            }
        }
    }
    return 0;
}

sub _handle_corrupt_pid_file {
    my ($self) = @_;

    my $pid_file = $self->pid_file();
    $log->infof( "deleting bogus pid file '%s'", $pid_file );
    unlink $pid_file or die "cannot remove '$pid_file': $!";
}

sub _cli_parse_argv {
    my ( $class, $option_pairs ) = @_;

    my %cli_params;
    my @spec =
      map { $_ => \$cli_params{ $option_pairs->{$_} } } keys(%$option_pairs);
    $class->_cli_get_options( \@spec, ['no_ignore_case'] );
    %cli_params = slice_def( \%cli_params, keys(%cli_params) );

    $class->_cli_usage( "", 0 ) if !%cli_params;
    $class->_cli_usage( "", 1 ) if $cli_params{help};
    $class->_cli_usage("must specify -c|--class") if $class eq __PACKAGE__;

    return %cli_params;
}

sub _cli_get_options {
    my ( $class, $spec, $config ) = @_;

    my $parser = new Getopt::Long::Parser( config => $config );
    if ( !$parser->getoptions(@$spec) ) {
        $class->_cli_usage("");
    }
}

sub _cli_option_pairs {
    return (
        'bind-addr=s'            => 'bind_addr',
        'd|server-root=s'        => 'server_root',
        'error-log=s'            => 'error_log',
        'h|help'                 => 'help',
        'k|action=s'             => 'action',
        'log-dir=s'              => 'log_dir',
        'name=s'                 => 'name',
        'pid-file=s'             => 'pid_file',
        'port=s'                 => 'port',
        'q|quiet'                => 'quiet',
        'serverctlrc=s'          => 'serverctlrc',
        'use-sudo=s'             => 'use_sudo',
        'v|verbose'              => 'verbose',
        'wait-for-status-secs=s' => 'wait_for_status_secs',
    );
}

sub _setup_cli_logging {
    my ( $self, $cli_params ) = @_;

    my $log_level =
        $cli_params->{verbose} ? 'debug'
      : $cli_params->{quiet}   ? 'warning'
      :                          'info';
    my $dispatcher =
      Log::Dispatch->new( outputs =>
          [ [ 'Screen', stderr => 0, min_level => $log_level, newline => 1 ] ]
      );
    Log::Any->set_adapter( { category => qr/^Server::Control/ },
        'Dispatch', dispatcher => $dispatcher );
}

sub _perform_cli_action {
    my ($self) = @_;
    my $action = $self->action;

    if ( !defined $action ) {
        $self->_cli_usage("must specify -k");
    }
    elsif ( !grep { $_ eq $action } $self->valid_cli_actions ) {
        $self->_cli_usage(
            sprintf(
                "invalid action '%s' - valid actions are %s",
                $action,
                join( ", ",
                    ( map { "'$_'" } sort( $self->valid_cli_actions ) ) )
            )
        );
    }
    else {
        ( my $action_method = $action ) =~ s/\-/_/g;
        $self->$action_method();
    }
}

sub _cli_usage {
    my ( $class, $msg, $verbose ) = @_;

    $msg     ||= "";
    $verbose ||= 0;
    my $usage = Capture::Tiny::capture_merged {
        pod2usage( -msg => $msg, -verbose => $verbose, -exitval => "NOEXIT" );
    };
    if ( $usage !~ /\S/ ) {
        die "could not get usage from pod2usage for $0";
    }
    else {
        print STDERR $usage;
        exit(2);
    }
}

sub _ensure_is_running {
    my ($self) = @_;

    my $proc = $self->is_running();
    unless ($proc) {
        $log->warn( $self->status_as_string() );
    }
    return $proc;
}

sub _warn_if_different_user {
    my ( $self, $proc ) = @_;

    my ( $uid, $eid ) = ( $<, $> );
    if ( ( $eid || $uid ) && $proc->uid != $uid && !$self->use_sudo() ) {
        $log->warnf(
            "warning: process %d is owned by uid %d ('%s'), different than current user %d ('%s'); may not be able to stop server",
            $proc->pid,
            $proc->uid,
            scalar( getpwuid( $proc->uid ) ),
            $uid,
            scalar( getpwuid($uid) )
        );
    }
}

1;

__END__