slashd

#!/usr/bin/perl -w
# This code is a part of Slash, and is released under the GPL.
# Copyright 1997-2003 by Open Source Development Network. See README
# and COPYING for more information, or see http://slashcode.com/.
# $Id$

############################################################
#
# slashd - the daemon that runs tasks from your site's "tasks"
# directory.  Which tasks are in this directory (probably
# /usr/local/slash/site/yoursitename/tasks) depends on which
# theme and plugins (if any) you installed with install-slashsite.
#
# If the times showing up in slashd.log are not the times you expect
# to see, it's because this script uses your database machine
# to decide when to run scripts, but the machine it runs on when
# logging timestamps.  This may help you notice unsynched clocks.
#
############################################################

use strict;
use Carp;
use Errno;
use File::Basename;
use File::Path;
use File::Spec::Functions;
use LWP::UserAgent;
use HTTP::Request;
use POSIX ':sys_wait_h';
use Time::Local;
use Time::HiRes;
use URI::Escape;
use XML::Parser::Expat;
use XML::RSS 0.95;
use Schedule::Cron;

use Slash;
use Slash::Constants ':slashd';
use Slash::Display;
use Slash::Utility;

use vars qw(
	%task %task_info $me
	$event_ar
	$cron
);

my $virtual_user = $ARGV[0];
createEnvironment($virtual_user);
my $constants = getCurrentStatic();
my $slashdb = getCurrentDB();
my $user = getCurrentUser();
my %pids = ( );

main();
exit 0;

############################################################
#
# Routines meant to be accessible from task scripts.
#
############################################################

# The standard log command.

sub slashdLog {
	my(@args) = @_;
	if ($pids{$$} && $pids{$$}{forktype} == SLASHD_NOWAIT) {
		# prepend script name if we are a child that is forked nowait
		$args[0] =~ s/^$pids{$$}{taskname}\s*//;
		$args[0] = "[$pids{$$}{taskname}] $args[0]";
	}
	doLog('slashd', \@args);
}

# log children ending
# We're polling this reaper function, instead of calling it from within
# a $SIG{CHLD} handler.  "if you're running in a loop, just arrange to
# call the reaper every so often.  This is the best approach because it
# isn't subject to the occasional core dump that signals can sometimes
# trigger in the C library." - Camel3, p. 416, and see also p. 413.
sub REAPER {
	return unless %pids;
	if (verbosity() >= 4) {
		my @pid_checklist = sort { $a <=> $b } keys %pids;
		slashdLog("REAPER in parent $$ begin: "
			. scalar(keys %pids) . " child(ren) potentially need reaping: @pid_checklist"
		);
	}
	while (my $pid = waitpid(-1, WNOHANG)) {
		if (verbosity() >= 4) {
			slashdLog("REAPER in parent $$ found reaped pid $pid");
		}
		last if $pid < 1;
		next if !exists $pids{$pid};
		my $status = $? >> 8;
		my $signal = $? & 127;
		my $taskname = $pids{$pid}{taskname};
		slashdLog("$taskname reaped ($pid)") if verbosity() >= 3;
		delete $pids{$pid};
		if ($status || $signal) {
			slashdLog(sprintf
				"%s odd exit (status %d, signal %d)",
				$taskname, $status, $signal
			);
		}
		insert_task_event($taskname, 0);
	}
	if (verbosity() >= 4) {
		my @pid_checklist = sort { $a <=> $b } keys %pids;
		slashdLog("REAPER in parent $$ done for now: "
			. scalar(keys %pids) . " child(ren) potentially need reaping"
			. (%pids ? ": @pid_checklist" : "")
		);
	}
}

# Log a warning and die.  Since slashd is meant to keep running
# long-term, this is meant for extreme circumstances such as a
# security violation;  normal warnings can go to slashdLog.

sub slashdLogDie {
	my $err = join(" ", @_);
	slashdLog($err);
	die $err;
}

# What time does the database think it is?  Our tasks are synched to
# that time, which may be different from the time that the machine
# we're running on thinks it is.
#
# We use two closure'd variables here and do a little dance just to
# avoid calling SELECT NOW() more than once every ten minutes.
# Not that it really matters, this optimization saves just about
# nothing, but there's just no need, clocks can't possibly drift
# anywere near that much.

