lib/Catalyst/Plugin/Scheduler/Base.pm

   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
  96 =head2 @events = $c->scheduler->list_pending_events;
  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;
 115     my $now     = DateTime->now( time_zone => $tz )->epoch;
 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?
 142             push @pending, $event if $event->next_run <= $now;
 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