[catagits/Catalyst-Plugin-Scheduler.git] / lib / Catalyst / Plugin / Scheduler / Base.pm

package Catalyst::Plugin::Scheduler::Base;

use Data::Dumper;
use DateTime;
use DateTime::Event::Cron;
use DateTime::TimeZone;
use File::stat;
use Set::Scalar;
use base        qw/Catalyst::Plugin::Scheduler/;
use Catalyst::Plugin::Scheduler::Event;

__PACKAGE__->mk_classdata(_events      => []);
__PACKAGE__->mk_classdata(_event_class => 'Catalyst::Plugin::Scheduler::Event');
__PACKAGE__->mk_classdata('_app'            );

=head1 NAME

Catalyst::Plugin::Scheduler::Base - Base class for the Catalyst Scheduler

=head1 SYNOPSIS

    MyApp->scheduler->schedule( at => '0 0 * * *', event => '/cron/ping' );
    
    ### return all scheduled events as ::Event objects
    @events     = MyApp->scheduler->list_events;

    ### return all pending scheduled events as ::Event objects
    @pending    = MyApp->scheduler->list_pending_events;
    
    ### a dump of the current scheduler state
    $aref       = MyApp->scheduler->state;

=head1 METHODS

=head2 $bool = MyApp->scheduler->schedule

Allows you to schedule events. For full usage and documentation, consult
the C<Catalyst::Plugin::Scheduler> documentation on method C<schedule>.

=cut

sub schedule {
    my $self    = shift;
    my $c       = $self->_app;
    my %args    = @_;

    ### XXX more input checks?

    unless ( $args{event} ) {
        Catalyst::Exception->throw(
            message => 'The schedule method requires an event parameter' );
    }
    
    ### default to '1'
    $args{'auto_run'} = 1 unless defined $args{'auto_run'};

    if ( $args{at} ) {

        # replace keywords that Set::Crontab doesn't support
        $args{at} = $self->_prepare_cron( $args{at} );
        
        # parse the cron entry into a DateTime::Set
        $args{set} = eval { DateTime::Event::Cron->from_cron( $args{at} ) };

        Catalyst::Exception->throw(
            "Scheduler: Unable to parse 'at' value $args{at}: $@"
        ) if $@;

    }

    my $who  = $self->_caller_string;
    push @{ $self->_events }, 
        Catalyst::Plugin::Scheduler::Event->new( scheduled_by => $who, %args );

    return 1;
}

### create a caller string like: "package (file.pm:#line)"
sub _caller_string { return sprintf "%s (%s:%s)", @{[caller(1)]}[0,1,2]; }

=head2 @events = $c->scheduler->list_events;

Returns an array of C<Catalyst::Plugin::Scheduler::Event> objects,
representing all the scheduled events in this application.

See the C<Catalyst::Plugin::Scheduler::Event> documentation on how to use
these objects.

=cut

sub list_events { 
    my $self = shift;
    return @{ $self->_events || [] };
};

=head2 @events = $c->scheduler->list_pending_events;

Returns an array of C<Catalyst::Plugin::Scheduler::Event> objects,
representing all the pending events in this application. They are the
events that are due according to your cron specification, and will be run
at the next dispatch, or can be run by you explicitly.

See the C<Catalyst::Plugin::Scheduler::Event> documentation on how to use
these objects.

=cut

sub list_pending_events {
    my $self    = shift;
    my $c       = $self->_app;
    my $tz      = $self->_config('time_zone');
    
    ### there are no events scheduled?
    my @events  = $self->list_events or return;
    my $now     = DateTime->now( time_zone => $tz )->epoch;
    
    ### list of pending events
    my @pending;
    
    ### XXX need NEXT RUN TIME??
    EVENT: 
    for my $event (@events) {
    
        ### this event is not active, so skip it
        next EVENT unless $event->active;
    
        ### the proper trigger is being called
        if( $event->trigger && $c->req->params->{schedule_trigger} &&
            $event->trigger eq $c->req->params->{schedule_trigger} 
        ) {
            
            ### if you're not authorized to call the trigger, skip it
            next EVENT unless $self->_event_authorized;
            
            push @pending, $event;
            next EVENT;
        }
        
        ### we're due according to our cron-entry...
        if( $event->set ) {
            ### is the next run time now, or even before now?
            push @pending, $event if $event->next_run <= $now;
        }
    }

    ### sort them by priority
    return sort { $a->priority <=> $b->priority } @pending;
}