{ my($last_db_time_offset, $last_db_time_confirm) = (undef, undef);
sub db_time {
	my $my_time = time;
	if (!$last_db_time_confirm
		or $my_time > $last_db_time_confirm + 600) {
		my $db_time = timeCalc($slashdb->getTime(), "%s", 0);
		$last_db_time_offset = $db_time - $my_time;
		$last_db_time_confirm = $my_time;
	}
	return $my_time + $last_db_time_offset;
} }

# Get the logging verbosity from the database.
#
# More closure and mini-caching, again to avoid querying the DB every
# single time we want to do something.

{ my($last_level, $last_level_confirm) = (undef, undef);
sub verbosity {
	my $my_time = time;
	if (!$last_level_confirm
		or $my_time > $last_level_confirm + 30) {
		my $new_level = $slashdb->getVar('slashd_verbosity', 'value');
		$new_level =~ /(\d+)/; $new_level = $1 || 2;
		if (defined($last_level) and $last_level != $new_level) {
			slashdLog("verbosity was $last_level, is $new_level");
		}
		$last_level = $new_level;
		$last_level_confirm = $my_time;
	}
	return $last_level;
} }

############################################################
#
# And now the internal routines (not that your script can't
# invoke them, but it probably won't need to).
#
############################################################

{ my $last_static_update = $^T;
sub update_static {
	my $my_time = time;
	my $changed = 0;
	if (!$last_static_update
		or $my_time > $last_static_update + 30) {
		my $old_panic = $constants->{panic} || 0;
		createCurrentStatic($slashdb->getSlashConf());
		$constants = getCurrentStatic();
		$last_static_update = $my_time;
		if ($old_panic != $constants->{panic}) {
			slashdLog("'panic' was $old_panic, is $constants->{panic}");
			init_event_ar();
			$changed = 1;
		}
	}
	return $changed;
} }

sub slashdLogInit {
	doLogInit('slashd');
}

sub init_cron {
	sub null_dispatcher { die "null_dispatcher called, there's a bug" }
	$cron = Schedule::Cron->new(\&null_dispatcher);
}

sub end_log {
	my($basename, $duration, $summary, $forktype) = @_;
	return if verbosity() < 1;
	my @log = ( );

	# secs_until can be negative;  that just means we're
	# behind and will execute the next task immediately to
	# try to catch up.
	my $secs_until = $event_ar->[0][1] - db_time();
	my $next_task = basename($event_ar->[0][0]);
	my $secs = verbosity() >= 2 ? 0 : -30;

	if ($forktype == SLASHD_LOG_NEXT_TASK) {
		push @log, "$basename forked";
	} else {
		push @log, "$basename end";
	}

	if ($forktype == SLASHD_WAIT) {
		push @log, " ($$)";
	}

	if ($forktype != SLASHD_LOG_NEXT_TASK) {
		push @log, " (${duration}s";
	}

	if ($forktype != SLASHD_NOWAIT) {
		# The child doesn't know what the next task is, if nowait
		push @log, ($secs_until < $secs)
			? "; $next_task "
				. -$secs_until
				. "s late"
			: verbosity() >= 2
				? "; $next_task in ${secs_until}s"
			: ();
	}

	if ($forktype != SLASHD_LOG_NEXT_TASK) {
		push @log, ")$summary";
	}
	slashdLog(join "", @log) if @log;
}

