From 79de38dc4af2cc5ad95dd7d79792d6f7340c18d2 Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Mon, 20 Sep 2010 11:45:21 -0700 Subject: [PATCH] WebGUI::BackgroundProcess (used now by AssetExport) --- docs/upgrades/upgrade_7.10.1-7.10.2.pl | 45 +- lib/WebGUI/AssetExportHtml.pm | 176 ++++-- lib/WebGUI/BackgroundProcess.pm | 590 ++++++++++++++++++ lib/WebGUI/BackgroundProcess/AssetExport.pm | 173 +++++ lib/WebGUI/BackgroundProcess/Status.pm | 84 +++ lib/WebGUI/Operation.pm | 1 + lib/WebGUI/Operation/BackgroundProcess.pm | 74 +++ .../Activity/RemoveOldBackgroundProcesses.pm | 82 +++ ...w_Activity_RemoveOldBackgroundProcesses.pm | 20 + t/BackgroundProcess.t | 87 +++ t/lib/WebGUI/Test/BackgroundProcess.pm | 20 + 11 files changed, 1309 insertions(+), 43 deletions(-) create mode 100644 lib/WebGUI/BackgroundProcess.pm create mode 100644 lib/WebGUI/BackgroundProcess/AssetExport.pm create mode 100644 lib/WebGUI/BackgroundProcess/Status.pm create mode 100644 lib/WebGUI/Operation/BackgroundProcess.pm create mode 100644 lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm create mode 100644 lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm create mode 100644 t/BackgroundProcess.t create mode 100644 t/lib/WebGUI/Test/BackgroundProcess.pm diff --git a/docs/upgrades/upgrade_7.10.1-7.10.2.pl b/docs/upgrades/upgrade_7.10.1-7.10.2.pl index d2f49d9fc..9f4bb75c6 100644 --- a/docs/upgrades/upgrade_7.10.1-7.10.2.pl +++ b/docs/upgrades/upgrade_7.10.1-7.10.2.pl @@ -22,7 +22,7 @@ use Getopt::Long; use WebGUI::Session; use WebGUI::Storage; use WebGUI::Asset; - +use List::Util qw(first); my $toVersion = '7.10.2'; my $quiet; # this line required @@ -31,9 +31,52 @@ my $quiet; # this line required my $session = start(); # this line required # upgrade functions go here +addBackgroundProcessTable($session); +installBackgroundProcessCleanup($session); finish($session); # this line required +#---------------------------------------------------------------------------- +# Creates a new table for tracking background processes +sub addBackgroundProcessTable { + my $session = shift; + my $db = $session->db; + my $sth = $db->dbh->table_info('', '', 'BackgroundProcess', 'TABLE'); + return if ($sth->fetch); + print "\tAdding BackgroundProcess table..." unless $quiet; + my $sql = q{ + CREATE TABLE BackgroundProcess ( + id CHAR(22), + groupId CHAR(22), + status LONGTEXT, + error TEXT, + startTime BIGINT(20), + endTime BIGINT(20), + finished BOOLEAN DEFAULT FALSE, + latch BOOLEAN DEFAULT FALSE, + + PRIMARY KEY(id) + ); + }; + $db->write($sql); + print "DONE!\n" unless $quiet; +} + +#---------------------------------------------------------------------------- +# install a workflow to clean up old background processes +sub installBackgroundProcessCleanup { + my $session = shift; + print "\tInstalling Background Process Cleanup workflow..." unless $quiet; + my $class = 'WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses'; + $session->config->addToArray('workflowActivities/None', $class); + my $wf = WebGUI::Workflow->new($session, 'pbworkflow000000000001'); + my $a = first { ref $_ eq $class } @{ $wf->getActivities }; + unless ($a) { + $a = $wf->addActivity($class); + $a->set(title => 'Remove Old Background Processes'); + }; + print "DONE!\n" unless $quiet; +} #---------------------------------------------------------------------------- # Describe what our function does diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm index edc634760..f5673f7db 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -23,7 +23,7 @@ use WebGUI::Exception; use WebGUI::Utility (); use WebGUI::Session; use URI::URL; -use Scope::Guard; +use Scope::Guard qw(guard); =head1 NAME @@ -304,21 +304,53 @@ sub exportAsHtml { } sub exportBranch { - my $self = shift; - my $options = shift; - my $reportSession = shift; + my ($self, $options, $reportSession) = @_; + my $i18n = $reportSession && + WebGUI::International->new($self->session, 'Asset'); my $depth = $options->{depth}; my $indexFileName = $options->{indexFileName}; my $extrasUploadAction = $options->{extrasUploadAction}; my $rootUrlAction = $options->{rootUrlAction}; - my $exportedCount = 0; + my $report = $options->{report}; - my $i18n; - if ( $reportSession ) { - $i18n = WebGUI::International->new($self->session, 'Asset'); + unless ($report) { + if ($reportSession) { + # We got a report session and no report coderef, so we'll print + # messages out. NOTE: this is for backcompat, but I'm not sure we + # even need it any more. I think the only thing using it was the + # old iframe-based export status report. --frodwith + my %reports = ( + 'bad user privileges' => sub { + my $asset = shift; + my $url = $asset->getUrl; + $i18n->get('bad user privileges') . "\n$url" + }, + 'not exportable' => sub { + my $asset = shift; + my $fullPath = $asset->exportGetUrlAsPath; + "$fullPath skipped, not exportable
"; + }, + 'exporting page' => sub { + my $asset = shift; + my $fullPath = $asset->exportGetUrlAsPath; + sprintf $i18n->get('exporting page'), $fullPath; + }, + 'collateral notes' => sub { pop }, + 'done' => sub { $i18n->get('done') }, + ); + $report = sub { + my ($asset, $key, @args) = @_; + my $code = $reports{$key}; + my $message = $asset->$code(); + $reportSession->output->print($message, @args); + }; + } + else { + $report = sub {}; + } } - + my $exportedCount = 0; my $exportAsset = sub { my ( $assetId ) = @_; @@ -335,26 +367,18 @@ sub exportBranch { # skip this asset if we can't view it as this user. unless( $asset->canView ) { - if( $reportSession ) { - my $message = sprintf( $i18n->get('bad user privileges') . "\n") . $asset->getUrl; - $reportSession->output->print($message); - } + $asset->$report('bad user privileges'); next; } # skip this asset if it's not exportable. unless ( $asset->exportCheckExportable ) { - if ( $reportSession ) { - $reportSession->output->print("$fullPath skipped, not exportable
"); - } + $asset->$report('not exportable'); next; } # tell the user which asset we're exporting. - if ( $reportSession ) { - my $message = sprintf $i18n->get('exporting page'), $fullPath; - $reportSession->output->print($message); - } + $asset->$report('exporting page'); # try to write the file eval { $asset->exportWriteFile }; @@ -364,9 +388,25 @@ sub exportBranch { # next, tell the asset that we're exporting, so that it can export any # of its collateral or other extra data. - eval { $asset->exportAssetCollateral($asset->exportGetUrlAsPath, $options, $reportSession) }; - if($@) { - WebGUI::Error->throw(error => "failed to export asset collateral for URL " . $asset->getUrl . ": $@"); + { + # For backcompat we want to capture anything that + # exportAssetCollateral may have printed and report it to the + # coderef. We should get rid of this as soon as we're ready to + # break that api. + my $cs = $self->session->duplicate(); + open my $handle, '>', \my $output; + $cs->output->setHandle($handle); + my $guard = guard { + close $handle; + $cs->var->end; + $cs->close(); + $asset->$report('collateral notes', $output); + }; + my $path = $asset->exportGetUrlAsPath; + eval { $asset->exportAssetCollateral($path, $options, $cs) }; + if($@) { + WebGUI::Error->throw(error => "failed to export asset collateral for URL " . $asset->getUrl . ": $@"); + } } # we exported this one successfully, so count it @@ -376,19 +416,12 @@ sub exportBranch { $self->session->db->write( "UPDATE asset SET lastExportedAs = ? WHERE assetId = ?", [ $fullPath, $asset->getId ] ); - $self->updateHistory("exported"); + $asset->updateHistory('exported'); # tell the user we did this asset correctly - if ( $reportSession ) { - $reportSession->output->print($i18n->get('done')); - } - - #use Devel::Cycle; - #warn "CHECKING on " . ref( $asset ) . ' ID: ' . $asset->getId . "\n"; - #find_cycle( $asset ); + $asset->$report('done'); }; - my $assetIds = $self->exportGetDescendants(undef, $depth); foreach my $assetId ( @{$assetIds} ) { $exportAsset->( $assetId ); @@ -625,6 +658,57 @@ sub exportGetUrlAsPath { #------------------------------------------------------------------- +=head2 exportInBackground + +Intended to be called by WebGUI::BackgroundProcess. Runs exportAsHtml on the +specified asset and keeps a json structure as the status. + +=cut + +sub exportInBackground { + my ($process, $args) = @_; + my $self = WebGUI::Asset->new($process->session, delete $args->{assetId}); + $args->{indexFileName} = delete $args->{index}; + my %flat; + + my $hashify; $hashify = sub { + my ($asset, $depth) = @_; + return if $depth < 1; + my $hash = { url => $asset->getUrl }; + my $children = $asset->getLineage(['children'], { returnObjects => 1 }); + $hash->{children} = [ map { $hashify->($_, $depth - 1) } @$children ]; + $flat{$asset->getId} = $hash; + return $hash; + }; + my $tree = $hashify->($self, $args->{depth}); + my $last = $tree; + my %reports = ( + 'bad user privileges' => sub { shift->{badUserPrivileges} = 1 }, + 'not exportable' => sub { shift->{notExportable} = 1 }, + 'exporting page' => sub { shift->{current} = 1 }, + 'done' => sub { + my $hash = shift; + delete $last->{current}; + $last = $hash; + $hash->{done} = 1; + }, + 'collateral notes' => sub { + my ($hash, $text) = @_; + $hash->{collateralNotes} = $text if $text; + }, + ); + $args->{report} = sub { + my ($asset, $key, @args) = @_; + my $code = $reports{$key}; + my $hash = $flat{$asset->getId}; + $code->($hash, @args); + $process->update(sub { JSON::encode_json($tree) }); + }; + $self->exportAsHtml($args); +} + +#------------------------------------------------------------------- + =head2 exportSymlinkExtrasUploads ( [ session ] ) Class or object method. Sets up the extras and uploads symlinks. @@ -935,16 +1019,24 @@ Displays the export status page =cut sub www_exportStatus { - my $self = shift; - return $self->session->privilege->insufficient() unless ($self->session->user->isInGroup(13)); - my $i18n = WebGUI::International->new($self->session, "Asset"); - my $iframeUrl = $self->getUrl('func=exportGenerate'); - foreach my $formVar (qw/index depth userId extrasUploadsAction rootUrlAction exportUrl/) { - $iframeUrl = $self->session->url->append($iframeUrl, $formVar . '=' . $self->session->form->process($formVar)); - } - - my $output = ''; - $self->getAdminConsole->render($output, $i18n->get('Page Export Status'), "Asset"); + my $self = shift; + my $session = $self->session; + return $session->privilege->insufficient + unless $session->user->isInGroup(13); + my $form = $session->form; + my @vars = qw( + index depth userId extrasUploadsAction rootUrlAction exportUrl + ); + my $process = WebGUI::BackgroundProcess->start( + $session, 'WebGUI::Asset', 'exportInBackground', { + assetId => $self->getId, + map { $_ => scalar $form->get($_) } @vars + } + ); + $process->setGroup(13); + my $pairs = $process->contentPairs('AssetExport'); + $session->http->setRedirect($self->getUrl($pairs)); + return 'redirect'; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/BackgroundProcess.pm b/lib/WebGUI/BackgroundProcess.pm new file mode 100644 index 000000000..25f02f141 --- /dev/null +++ b/lib/WebGUI/BackgroundProcess.pm @@ -0,0 +1,590 @@ +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; diff --git a/lib/WebGUI/BackgroundProcess/AssetExport.pm b/lib/WebGUI/BackgroundProcess/AssetExport.pm new file mode 100644 index 000000000..e3b5f7ffe --- /dev/null +++ b/lib/WebGUI/BackgroundProcess/AssetExport.pm @@ -0,0 +1,173 @@ +package WebGUI::BackgroundProcess::AssetExport; + +=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 + ------------------------------------------------------------------- + +=cut + +use strict; +use warnings; + +=head1 NAME + +WebGUI::BackgroundProcess::AssetExport + +=head1 DESCRIPTION + +Renders an admin console page that polls ::Status to draw a friendly graphical +representation of how an export is coming along. + +=head1 SUBROUTINES + +These subroutines are available from this package: + +=cut + +use Template; + +my $template = <<'TEMPLATE'; +