sub _run_events {
    my $self    = shift;
    my $c       = $self->_app;
    my %args    = @_;

    $self->_check_yaml();

    # check if a minute has passed since our last check
    # This check is not run if the user is manually triggering an event
    if ( time - $self->_last_check_time < $self->_config('check_every') ) {
        return unless $c->req->params->{schedule_trigger};
    }

    my @events = $self->list_pending_events;

    ### update the 'checked' time and save the state, so no more
    ### processes are going to be running these events
    ### the small race condition between the 'list_pending_events' call
    ### and the updating of the check time is resolved by checking if a
    ### job is running before executing it, so at worst, we have several
    ### processes sharing the load of this cron run. --kane
    $self->_last_check_time( time );

    EVENT:
    for my $event ( @events ) {

        # do some security checking for non-auto-run events
        ### XXX move this to $event->run? --kane
        if ( !$event->auto_run ) {
            next EVENT unless $self->_event_authorized;
        }

        $event->run;
    }
}

=head2 $aref = MyApp->scheduler->state

A dump of the current state of the scheudler. For full usage and 
documentation, consult the C<Catalyst::Plugin::Scheduler> documentation on
method C<scheduler+state>.

=cut

sub state {
    my $self    = shift;
    my $c       = $self->_app;

    my $event_dump = [];
    for my $event ( $self->list_events ) {
        my $dump = {};
        for my $key ( qw/at trigger event auto_run/ ) {
            $dump->{$key} = $event->$key if $event->$key;
        }

        # display the next run time
        $dump->{next_run} = $event->next_run_as_string;
        
        # display the last run time
        $dump->{last_run} = $event->last_run_as_string; 
        
        # display the result of the last run
        my $output = $event->output;
        if ( $output ) {
            $dump->{last_output} = $output;
        }
            
        push @{$event_dump}, $dump;
    }
    
    return $event_dump;
}        

sub _config {
    my $self = shift;
    my $key  = shift;
    my $c    = $self->_app;
    my $conf = $c->config->{scheduler};
    my $rv   = $key ? $conf->{$key} : $conf;
    
    return $rv;
}    

### shorthand form
sub _last_check_time {
    my $self = shift;
    return $self->_event_class->_last_check_time( @_ );
}    

# check and reload the YAML file with schedule data
sub _check_yaml {
    my $self    = shift;
    my $c       = $self->_app;

    $self->_event_class->_get_event_state();

    # each process needs to load the YAML file independently
    if ( $self->_event_class->_event_state->{yaml_mtime}->{$$} ||= 0 ) {
        return if ( time - $self->_last_check_time < 60 );
    }

    my $file = $self->_config('yaml_file');
    return unless -e $file;

    eval {
        my $mtime = ( stat $file )->mtime;
        if ( $mtime > $self->_event_class->_event_state->{yaml_mtime}->{$$} ) {
            $self->_event_class->_event_state->{yaml_mtime}->{$$} = $mtime;

            # clean up old PIDs listed in yaml_mtime
            for my $pid ( 
                keys %{ $self->_event_class->_event_state->{yaml_mtime} } 
            ) {
                delete $self->_event_class->_event_state->{yaml_mtime}->{$pid}
                    if $self->_event_class->_event_state->{yaml_mtime}->{$pid} 
                        < $mtime 
            }            
            $self->_event_class->_save_event_state();
            
            # wipe out all current events and reload from YAML
            $self->_events( [] );

            my $yaml;

            eval { require YAML::Syck; };
            if( $@ ) {
                require YAML;
                $yaml = YAML::LoadFile( "$file" );
            }
            else {
                open( my $fh, $file ) or die $!;
                my $content = do { local $/; <$fh> };
                close $fh;
                $yaml = YAML::Syck::Load( $content );
            }
            
            foreach my $event ( @{$yaml} ) {
                $self->schedule( %{$event} );
            }

            $c->log->info( "Scheduler: PID $$ loaded "
                    . scalar @{$yaml}
                    . ' events from YAML file' )
                if $self->_config('logging');
        }
    };
    
    $c->log->error("Scheduler: Error reading YAML file: $@") if $@;
}