sub process_tasks {
	%task = ( );

	# "require" all the task files -- each will put its info into
	# $task{"filename.pl"}
	my %success = my %failure = ( );
	my $dir = catdir($constants->{datadir}, "tasks");
	if (!-e $dir or !-d _ or !-r _) {
		slashdLogDie(<<EOT);
could not process task files in $dir, missing or not readable to $>
EOT
	}

	# Go through the files and require them all.  Each file will
	# store its data and code in %task and execute any necessary
	# initialization.  We also do some rudimentary checks of whether
	# an attacker with guest access on this system could be feeding
	# us bad code (the better solution, of course, is not to let
	# attackers have local guest access).

	my $I_WANT_SLASHD_TO_BE_A_SILLY_LOCAL_SECURITY_HOLE = 0;
	if (not $I_WANT_SLASHD_TO_BE_A_SILLY_LOCAL_SECURITY_HOLE
		and (stat $dir)[2] & 002) {
		slashdLogDie("you really don't want me to use task files",
			"from a directory that's world-writable: $dir");
	}
	my @files =
		sort
		grep { -e $_ and -f _ and -r _ }
		glob "$dir/[a-zA-Z0-9_-][a-zA-Z0-9_-]*.pl";
	for my $fullname (@files) {
		if (not $I_WANT_SLASHD_TO_BE_A_SILLY_LOCAL_SECURITY_HOLE
			and (stat $fullname)[2] & 002) {
			slashdLogDie(<<EOT);
you really don't want me to use a task file that's world-writable: $fullname
EOT
		}
		my $file = basename($fullname);
		my $ok = 0;
		eval { local $me = $file; $ok = require $fullname; };
		if ($@) {
			slashdLog("requiring '$fullname' raised exception: $@");
			$ok = 0;
		}
		if ($!) {
			slashdLog("requiring '$fullname' caused error: $!");
			$ok = 0;
		}
		if (!defined($task{$file}{timespec})) {
			slashdLog("'$fullname' did not set timespec properly");
			$ok = 0;
		}
		if (!$task{$file}{code} or ref $task{$file}{code} ne 'CODE') {
			slashdLog("'$fullname' did not set code properly");
			$ok = 0;
		}
		# This may be rethought later, but for those useful tasks we 
		# MAY OR MAY NOT want to run on an automated AND/OR a manual
		# type basis: this allows the user to decide.
		if ($task{$file}{standalone}) {
			slashdLog("'$fullname' available via runtask, only!");
			$ok = 0;
		}
		if ($ok) {
			$success{$file} = 1;
		} else {
			delete $task{$file} if $task{$file};
			$failure{$file} = 1;
		}
	}

	# Log success and failure, and if no successes, abort with die()
	for my $task (keys %success) {
		$task =~ s/\.pl$//;
		$slashdb->createSlashdStatus($task);
	}
	slashdLog(
		"processed $dir; "
		. (scalar keys %success) . " successful"
		. (
			(scalar keys %success)
			?  " (" . join(" ", sort keys %success) . ")"
			: ""
		)
		. "; "
		. (scalar keys %failure) . " failed"
		. (
			(scalar keys %failure)
			?  " (" . join(" ", sort keys %failure) . ")"
			: ""
		)
	);
	slashdLogDie("aborting: no files successfully processed from $dir")
		if !%task;

	# The appropriate data is in $task{"filename.pl"} -- write it all into
	# the $cron object.

	$cron->clean_timetable;
	for my $file (sort keys %task) {
		$task{$file}{entry} = $cron->add_entry($task{$file}{timespec},
						       $task{$file}{code});
	}
	$cron->build_initial_queue;

}

# Create an initial array of events with their next-scheduled
# execution times.

sub init_event_ar {
	$event_ar = [ ];
	for my $file (sort keys %task) {
		my $immediate = $task{$file}{on_startup} ? 1 : 0;
		insert_task_event($file, $immediate);
	}
	if (verbosity() >= 2) {
		my $first_task = basename($event_ar->[0][0]);
		my $secs_until = $event_ar->[0][1] - db_time();
		slashdLog("first task will be $first_task in $secs_until secs");
	}
}

# Given a task's filename, returns the next time at which that task will
# run.  The optional third argument is a hashref in which the current
# database time is cached and where the next execution time and its file
# are stored (in case the caller cares).

sub calc_next_execution_time {
	my($file, $hr) = @_;
	$hr = { } if !$hr;
	$hr->{db_time} = db_time();
	my $timespec = $task{$file}{timespec};
	if ($constants->{panic} >= 1) {
		# Check for timespec_panic_n being defined, where n is
		# the current panic level or, if available, less.
		my $i = $constants->{panic};
		while ($i > 0) {
			if (defined($task{$file}{"timespec_panic_$i"})) {
				$timespec = $task{$file}{"timespec_panic_$i"};
				last;
			}
			--$i;
		}
	}

	my $entry_time;
	if ($timespec) {
		# Let Schedule::Cron determine the next execution time.
		$entry_time = $cron->get_next_execution_time($timespec,
			$hr->{db_time});
	} else {
		# "Never execute" if timespec (at least for this panic level)
		# is an empty string.  This will break on Jan. 18, 2038.
		$entry_time = 2**31-1;
	}
	if ($entry_time < $hr->{db_time}) {
		my $min_time = $hr->{min_time} || "none";
		slashdLog(<<EOT) if verbosity() >= 1;
error: entry_time in the past, check TZ ($entry_time < $hr->{db_time}) $file $timespec $min_time
EOT
		return undef;
	}
	if (!$hr->{min_time} or $entry_time < $hr->{min_time}) {
		$hr->{min_time} = $entry_time;
		$hr->{min_file} = $file;
	}
	$entry_time;
}

