590 lines
16 KiB
Perl
590 lines
16 KiB
Perl
package WebGUI::BackgroundProcess;
|
|
|
|
use warnings;
|
|
use strict;
|
|
|
|
use Config;
|
|
use POSIX;
|
|
use WebGUI::Session;
|
|
use WebGUI::Pluggable;
|
|
use JSON;
|
|
use Getopt::Long qw(GetOptionsFromArray);
|
|
use Time::HiRes qw(sleep);
|
|
|
|
=head1 NAME
|
|
|
|
WebGUI::BackgroundProcess
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Safely and portably spawn a long running process that you can check the
|
|
status of.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
package WebGUI::Some::Class;
|
|
|
|
sub doWork {
|
|
my ($process, $data) = @_;
|
|
$process->update("Starting...");
|
|
...
|
|
$process->update("About half way done...");
|
|
...
|
|
$process->update("Finished!");
|
|
}
|
|
|
|
sub www_doWork {
|
|
my $self = shift;
|
|
my $session = $self->session;
|
|
my $process = WebGUI::BackgroundProcess->start(
|
|
$session, 'WebGUI::Some::Class', 'doWork', { some => 'data' }
|
|
);
|
|
# See WebGUI::Content::BackgroundProcess
|
|
my $pairs = $process->contentPairs('DoWork');
|
|
$session->http->setRedirect($self->getUrl($pairs));
|
|
return 'redirect';
|
|
}
|
|
|
|
package WebGUI::Content::BackgroundProcess::DoWork;
|
|
|
|
sub handler {
|
|
my $process = shift;
|
|
my $session = $process->session;
|
|
return $session->style->userStyle($process->status);
|
|
|
|
# or better yet, an ajaxy page that polls.
|
|
}
|
|
|
|
|
|
=head1 LEGAL
|
|
|
|
-------------------------------------------------------------------
|
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
|
-------------------------------------------------------------------
|
|
Please read the legal notices (docs/legal.txt) and the license
|
|
(docs/license.txt) that came with this distribution before using
|
|
this software.
|
|
-------------------------------------------------------------------
|
|
http://www.plainblack.com info@plainblack.com
|
|
-------------------------------------------------------------------
|
|
|
|
=head1 METHODS
|
|
|
|
=cut
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 argv ($module, $subname, $data)
|
|
|
|
Produces an argv suitable for passing to exec (after the initial executable
|
|
name and perl switches) for running the given user routine with the supplied
|
|
data.
|
|
|
|
=cut
|
|
|
|
sub argv {
|
|
my ( $self, $module, $subname, $data ) = @_;
|
|
my $class = ref $self;
|
|
my $session = $self->session;
|
|
my $config = $session->config;
|
|
my $id = $self->getId;
|
|
return (
|
|
'--webguiRoot' => $config->getWebguiRoot,
|
|
'--configFile' => $config->getFilename,
|
|
'--sessionId' => $session->getId,
|
|
'--module' => $module,
|
|
'--subname' => $subname,
|
|
'--id' => $self->getId,
|
|
'--data' => JSON::encode_json($data),
|
|
);
|
|
} ## end sub argv
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 argvToHash ($argv)
|
|
|
|
Class method. Processes the passed array with GetOptions -- intended for use
|
|
from the exec() in start. Don't call unless you know what you're doing.
|
|
|
|
=cut
|
|
|
|
sub argvToHash {
|
|
my ( $class, $argv ) = @_;
|
|
my $hash = {};
|
|
GetOptionsFromArray( $argv, $hash,
|
|
'webguiRoot=s',
|
|
'configFile=s',
|
|
'sessionId=s',
|
|
'module=s',
|
|
'subname=s',
|
|
'id=s',
|
|
'data=s'
|
|
);
|
|
$hash->{data} = JSON::decode_json( $hash->{data} );
|
|
return $hash;
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 canView ($user?)
|
|
|
|
Returns whether the current user (or the user passed in, if there is one) has
|
|
permission to view the status of the background process. By default, only
|
|
admins can view, but see setGroup.
|
|
|
|
=cut
|
|
|
|
sub canView {
|
|
my $self = shift;
|
|
my $session = $self->session;
|
|
my $user = shift || $session->user;
|
|
$user = WebGUI::User->new( $session, $user )
|
|
unless eval { $user->isa('WebGUI::User') };
|
|
return 1 if $user->isAdmin;
|
|
my $group = $self->get('groupId');
|
|
return $group && $user->isInGroup($group);
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 contentPairs ($module, $pid)
|
|
|
|
Returns a bit of query string useful for redirecting to a
|
|
WebGUI::Content::BackgroundProcess plugin. $module should be the bit that
|
|
comes after WebGUI::Content::BackgroundProcess, e.g.
|
|
$process->contentPairs('Foo') should return something like
|
|
"op=background;module=Foo;pid=adlfjafo87ad9f78a7", which will get dispatched
|
|
to WebGUI::Content::BackgroundProcess::Foo::handler($process)
|
|
|
|
=cut
|
|
|
|
sub contentPairs {
|
|
my ( $self, $module ) = @_;
|
|
my $pid = $self->getId;
|
|
return "op=background;module=$module;pid=$pid";
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 create ( )
|
|
|
|
Creates a new BackgroundProcess object and inserts a blank row of data into
|
|
the db. You probably shouldn't call this -- see start().
|
|
|
|
=cut
|
|
|
|
sub create {
|
|
my ( $class, $session ) = @_;
|
|
my $id = $session->id->generate;
|
|
$session->db->setRow( $class->tableName, 'id', {}, $id );
|
|
bless { session => $session, id => $id };
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 delete ( )
|
|
|
|
Clean up the information for this process from the database.
|
|
|
|
=cut
|
|
|
|
sub delete {
|
|
my $self = shift;
|
|
my $db = $self->session->db;
|
|
my $tbl = $db->dbh->quote_identifier( $self->tableName );
|
|
$db->write( "DELETE FROM $tbl WHERE id = ?", [ $self->getId ] );
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 endTime ( )
|
|
|
|
Returns the epoch time indicating when the subroutine passed to run() finished
|
|
executing, or undef if it hasn't finished. Note that even if the sub passed
|
|
to run dies, an endTime will be recorded.
|
|
|
|
=cut
|
|
|
|
sub endTime { $_[0]->get('endTime') }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 error ( $msg )
|
|
|
|
Call this to record an error status. You probably shouldn't, though -- just
|
|
dying from your subroutine will cause this to be set.
|
|
|
|
=cut
|
|
|
|
sub error { $_[0]->set( { error => $_[1] } ) }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 finish ( )
|
|
|
|
Mark the process as being finished. This is called for you when your
|
|
subroutine is finished. If update() wasn't computed on the last call, it will
|
|
be computed now.
|
|
|
|
=cut
|
|
|
|
sub finish {
|
|
my $self = shift;
|
|
my %props = ( finished => 1 );
|
|
if ( my $calc = delete $self->{delay} ) {
|
|
$props{status} = $calc->();
|
|
$props{latch} = 0;
|
|
}
|
|
$props{endTime} = time();
|
|
$self->set( \%props );
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 get ( @keys )
|
|
|
|
Get data from the database record for this process (returned as a simple list,
|
|
not an arrayref). Valid keys are: id, status, error, startTime, endTime,
|
|
finished, groupId. They all have more specific accessors, but you can use
|
|
this to get several at once.
|
|
|
|
=cut
|
|
|
|
sub get {
|
|
my ( $self, @keys ) = @_;
|
|
my $db = $self->session->db;
|
|
my $dbh = $db->dbh;
|
|
my $tbl = $dbh->quote_identifier( $self->tableName );
|
|
my $key
|
|
= @keys
|
|
? join( ',', map { $dbh->quote_identifier($_) } @keys )
|
|
: '*';
|
|
my $id = $dbh->quote( $self->getId );
|
|
my @values = $db->quickArray("SELECT $key FROM $tbl WHERE id = $id");
|
|
return wantarray ? @values : $values[0];
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 getError ( )
|
|
|
|
If the process died, this will be set to stringified $@.
|
|
|
|
=cut
|
|
|
|
sub getError { $_[0]->get('error') }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 getGroupId
|
|
|
|
Returns the group ID (not the actual WebGUI::Group) of users who are allowed
|
|
to view this process.
|
|
|
|
=cut
|
|
|
|
sub getGroupId {
|
|
my $id = $_[0]->get('groupId');
|
|
return $id || 3;
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 getId ( )
|
|
|
|
The unique id for this background process. Note: this is NOT the pid, but a
|
|
WebGUI guid.
|
|
|
|
=cut
|
|
|
|
sub getId { shift->{id} }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 getStatus()
|
|
|
|
Signals the background process that it should report its next status, then
|
|
polls at $interval (can be fractional) seconds (default: .1) waiting for the
|
|
background process to claim that its status has been updated. Returns the
|
|
updated status. See setWait() for a way to change the interval (or disable
|
|
the waiting procedure entirely).
|
|
|
|
=cut
|
|
|
|
sub getStatus {
|
|
my $self = shift;
|
|
my $interval = $self->{interval};
|
|
if ($interval) {
|
|
$self->set( { latch => 1 } );
|
|
while (1) {
|
|
sleep $interval;
|
|
my ( $finished, $latch ) = $self->get( 'finished', 'latch' );
|
|
last if $finished || !$latch;
|
|
}
|
|
}
|
|
return $self->get('status');
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 isFinished ( )
|
|
|
|
A simple flag indicating that background process is no longer running.
|
|
|
|
=cut
|
|
|
|
sub isFinished { $_[0]->get('finished') }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 new ( $session, $id )
|
|
|
|
Returns an object capable of checking on the status of the background process
|
|
indicated by $id. Returns undef if there is no such process.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my ( $class, $session, $id ) = @_;
|
|
my $db = $session->db;
|
|
my $tbl = $db->dbh->quote_identifier( $class->tableName );
|
|
my $sql = "SELECT COUNT(*) FROM $tbl WHERE id = ?";
|
|
my $exists = $db->quickScalar( $sql, [$id] );
|
|
return $exists
|
|
? bless( { session => $session, id => $id, interval => .1 }, $class )
|
|
: undef;
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 session ()
|
|
|
|
Get the WebGUI::Session this process was created with. Note: this is safe to
|
|
call in the child process, as it is a duplicated session (same session id) and
|
|
doesn't share any handles with the parent process.
|
|
|
|
=cut
|
|
|
|
sub session { $_[0]->{session} }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 set ($properties)
|
|
|
|
Updates the database row with the properties given by the $properties hashref.
|
|
See get() for a list of valid keys.
|
|
|
|
=cut
|
|
|
|
sub set {
|
|
my ( $self, $values ) = @_;
|
|
my @keys = keys %$values;
|
|
return unless @keys;
|
|
|
|
my $db = $self->session->db;
|
|
my $dbh = $db->dbh;
|
|
my $tbl = $dbh->quote_identifier( $self->tableName );
|
|
my $sets = join(
|
|
',',
|
|
map {
|
|
my $ident = $dbh->quote_identifier($_);
|
|
my $value = $dbh->quote( $values->{$_} );
|
|
"$ident = $value";
|
|
} @keys
|
|
);
|
|
|
|
my $id = $dbh->quote( $self->getId );
|
|
$db->write("UPDATE $tbl SET $sets WHERE id = $id");
|
|
} ## end sub set
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 setGroup($groupId)
|
|
|
|
Allow the given group (in addition to admins) the ability to check on the
|
|
status of this process
|
|
|
|
=cut
|
|
|
|
sub setGroup {
|
|
my ( $self, $groupId ) = @_;
|
|
$groupId = eval { $groupId->getId } || $groupId;
|
|
$self->set( { groupId => $groupId } );
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 runCmd ($hashref)
|
|
|
|
Class method. Processes ARGV and passes it to runFromHash. Don't call this
|
|
unless you're the start() method.
|
|
|
|
=cut
|
|
|
|
sub runCmd {
|
|
my $class = shift;
|
|
$class->runFromHash( $class->argvToHash( \@ARGV ) );
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 runFromHash ($hashref)
|
|
|
|
Class method. Expects a hash of arguments describing what to run. Don't call
|
|
this unless you know what you're doing.
|
|
|
|
=cut
|
|
|
|
sub runFromHash {
|
|
my ( $class, $args ) = @_;
|
|
my $module = $args->{module};
|
|
WebGUI::Pluggable::load($module);
|
|
my $code = $module->can( $args->{subname} );
|
|
my $session = WebGUI::Session->open( $args->{webguiRoot}, $args->{configFile}, undef, undef, $args->{sessionId} );
|
|
|
|
my $self = $class->new( $session, $args->{id} );
|
|
$self->set( { startTime => time } );
|
|
eval { $self->$code( $args->{data} ) };
|
|
$self->error($@) if $@;
|
|
$self->finish();
|
|
}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 setWait ( $interval )
|
|
|
|
Use this to control the pace at which getStatus will poll for updated
|
|
statuses. By default, this is a tenth of a second. If you set it to 0,
|
|
getStatus will still signal the background process for an update, but will
|
|
take whatever is currently recorded as the status and return immediately.
|
|
|
|
=cut
|
|
|
|
sub setWait { $_[0]->{interval} = $_[1] }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 start ( $session, $module, $subname, $data )
|
|
|
|
Class method. The first thing this method does is daemonize (double-fork,
|
|
setsid, chdir /, umask 0, all that good stuff). It then executes
|
|
$module::subname in a fresh perl interpreter (exec'd $^X) with ($process,
|
|
$data) as its arguments. The only restriction on $data is that it be
|
|
serializable by JSON.
|
|
|
|
=head3 $0
|
|
|
|
The process name (as it appears in ps) will be set to webgui-background-$id,
|
|
where $id is the value returned by $process->getId. It thus won't look like a
|
|
modperl process to anyone monitoring the process table (wremonitor.pl, for
|
|
example).
|
|
|
|
=cut
|
|
|
|
sub start {
|
|
my ( $class, $session, $module, $subname, $data ) = @_;
|
|
my $self = $class->create($session);
|
|
my $id = $self->getId;
|
|
|
|
my $pid = fork();
|
|
die "Cannot fork: $!" unless defined $pid;
|
|
if ($pid) {
|
|
|
|
# The child process will fork again and exit immediately, so we can
|
|
# wait for it (and thus not have zombie processes).
|
|
waitpid( $pid, 0 );
|
|
|
|
return $self;
|
|
}
|
|
|
|
# We don't want destructors called, so POSIX exit on errors.
|
|
eval {
|
|
|
|
# detach from controlling terminal, get us into a new process group
|
|
die "Cannot become session leader: $!" if POSIX::setsid() < 0;
|
|
|
|
# Fork again so we never get a controlling terminal
|
|
$pid = fork();
|
|
die "Child cannot fork: $!" unless defined $pid;
|
|
|
|
# We don't want to call any destructors, as it would mess with the
|
|
# parent's mysql connection, etc.
|
|
POSIX::_exit(0) if $pid;
|
|
|
|
# We're now in the final target process. Standard daemon-y things...
|
|
$SIG{HUP} = 'IGNORE';
|
|
chdir '/';
|
|
umask 0;
|
|
|
|
# Forcibly close any open file descriptors that remain
|
|
my $max = POSIX::sysconf(&POSIX::_SC_OPEN_MAX) || 1024;
|
|
POSIX::close($_) for ( 0 .. $max );
|
|
|
|
# Get us some reasonable STD handles
|
|
my $null = '/dev/null';
|
|
open STDIN, '<', $null or die "Cannot read $null: $!";
|
|
open STDOUT, '>', $null or die "Cannot write $null: $!";
|
|
open STDERR, '>', $null or die "Cannot write $null: $!";
|
|
|
|
# Now we're ready to run the user's code.
|
|
my $perl = $Config{perlpath};
|
|
exec {$perl} (
|
|
"webgui-background-$id",
|
|
( map {"-I$_"} @INC ),
|
|
"-M$class", "-e$class->runCmd();",
|
|
'--', $self->argv( $module, $subname, $data )
|
|
) or POSIX::_exit(-1);
|
|
};
|
|
POSIX::_exit(-1) if ($@);
|
|
} ## end sub start
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 startTime ( )
|
|
|
|
Returns the time this process started running in epoch format.
|
|
|
|
=cut
|
|
|
|
sub startTime { $_[0]->get('startTime') }
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 tableName ( )
|
|
|
|
Class method: a constant, for convenience. The name of the table that process
|
|
data is stored in.
|
|
|
|
=cut
|
|
|
|
sub tableName {'BackgroundProcess'}
|
|
|
|
#-----------------------------------------------------------------
|
|
|
|
=head2 update ( $msg )
|
|
|
|
Set a new status for the background process. This can be anything, and will
|
|
overwrite the old status. JSON is recommended for complex statuses.
|
|
Optionally, $msg can be a subroutine that returns the new status -- if your
|
|
status may take a long time to compute, you should use this, as you may be
|
|
able to avoid computing some (or all) of your status updates, depending on how
|
|
often they're being asked for. See the getStatus method for details.
|
|
|
|
=cut
|
|
|
|
sub update {
|
|
my ( $self, $msg ) = @_;
|
|
if ( ref $msg eq 'CODE' ) {
|
|
if ( $self->get('latch') ) {
|
|
$msg = $msg->();
|
|
}
|
|
else {
|
|
$self->{delay} = $msg;
|
|
return;
|
|
}
|
|
}
|
|
delete $self->{delay};
|
|
$self->set( { latch => 0, status => $msg } );
|
|
}
|
|
|
|
1;
|