# Detect the current time zone
sub _detect_timezone {
    my $self    = shift;
    my $c       = $self->_app;

    my $tz;
    eval { $tz = DateTime::TimeZone->new( name => 'local' ) };
    if ($@) {
        $c->log->warn(
            'Scheduler: Unable to autodetect local time zone, using UTC')
            if $self->_config('logging'); 
        return 'UTC';
    }
    else {
        $c->log->debug(
            'Scheduler: Using autodetected time zone: ' . $tz->name )
            if $self->_config('logging');
        return $tz->name;
    }
}

# Check for authorized users on non-auto events
sub _event_authorized {
    my $self    = shift;
    my $c       = $self->_app;

    # this should never happen, but just in case...
    return unless $c->req->address;

    my $hosts_allow = $self->_config('hosts_allow');
    $hosts_allow    = [$hosts_allow] unless ref($hosts_allow) eq 'ARRAY';
    my $allowed     = Set::Scalar->new( @{$hosts_allow} );

    return $allowed->contains( $c->req->address );
}

# Set::Crontab does not support day names, or '@' shortcuts
{   my %replace = (
        jan   => 1,
        feb   => 2,
        mar   => 3,
        apr   => 4,
        may   => 5,
        jun   => 6,
        jul   => 7,
        aug   => 8,
        sep   => 9,
        'oct' => 10,
        nov   => 11,
        dec   => 12,

        sun => 0,
        mon => 1,
        tue => 2,
        wed => 3,
        thu => 4,
        fri => 5,
        sat => 6,
    );
    
    my %replace_at = (
        'yearly'   => '0 0 1 1 *',
        'annually' => '0 0 1 1 *',
        'monthly'  => '0 0 1 * *',
        'weekly'   => '0 0 * * 0',
        'daily'    => '0 0 * * *',
        'midnight' => '0 0 * * *',
        'hourly'   => '0 * * * *',
        'always'   => '* * * * *',
    );

    sub _prepare_cron {
        my $self = shift;
        my $c    = $self->_app;
        my $cron = shift;
    
        return $cron unless $cron =~ /\w/;
        
        if ( $cron =~ /^\@/ ) {
            $cron =~ s/^\@//;
            return $replace_at{ $cron };
        }
    
        for my $name ( keys %replace ) {
            my $value = $replace{$name};
            $cron =~ s/$name/$value/i;
            last unless $cron =~ /\w/;
        }

        return $cron;
    }
}

1;

__END__

=head1 SEE ALSO

C<Catalyst::Plugin::Scheduler>, C<Catalyst::Plugin::Scheduler::Event>,