+Currently exporting +(/).
+ seconds elapsed. +

+ +[% MACRO yui(file) BLOCK %] + +[% END %] +[% yui("yahoo/yahoo-min.js") %] +[% yui("json/json-min.js") %] +[% yui("event/event-min.js") %] +[% yui("connection/connection_core-min.js") %] + +TEMPLATE + +my $stylesheet = <<'STYLESHEET'; + +STYLESHEET + +#------------------------------------------------------------------- + +=head2 handler ( process ) + +See WebGUI::Operation::BackgroundProcess. + +=cut + +sub handler { + my $process = shift; + my $session = $process->session; + my $url = $session->url; + my $tt = Template->new( { INTERPOLATE => 1 } ); + my %vars = ( + statusUrl => $url->page( $process->contentPairs('Status') ), + extras => $session->url->extras, + ); + $tt->process( \$template, \%vars, \my $content ) or die $tt->error; + + my $console = WebGUI::AdminConsole->new( $process->session, 'assets' ); + $session->style->setRawHeadTags($stylesheet); + my $i18n = WebGUI::International->new( $session, 'Asset' ); + return $console->render( $content, $i18n->get('Page Export Status') ); +} ## end sub handler + +1; diff --git a/lib/WebGUI/BackgroundProcess/Status.pm b/lib/WebGUI/BackgroundProcess/Status.pm new file mode 100644 index 000000000..fba674a9d --- /dev/null +++ b/lib/WebGUI/BackgroundProcess/Status.pm @@ -0,0 +1,84 @@ +package WebGUI::BackgroundProcess::Status; + +use JSON; + +=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 + ------------------------------------------------------------------- + +=cut + +use strict; +use warnings; + +=head1 NAME + +WebGUI::BackgroundProcess::Status + +=head1 DESCRIPTION + +Returns a json response of the following form: + + { + "finished" : true, + "elapsed" : 10, + "status" : "whatever is in the status field. Could be anything.", + "error" : "whatever is in the error field" + } + +Note that if your status is JSON, you'll have to decode that seperately, so +something like: + + decoded = JSON.parse(r.responseText); + status = JSON.parse(decoded.status); + +Finished is obviously true or false. Notably, it will be true in the error +case: so to status.finished && !status.error means successful completion. +Error will only be present if the process died for some reason. + +Status will always be present, mostly so you can see what the last status was +before it died. + +Elapsed will be the number of seconds since the process started (or until the +process finished, if it is finished). + +=head1 SUBROUTINES + +These subroutines are available from this package: + +=cut + +#------------------------------------------------------------------- + +=head2 handler ( process ) + +See the synopsis for what kind of response this generates. + +=cut + +sub handler { + my $process = shift; + my $status = $process->getStatus; + my ( $finished, $startTime, $endTime, $error ) = $process->get( 'finished', 'startTime', 'endTime', 'error' ); + + $endTime = time() unless $finished; + + my %status = ( + status => $status, + elapsed => ( $endTime - $startTime ), + finished => ( $finished ? \1 : \0 ), + ); + $status{error} = $error if $finished; + $process->session->http->setMimeType('text/plain'); + JSON::encode_json( \%status ); +} ## end sub handler + +1; diff --git a/lib/WebGUI/Operation.pm b/lib/WebGUI/Operation.pm index 4c102fb75..444582270 100644 --- a/lib/WebGUI/Operation.pm +++ b/lib/WebGUI/Operation.pm @@ -76,6 +76,7 @@ Returns a hash reference containing operation and package names. sub getOperations { return { + 'background' => 'BackgroundProcess', 'killSession' => 'ActiveSessions', 'viewActiveSessions' => 'ActiveSessions', diff --git a/lib/WebGUI/Operation/BackgroundProcess.pm b/lib/WebGUI/Operation/BackgroundProcess.pm new file mode 100644 index 000000000..ec2e2bf37 --- /dev/null +++ b/lib/WebGUI/Operation/BackgroundProcess.pm @@ -0,0 +1,74 @@ +package WebGUI::Operation::BackgroundProcess; + +=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 + ------------------------------------------------------------------- + +=cut + +use strict; +use warnings; + +use WebGUI::BackgroundProcess; +use WebGUI::Pluggable; + +=head1 NAME + +WebGUI::Operation::BackgroundProcess + +=head1 DESCRIPTION + +URL dispatching for WebGUI::BackgroundProcess monitoring + +=head1 SUBROUTINES + +These subroutines are available from this package: + +=cut + +#------------------------------------------------------------------- + +=head2 handler ( session ) + +Dispatches to the proper module based on the module form parameter if op is +background. Returns insufficient privilege page if the user doesn't pass +canView on the process before dispatching. + +=cut + +sub www_background { + my $session = shift; + my $form = $session->form; + my $module = $form->get('module') || 'Status'; + my $pid = $form->get('pid') || return undef; + + my $process = WebGUI::BackgroundProcess->new( $session, $pid ); + + return $session->privilege->insufficient unless $process->canView; + + my $log = $session->log; + + unless ($process) { + $log->error("Tried to get info for nonexistent process $pid"); + return undef; + } + + my $output = eval { WebGUI::Pluggable::run( "WebGUI::BackgroundProcess::$module", 'handler', [$process] ); }; + + if ($@) { + $log->error($@); + return undef; + } + + return $output; +} ## end sub www_background + +1; diff --git a/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm b/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm new file mode 100644 index 000000000..fd06e118a --- /dev/null +++ b/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm @@ -0,0 +1,82 @@ +package WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses; + +=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 + ------------------------------------------------------------------- + +=cut + +use warnings; +use strict; + +use base 'WebGUI::Workflow::Activity'; + +use WebGUI::International; +use WebGUI::BackgroundProcess; + +=head1 NAME + +WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses + +=head1 DESCRIPTION + +Remove background processes that are older than a configurable threshold. + +=head1 METHODS + +These methods are available from this class: + +=cut + +#------------------------------------------------------------------- + +=head2 definition ( session, definition ) + +See WebGUI::Workflow::Activity::definition() for details. + +=cut + +sub definition { + my ( $class, $session, $definition ) = @_; + my $i18n = WebGUI::International->new( $session, 'Workflow_Activity_RemoveOldBackgroundProcesses' ); + my %def = ( + name => $i18n->get('activityName'), + properties => { + interval => { + fieldType => 'interval', + label => $i18n->get('interval'), + defaultValue => 60 * 60 * 24 * 7, + hoverHelp => $i18n->get('interval help') + } + } + ); + push @$definition, \%def; + return $class->SUPER::definition( $session, $definition ); +} ## end sub definition + +#------------------------------------------------------------------- + +=head2 execute ( [ object ] ) + +See WebGUI::Workflow::Activity::execute() for details. + +=cut + +sub execute { + my $self = shift; + my $db = $self->session->db; + my $tbl = $db->dbh->quote_identifier( WebGUI::BackgroundProcess->tableName ); + my $time = time - $self->get('interval'); + $db->write( "DELETE FROM $tbl WHERE endTime <= ?", [$time] ); + return $self->COMPLETE; +} + +1; diff --git a/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm b/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm new file mode 100644 index 000000000..01ee9fc03 --- /dev/null +++ b/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm @@ -0,0 +1,20 @@ +package WebGUI::i18n::English::Workflow_Activity_RemoveOldBackgroundProcesses; + +use strict; + +our $I18N = { + 'interval help' => { + message => 'How long do we wait after process completion before deleting it?', + lastUpdated => 1285358250, + }, + 'interval' => { + message => q|Interval|, + lastUpdated => 1285358250, + }, + 'activityName' => { + message => q|Remove Old Background Processes|, + lastUpdated => 1285358250, + }, +}; + +1; diff --git a/t/BackgroundProcess.t b/t/BackgroundProcess.t new file mode 100644 index 000000000..7cb332fe0 --- /dev/null +++ b/t/BackgroundProcess.t @@ -0,0 +1,87 @@ +# vim:syntax=perl +#------------------------------------------------------------------- +# 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 +#------------------------------------------------------------------ + +# WebGUI::BackgroundProcess tests + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; + +use Test::More; +use Test::Deep; +use Data::Dumper; +use JSON; + +use WebGUI::Test; +use WebGUI::Session; +use WebGUI::BackgroundProcess; + +my $session = WebGUI::Test->session; +my $class = 'WebGUI::BackgroundProcess'; +my $testClass = 'WebGUI::Test::BackgroundProcess'; + +# test simplest (non-forking) case + +my $process = $class->create($session); +my @argv = $process->argv( $testClass, 'simple', ['data'] ); +my $hash = $class->argvToHash( \@argv ); + +is ref $hash, 'HASH', 'got hash from argv'; +cmp_bag( + [ keys %$hash ], + [ qw(webguiRoot configFile sessionId id module subname data) ], + 'argvToHash has the right keys' +); + +my $now = time; + +$class->runFromHash($hash); +ok $process->isFinished, 'finished'; +my $error = $process->getError; +ok( !$error, 'no errors' ) or diag " Expected nothing, got: $error\n"; +$process->setWait(0); +is $process->getStatus, 'data', 'proper status'; +my $started = $process->startTime; +ok( ( $started >= $now ), 'sane startTime' ); +ok( ( $process->endTime >= $started ), 'sane endTime' ); + +$process->delete; + +note "Testing error case\n"; +$process = $class->create($session); +@argv = $process->argv( $testClass, 'error', ['error'] ); +$hash = $class->argvToHash( \@argv ); +$class->runFromHash($hash); +ok $process->isFinished, 'finished'; +is $process->getError, "error\n", 'has error code'; +$process->setWait(0); +my $status = $process->getStatus; +ok( !$status, 'no discernable status' ) or diag $status; +ok( ( $process->endTime >= $started ), 'sane endTime' ); + +note "Testing with actual fork\n"; +$process = $class->start( $session, $testClass, 'complex', ['data'] ); +my $sleeping; +while ( !$process->isFinished && $sleeping++ < 10 ) { + sleep 1; +} +ok $process->isFinished, 'finished'; +is $process->getStatus, 'baz', 'correct status' + or diag $process->getError . "\n"; + +$process->delete; + +done_testing; + +#vim:ft=perl diff --git a/t/lib/WebGUI/Test/BackgroundProcess.pm b/t/lib/WebGUI/Test/BackgroundProcess.pm new file mode 100644 index 000000000..51912b2dc --- /dev/null +++ b/t/lib/WebGUI/Test/BackgroundProcess.pm @@ -0,0 +1,20 @@ +package WebGUI::Test::BackgroundProcess; + +sub simple { + my ( $self, $arr ) = @_; + $self->update( $arr->[0] ); +} + +sub error { + my ( $self, $arr ) = @_; + die "$arr->[0]\n"; +} + +sub complex { + my $self = shift; + $self->update( sub {'foo'} ); + $self->update( sub {'bar'} ); + $self->update( sub {'baz'} ); +} + +1;