# Given a task filename, calculates its next execution time, and recreates
# the event array with that task scheduled for that time.  This happens
# to be always called when the task in question has already been popped
# off the front (current) end of the list, though this function will also
# happen to work if the task is already on the list for some reason.

sub insert_task_event {
	my($file, $immediate) = @_;
	my $event_hr = { };
	if (verbosity() >= 4) {
		slashdLog("insert_task_event called: '$file' '$immediate'");
	}

	# Convert the existing array into a hash.
	for my $file_num (0..$#$event_ar) {
		my($file, $until_time) = @{$event_ar->[$file_num]};
		$event_hr->{$file}{until_time} = $until_time;
	}

	# Add (or replace) the desired task into the hash.
	my $next_time;
	if ($immediate and $constants->{panic} < 1) {
		$next_time = db_time();
	} else {
		$next_time = calc_next_execution_time($file);
	}
	$event_hr->{$file}{until_time} = $next_time;
	if (verbosity() >= 4) {
		slashdLog("insert_task_event decided: '$file' next at "
			. scalar(localtime($next_time)));
	}

	# Rebuild the array in the proper order.
	$event_ar = [ ];
	my @files = sort {
		$event_hr->{$a}{until_time} <=> $event_hr->{$b}{until_time}
		||
		$a cmp $b
	} keys %$event_hr;
	for my $file (@files) {
		push @$event_ar, [ $file, $event_hr->{$file}{until_time} ];
		(my $file_nopl = $file) =~ s/\.pl//;
		my @u = gmtime($event_hr->{$file}{until_time});
		my $options = {
			next_begin => sprintf("%4d-%02d-%02d %02d:%02d:%02d",
				$u[5]+1900, $u[4]+1, $u[3],
				$u[2], $u[1], $u[0]
			)
		};
		$slashdb->setSlashdStatus($file_nopl, $options);
	}
}

sub wait_until_task {
	# The time we need to sleep until will stay at the front of the
	# event array.  However, it may change after every call to
	# REAPER(), because REAPER() calls insert_task_event().  As
	# soon as the current time exceeds the time at the front of the
	# event array, we're done, so we return that first task.
	my $max_sleep;
	my($task_filename, $until_time) = @{ $event_ar->[0] };
	WAIT_UNTIL: while ((my $cur_time = db_time()) < $until_time) {
		# If there are children waiting to be reaped, we loop
		# frequently to poll REAPER to look for them to die.
		# If not, there's no need to hit it frequently.
		$max_sleep = (%pids ? 2 : 300);
		my $sleep_total = $until_time - $cur_time;
		if ($sleep_total < 1) {
			$sleep_total = 1;
		} elsif ($sleep_total > $max_sleep) {
			$sleep_total = $max_sleep;
		}
		slashdLog(sprintf "Begin reap-and-sleep-for-%s-secs: %s < %s",
			$sleep_total,
			scalar(localtime($cur_time)),
			scalar(localtime($until_time)))
			if verbosity() >= 3;
		REAPER();
		# If the REAPER() call pushed a new event with a new
		# until_time onto the front of the event array, then
		# jump right back into this while loop without
		# sleeping at all (because the new event may trigger
		# sooner, even need to be triggered immediately).
		my $new_until_time = $event_ar->[0][1];
		if ($new_until_time != $until_time) {
			if (verbosity() >= 4) {
				slashdLog("REAPER() found new task,"
					. " cancelling sleep");
			}
			$until_time = $new_until_time;
			next WAIT_UNTIL;
		}
		# If not, do the sleep we planned to do.
		sleep $sleep_total;
	}
	slashdLog(sprintf "Finishing sleep: %s >= %s",
		scalar(localtime(db_time())),
		scalar(localtime($until_time)))
		if verbosity() >= 3;
}