=cut
Commit	Line	Data
ba2735b6	1	package Catalyst::Plugin::Scheduler::Base;
	2
	3	use Data::Dumper;
	4	use DateTime;
	5	use DateTime::Event::Cron;
	6	use DateTime::TimeZone;
	7	use File::stat;
	8	use Set::Scalar;
	9	use base qw/Catalyst::Plugin::Scheduler/;
	10	use Catalyst::Plugin::Scheduler::Event;
	11
	12	__PACKAGE__->mk_classdata(_events => []);
	13	__PACKAGE__->mk_classdata(_event_class => 'Catalyst::Plugin::Scheduler::Event');
	14	__PACKAGE__->mk_classdata('_app' );
	15
	16	=head1 NAME
	17
	18	Catalyst::Plugin::Scheduler::Base - Base class for the Catalyst Scheduler
	19
	20	=head1 SYNOPSIS
	21
	22	MyApp->scheduler->schedule( at => '0 0 * * *', event => '/cron/ping' );
	23
	24	### return all scheduled events as ::Event objects
	25	@events = MyApp->scheduler->list_events;
	26
	27	### return all pending scheduled events as ::Event objects
	28	@pending = MyApp->scheduler->list_pending_events;
	29
	30	### a dump of the current scheduler state
	31	$aref = MyApp->scheduler->state;
	32
	33	=head1 METHODS
	34
	35	=head2 $bool = MyApp->scheduler->schedule
	36
	37	Allows you to schedule events. For full usage and documentation, consult
	38	the C<Catalyst::Plugin::Scheduler> documentation on method C<schedule>.
	39
	40	=cut
	41
	42	sub schedule {
	43	my $self = shift;
	44	my $c = $self->_app;
	45	my %args = @_;
	46
	47	### XXX more input checks?
	48
	49	unless ( $args{event} ) {
	50	Catalyst::Exception->throw(
	51	message => 'The schedule method requires an event parameter' );
	52	}
	53
	54	### default to '1'
	55	$args{'auto_run'} = 1 unless defined $args{'auto_run'};
	56
	57	if ( $args{at} ) {
	58
	59	# replace keywords that Set::Crontab doesn't support
	60	$args{at} = $self->_prepare_cron( $args{at} );
	61
	62	# parse the cron entry into a DateTime::Set
	63	$args{set} = eval { DateTime::Event::Cron->from_cron( $args{at} ) };
	64
65	Catalyst::Exception->throw(
66	"Scheduler: Unable to parse 'at' value $args{at}: $@"
67	) if $@;
68
69	}
70
71	my $who = $self->_caller_string;
72	push @{ $self->_events },
73	Catalyst::Plugin::Scheduler::Event->new( scheduled_by => $who, %args );
74
75	return 1;
76	}
77
78	### create a caller string like: "package (file.pm:#line)"
79	sub _caller_string { return sprintf "%s (%s:%s)", @{[caller(1)]}[0,1,2]; }
80
81	=head2 @events = $c->scheduler->list_events;
82
83	Returns an array of C<Catalyst::Plugin::Scheduler::Event> objects,
84	representing all the scheduled events in this application.
85
86	See the C<Catalyst::Plugin::Scheduler::Event> documentation on how to use
87	these objects.
88
89	=cut
90
91	sub list_events {
92	my $self = shift;
93	return @{ $self->_events \|\| [] };
94	};
95
945fdd23	96	=head2 @events = $c->scheduler->list_pending_events;
ba2735b6	97
	98	Returns an array of C<Catalyst::Plugin::Scheduler::Event> objects,
	99	representing all the pending events in this application. They are the
	100	events that are due according to your cron specification, and will be run
	101	at the next dispatch, or can be run by you explicitly.
	102
	103	See the C<Catalyst::Plugin::Scheduler::Event> documentation on how to use
	104	these objects.
	105
	106	=cut
	107
	108	sub list_pending_events {
	109	my $self = shift;
	110	my $c = $self->_app;
	111	my $tz = $self->_config('time_zone');
	112
	113	### there are no events scheduled?
	114	my @events = $self->list_events or return;
247e43e2	115	my $now = DateTime->now( time_zone => $tz )->epoch;
ba2735b6	116
	117	### list of pending events
	118	my @pending;
	119
	120	### XXX need NEXT RUN TIME??
	121	EVENT:
	122	for my $event (@events) {
	123
	124	### this event is not active, so skip it
	125	next EVENT unless $event->active;
	126
	127	### the proper trigger is being called
	128	if( $event->trigger && $c->req->params->{schedule_trigger} &&
	129	$event->trigger eq $c->req->params->{schedule_trigger}
	130	) {
	131
	132	### if you're not authorized to call the trigger, skip it
	133	next EVENT unless $self->_event_authorized;
	134
	135	push @pending, $event;
	136	next EVENT;
	137	}
	138
	139	### we're due according to our cron-entry...
	140	if( $event->set ) {
	141	### is the next run time now, or even before now?
247e43e2	142	push @pending, $event if $event->next_run <= $now;
ba2735b6	143	}
	144	}
	145
	146	### sort them by priority
	147	return sort { $a->priority <=> $b->priority } @pending;
	148	}
	149
	150
	151
	152	sub _run_events {
	153	my $self = shift;
	154	my $c = $self->_app;
	155	my %args = @_;
	156
	157	$self->_check_yaml();
	158
	159	# check if a minute has passed since our last check
	160	# This check is not run if the user is manually triggering an event
	161	if ( time - $self->_last_check_time < $self->_config('check_every') ) {
	162	return unless $c->req->params->{schedule_trigger};
	163	}
	164
	165	my @events = $self->list_pending_events;
	166
	167	### update the 'checked' time and save the state, so no more
	168	### processes are going to be running these events
	169	### the small race condition between the 'list_pending_events' call
	170	### and the updating of the check time is resolved by checking if a
	171	### job is running before executing it, so at worst, we have several
	172	### processes sharing the load of this cron run. --kane
	173	$self->_last_check_time( time );
	174
	175	EVENT:
	176	for my $event ( @events ) {
	177
	178	# do some security checking for non-auto-run events
	179	### XXX move this to $event->run? --kane
	180	if ( !$event->auto_run ) {
	181	next EVENT unless $self->_event_authorized;
	182	}
	183
	184	$event->run;
	185	}
	186	}
	187
	188	=head2 $aref = MyApp->scheduler->state
	189
	190	A dump of the current state of the scheudler. For full usage and
	191	documentation, consult the C<Catalyst::Plugin::Scheduler> documentation on
	192	method C<scheduler+state>.
	193
	194	=cut
	195
	196	sub state {
	197	my $self = shift;
	198	my $c = $self->_app;
	199
	200	my $event_dump = [];
	201	for my $event ( $self->list_events ) {
	202	my $dump = {};
	203	for my $key ( qw/at trigger event auto_run/ ) {
	204	$dump->{$key} = $event->$key if $event->$key;
	205	}
	206
207	# display the next run time
208	$dump->{next_run} = $event->next_run_as_string;
209
210	# display the last run time
211	$dump->{last_run} = $event->last_run_as_string;
212
213	# display the result of the last run
214	my $output = $event->output;
215	if ( $output ) {
216	$dump->{last_output} = $output;
217	}
218
219	push @{$event_dump}, $dump;
220	}
221
222	return $event_dump;
223	}
224
225	sub _config {
226	my $self = shift;
227	my $key = shift;
228	my $c = $self->_app;
229	my $conf = $c->config->{scheduler};
230	my $rv = $key ? $conf->{$key} : $conf;
231
232	return $rv;
233	}
234
235	### shorthand form
236	sub _last_check_time {
237	my $self = shift;
238	return $self->_event_class->_last_check_time( @_ );
239	}
240
241	# check and reload the YAML file with schedule data
242	sub _check_yaml {
243	my $self = shift;
244	my $c = $self->_app;
245
246	$self->_event_class->_get_event_state();
247
248	# each process needs to load the YAML file independently
249	if ( $self->_event_class->_event_state->{yaml_mtime}->{$$} \|\|= 0 ) {
250	return if ( time - $self->_last_check_time < 60 );
251	}
252
253	my $file = $self->_config('yaml_file');
254	return unless -e $file;
255
256	eval {
257	my $mtime = ( stat $file )->mtime;
258	if ( $mtime > $self->_event_class->_event_state->{yaml_mtime}->{$$} ) {
259	$self->_event_class->_event_state->{yaml_mtime}->{$$} = $mtime;
260
261	# clean up old PIDs listed in yaml_mtime
262	for my $pid (
263	keys %{ $self->_event_class->_event_state->{yaml_mtime} }
264	) {
265	delete $self->_event_class->_event_state->{yaml_mtime}->{$pid}
266	if $self->_event_class->_event_state->{yaml_mtime}->{$pid}
267	< $mtime
268	}
269	$self->_event_class->_save_event_state();
270
271	# wipe out all current events and reload from YAML
272	$self->_events( [] );
273
274	my $yaml;
275
276	eval { require YAML::Syck; };
277	if( $@ ) {
278	require YAML;
279	$yaml = YAML::LoadFile( "$file" );
280	}
281	else {
282	open( my $fh, $file ) or die $!;
283	my $content = do { local $/; <$fh> };
284	close $fh;
285	$yaml = YAML::Syck::Load( $content );
286	}
287
288	foreach my $event ( @{$yaml} ) {
289	$self->schedule( %{$event} );
290	}
291
292	$c->log->info( "Scheduler: PID $$ loaded "
293	. scalar @{$yaml}
294	. ' events from YAML file' )
295	if $self->_config('logging');
296	}
297	};
298
299	$c->log->error("Scheduler: Error reading YAML file: $@") if $@;
300	}
301
302	# Detect the current time zone
303	sub _detect_timezone {
304	my $self = shift;
305	my $c = $self->_app;
306
307	my $tz;
308	eval { $tz = DateTime::TimeZone->new( name => 'local' ) };
309	if ($@) {
310	$c->log->warn(
311	'Scheduler: Unable to autodetect local time zone, using UTC')
312	if $self->_config('logging');
313	return 'UTC';
314	}
315	else {
316	$c->log->debug(
317	'Scheduler: Using autodetected time zone: ' . $tz->name )
318	if $self->_config('logging');
319	return $tz->name;
320	}
321	}
322
323	# Check for authorized users on non-auto events
324	sub _event_authorized {
325	my $self = shift;
326	my $c = $self->_app;
327
328	# this should never happen, but just in case...
329	return unless $c->req->address;
330
331	my $hosts_allow = $self->_config('hosts_allow');
332	$hosts_allow = [$hosts_allow] unless ref($hosts_allow) eq 'ARRAY';
333	my $allowed = Set::Scalar->new( @{$hosts_allow} );
334
335	return $allowed->contains( $c->req->address );
336	}
337
338	# Set::Crontab does not support day names, or '@' shortcuts
339	{ my %replace = (
340	jan => 1,
341	feb => 2,
342	mar => 3,
343	apr => 4,
344	may => 5,
345	jun => 6,
346	jul => 7,
347	aug => 8,
348	sep => 9,
349	'oct' => 10,
350	nov => 11,
351	dec => 12,
352
353	sun => 0,
354	mon => 1,
355	tue => 2,
356	wed => 3,
357	thu => 4,
358	fri => 5,
359	sat => 6,
360	);
361
362	my %replace_at = (
363	'yearly' => '0 0 1 1 *',
364	'annually' => '0 0 1 1 *',
365	'monthly' => '0 0 1 * *',
366	'weekly' => '0 0 * * 0',
367	'daily' => '0 0 * * *',
368	'midnight' => '0 0 * * *',
369	'hourly' => '0 * * * *',
370	'always' => '* * * * *',
371	);
372
373	sub _prepare_cron {
374	my $self = shift;
375	my $c = $self->_app;
376	my $cron = shift;
377
378	return $cron unless $cron =~ /\w/;
379
380	if ( $cron =~ /^\@/ ) {
381	$cron =~ s/^\@//;
382	return $replace_at{ $cron };
383	}
384
385	for my $name ( keys %replace ) {
386	my $value = $replace{$name};
387	$cron =~ s/$name/$value/i;
388	last unless $cron =~ /\w/;
389	}
390
391	return $cron;
392	}
393	}
394
395	1;
396
397	__END__
398
399	=head1 SEE ALSO
400
401	C<Catalyst::Plugin::Scheduler>, C<Catalyst::Plugin::Scheduler::Event>,
402
403	=cut
404