sub main {

	# Initialize logging and all the low-level stuff.

	slashdLogInit();
	slashdLog("Starting up Slashd (verbosity " . verbosity()
		. ") with pid $$");
	if ($ENV{TZ} ne 'GMT') {
		slashdLog(join(" ",
			"Note: \$ENV{TZ}='$ENV{TZ}' not GMT, this may cause",
			"'entry_time in the past' errors; did you not start",
			"slashd with the init script?"
		));
	}

	# Initialize the scheduling stuff.

	%task_info = ( );
	init_cron();
	process_tasks();
	init_event_ar();

	# Here's the main event loop, which never returns (slashd is
	# typically ended with a SIGTERM from /etc/*/init.d/slash stop).

	$SIG{CHLD} = sub {
		# Logging is for debugging only!!  Almost anything you do
		# in a signal handler (including opening, printing to,
		# and closing a file, which slashdLog does) can call into
		# the C library which can (though it's unlikely) cause
		# coredumps and other bad stuff.  For more, see the
		# comment at the top of the REAPER function.
		# slashdLog("SIGCHLD called in $$")
		# NOTE: perl 5.8 has safe signals.
	};

	# daemonize
	close STDOUT;

	MAINLOOP: while (1) {
		if (verbosity() >= 4) {
			slashdLog("Beginning MAINLOOP");
		}

		# wait_until_task calls REAPER() periodically;  it will
		# return when there is a task that needs to be called.
		my $task_info = wait_until_task();

		# Recheck the vars table to reload $constants if necessary.
		# If it changed, this may alter our execution schedule, so
		# repeat the loop from the top.
		if (update_static()) {
			next MAINLOOP;
		}

		# Get the information about the task at the front of the
		# event array.
                my($task_filename, $until_time) = @{ shift @$event_ar };
                my $basename = basename($task_filename);
                (my $basename_nopl = $basename) =~ s/\.pl$//;
                my $subref = $task{$task_filename}{code};
                my $forktype = SLASHD_WAIT; # the default
                $forktype = SLASHD_NOWAIT
                        if $task{$task_filename}{fork} == SLASHD_NOWAIT;

		# Execute it.

		$slashdb->setSlashdStatus($basename_nopl, {
			-in_progress	=> 'in_progress+1',
			task		=> $basename_nopl,
		});
		my $start_time = Time::HiRes::time;

		my $args = {
			basename	=> $basename,
			basename_nopl	=> $basename_nopl,
			forktype	=> $forktype,
			subref		=> $subref,
			start_time	=> $start_time,
			task_filename	=> $task_filename,
			invocation_num	=> $task_info{$task_filename}{invocations} || 0
		};

		REAPER();

		local $me = $basename;

		# kill the dbh, we have too many problems
		# if it sticks around during a fork -- pudge
		$slashdb->{_dbh}->disconnect;
		undef $slashdb->{_dbh};

		FORK: {
			$args->{pid} = my $pid = fork();

			# Parent and child now separately reconnect.
			$slashdb->sqlConnect();

			if ($pid) {
				next MAINLOOP if !do_parent($args);
			} elsif (defined $pid) {
				do_child($args);
				# should never reach here, do_child exits
			} elsif ($!{EAGAIN}) {
				# Recoverable fork error.
				sleep 1;
				redo FORK;
			} else {
				# "Weird fork error," says Camel3 p. 715.
				slashdLog("Error: cannot fork '$me': $!");

				# current task is *not* added back into
				# event array if we get here, it is lost
				# until slashd restarts -- pudge
				# if weird forks stalk the land, we must
				# expect casualties -- jamie
				next MAINLOOP;
			}
		}

		# Sleep for at least a few seconds between tasks.
		if (verbosity() >= 4) {
			slashdLog("Ending MAINLOOP");
		}
		sleep 2;
		$task_info{$task_filename}{invocations}++;

	}
}

sub do_parent {
	my($args) = @_;
	my($pid, $basename, $forktype) =
		@{$args}{qw(pid basename forktype)};

	# some later call to REAPER will
	# reap and delete this hash field
	$pids{$pid} = {
		taskname	=> $basename,
		forktype	=> $forktype,
		dead		=> 0,
	};

	if ($forktype == SLASHD_NOWAIT) {
		# log when next task is running
		end_log($basename, 0, "", SLASHD_LOG_NEXT_TASK);
		if (verbosity() >= 4) {
			slashdLog("Parent $$: sleep for 2 seconds after fork()");
		}

		sleep 2;

		if (verbosity() >= 4) {
			slashdLog("Parent $$: slept for 2 seconds after fork()");
		}

	} elsif ($forktype == SLASHD_WAIT) {
		if (verbosity() >= 4) {
			slashdLog("Parent $$: sleep and wait after fork()");
		}

		# wait for REAPER to reap and delete this hash field
		while (exists $pids{$pid}) {
			REAPER();
			sleep 1;
		}

		if (verbosity() >= 4) {
			slashdLog("Parent $$: slept and waited after fork()");
		}

	} else {
		slashdLog("unexpected value of \$forktype: $forktype");
		return 0;
	}

	return 1;
}


sub do_child {
	my($args) = @_;
	my($basename, $forktype, $subref, $basename_nopl,
		$start_time, $invocation_num) =
		@{$args}{qw(basename forktype subref basename_nopl
		start_time invocation_num)};

	# In doLogPid we set a handler for these that deletes the slashd.pid
	# file;  children don't have the right to do that.
	$SIG{TERM} = $SIG{INT} = 'DEFAULT';

	# Children may use system(), backticks, or open() pipes, all of which
	# end up invoking CHLD handlers.  Don't call the parent's CHLD handler
	# -- whatever it may be, it's inappropriate for the child.  The default
	# action for SIGCHLD is to ignore it.
	$SIG{CHLD} = 'DEFAULT';

	if (verbosity() >= 4) {
		slashdLog("Child $$ [$me]: sleep for 2 seconds after fork()");
	}

	$pids{$$} = {
		taskname	=> $basename,
		forktype	=> $forktype
	};

	# have STDERR passed through slashdLog
	tie *STDERR, 'Slash::Tie::STDERR' if $forktype == SLASHD_NOWAIT;

	# Give the parent a chance to get into its REAPER loop.  This
	# shouldn't be necessary now that the parent is not using $SIG{CHLD}
	# to handle reaping child processes, but it still isn't a bad idea.
	sleep 2;
	slashdLog("$basename begin ($$)") if verbosity() >= 2;

	if (verbosity() >= 4) {
		slashdLog("Child $$: slept for 2 seconds after fork()");
	}

	my $info = {
		invocation_num => $invocation_num,
	};
	if (verbosity() >= 4) {
		slashdLog("invocation_num $info->{invocation_num}");
	}
	my $summary = $subref->($virtual_user, $constants, $slashdb, $user,
		$info);

	my $end_time = Time::HiRes::time;
	my $duration = sprintf("%.2f", $end_time - $start_time);

	# If desired, log that it's done (to disk logfile and into the DB).
	$summary = "" if !$summary;
	$summary =~ s/\s+/ /g; chomp $summary;
	$summary = ": $summary" if $summary;
	end_log($basename, $duration, $summary, $forktype);

	(my $summary_trim = $summary) =~ s/^:\s*//;
	$slashdb->setSlashdStatus($basename_nopl, {
		-last_completed	=> "NOW()",
		summary		=> $summary_trim,
		duration	=> $duration,
		-in_progress	=> 'GREATEST(in_progress-1, 0)',
	});

	if (verbosity() >= 4) {
		slashdLog("Child $$ exits here");
	}

	# Child must not drop out of this subroutine.
	exit;
}


package Slash::Tie::STDERR;
use Symbol 'gensym';
use base 'Tie::Handle';

sub TIEHANDLE {
	my $class = shift;
	my $fh    = gensym();
	bless $fh, $class;
	return $fh;
}

sub PRINT {
	my($fh, @args) = @_;
	main::slashdLog(@args);
}

sub PRINTF {
	my($fh, $format, @args) = @_;
	main::slashdLog(sprintf($format, @args));
}

1;