App-Dochazka-REST
view release on metacpan or search on metacpan
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
);
use App::Dochazka::REST::Holiday qw(
calculate_hours
canon_date_diff
canon_to_ymd
get_tomorrow
holidays_in_daterange
tsrange_to_dates_and_times
ymd_to_canon
);
use Data::Dumper;
use Date::Calc qw(
Add_Delta_Days
Date_to_Days
Day_of_Week
check_date
);
use JSON qw( decode_json );
use Params::Validate qw( :all );
use Try::Tiny;
BEGIN {
no strict 'refs';
our %attr= (
act_obj => {
type => HASHREF,
isa => 'App::Dochazka::REST::Model::Activity',
optional => 1
},
clobber => { type => BOOLEAN, optional => 1 },
constructor_status => {
type => HASHREF,
isa => 'App::CELL::Status',
optional => 1
},
context => { type => HASHREF, optional => 1 },
date_list => { type => ARRAYREF, optional => 1 },
dry_run => { type => BOOLEAN, optional => 1 },
emp_obj => {
type => HASHREF,
isa => 'App::Dochazka::REST::Model::Employee',
optional => 1
},
intervals => { type => ARRAYREF, optional => 1 },
long_desc => { type => SCALAR, optional => 1 },
remark => { type => SCALAR, optional => 1 },
tiid => { type => SCALAR, optional => 1 },
tsrange => { type => HASHREF, optional => 1 },
tsranges => { type => ARRAYREF, optional => 1 },
);
map {
my $fn = __PACKAGE__ . "::$_";
$log->debug( "BEGIN BLOCK: $_ $fn" );
*{ $fn } =
App::Dochazka::Common::Model::make_accessor( $_, $attr{ $_ } );
} keys %attr;
*{ 'reset' } = sub {
# process arguments
my $self = shift;
my %ARGS = validate( @_, \%attr ) if @_ and defined $_[0];
# Wipe out current TIID
$self->DESTROY;
# Set attributes to run-time values sent in argument list.
# Attributes that are not in the argument list will get set to undef.
map { $self->{$_} = $ARGS{$_}; } keys %attr;
# run the populate function, if any
$self->populate() if $self->can( 'populate' );
# return an appropriate throw-away value
return;
};
*{ 'TO_JSON' } = sub {
my $self = shift;
my $unblessed_copy;
map { $unblessed_copy->{$_} = $self->{$_}; } keys %attr;
return $unblessed_copy;
};
}
my %dow_to_num = (
'MON' => 1,
'TUE' => 2,
'WED' => 3,
'THU' => 4,
'FRI' => 5,
'SAT' => 6,
'SUN' => 7,
);
my %num_to_dow = reverse %dow_to_num;
=head1 NAME
App::Dochazka::REST::Fillup - fillup routines
=head1 SYNOPSIS
use App::Dochazka::REST::Fillup;
...
=head1 METHODS
=head2 populate
Get the next TIID and store in the object
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
return $CELL->status_ok;
}
=head2 _vet_date_spec
The user can specify fillup dates either as a tsrange or as a list of
individual dates.
One or the other must be given, not neither and not both.
Returns a status object.
=cut
sub _vet_date_spec {
my $self = shift;
my %ARGS = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_vet_date_spec to enforce date specification policy" );
if ( defined( $ARGS{date_list} ) and defined( $ARGS{tsrange} ) ) {
$log->debug( "date_spec is NOT OK" );
return $CELL->status_not_ok;
}
if ( ! defined( $ARGS{date_list} ) and ! defined( $ARGS{tsrange} ) ) {
$log->debug( "date_spec is NOT OK" );
return $CELL->status_not_ok;
}
$self->{'vetted'}->{'date_spec'} = 1;
$log->debug( "date_spec is OK" );
return $CELL->status_ok;
}
=head2 _vet_date_list
This function takes one named argument: date_list, the value of which must
be a reference to an array of dates, each in canonical YYYY-MM-DD form. For
example, this
[ '2016-01-13', '2016-01-27', '2016-01-14' ]
is a legal C<date_list> argument.
This function performs various checks on the date list, sorts it, and
populates the C<tsrange> and C<tsranges> attributes based on it. For the
sample date list given above, the tsrange will be something like
{ tsrange => "[\"2016-01-13 00:00:00+01\",\"2016-01-28 00:00:00+01\")" }
This is used to make sure the employee's schedule and priv level did not
change during the time period represented by the date list, as well as in
C<fillup_tempintvls> to generate the C<tempintvl> working set.
Returns a status object.
=cut
sub _vet_date_list {
my $self = shift;
my ( %ARGS ) = validate( @_, {
date_list => { type => ARRAYREF|UNDEF },
} );
$log->debug( "Entering " . __PACKAGE__ . "::_vet_date_list to vet/populate the date_list property" );
if ( $ARGS{'date_list'} ) {
$log->debug( "Date list is " . Dumper $ARGS{'date_list'} );
}
die "GOPHFQQ! tsrange property must not be populated in _vet_date_list()" if $self->tsrange;
return $CELL->status_ok if not defined( $ARGS{date_list} );
return $CELL->status_err( 'DOCHAZKA_EMPTY_DATE_LIST' ) if scalar( @{ $ARGS{date_list} } ) == 0;
# check that dates are valid and in canonical form
my @canonicalized_date_list = ();
foreach my $date ( @{ $ARGS{date_list} } ) {
my ( $y, $m, $d ) = canon_to_ymd( $date );
if ( ! check_date( $y, $m, $d ) ) {
return $CELL->status_err(
"DOCHAZKA_INVALID_DATE_IN_DATE_LIST",
args => [ $date ],
);
}
push @canonicalized_date_list, sprintf( "%04d-%02d-%02d", $y, $m, $d );
}
my @sorted_date_list = sort @canonicalized_date_list;
$self->date_list( \@sorted_date_list );
my $noof_entries = scalar( @{ $self->date_list } );
if ( $noof_entries > $site->DOCHAZKA_INTERVAL_FILLUP_MAX_DATELIST_ENTRIES ) {
return $CELL->status_err(
'DOCHAZKA_INTERVAL_FILLUP_DATELIST_TOO_LONG',
args => [ $noof_entries ],
);
}
# populate tsrange
if ( scalar @sorted_date_list == 0 ) {
$self->tsrange( undef );
} elsif ( scalar @sorted_date_list == 1 ) {
my $t = "[ $sorted_date_list[0] 00:00, $sorted_date_list[0] 24:00 )";
my $status = canonicalize_tsrange( $self->context->{dbix_conn}, $t );
return $status unless $status->ok;
$self->tsrange( { tsrange => $status->payload } );
} else {
my $t = "[ $sorted_date_list[0] 00:00, $sorted_date_list[-1] 24:00 )";
my $status = canonicalize_tsrange( $self->context->{dbix_conn}, $t );
return $status unless $status->ok;
$self->tsrange( { tsrange => $status->payload } );
}
# populate tsranges
if ( scalar @sorted_date_list == 0 ) {
$self->tsranges( undef );
} else {
my @tsranges = ();
foreach my $date ( @sorted_date_list ) {
my $t = "[ $date 00:00, $date 24:00 )";
my $status = canonicalize_tsrange(
$self->context->{dbix_conn},
$t,
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
$self->context->{dbix_conn},
$t,
);
return $status unless $status->ok;
$self->tsrange( { tsrange => $status->payload } );
$self->tsranges( [ { tsrange => $status->payload } ] );
}
foreach my $t_hash ( @{ $self->tsranges }, $self->tsrange ) {
# split the tsrange
my @parens = $t_hash->{tsrange} =~ m/[^\[(]*([\[(])[^\])]*([\])])/;
my $status = split_tsrange( $self->context->{'dbix_conn'}, $t_hash->{tsrange} );
$log->info( "split_tsrange() returned: " . Dumper( $status ) );
return $status unless $status->ok;
my $low = $status->payload->[0];
my $upp = $status->payload->[1];
my @low = canon_to_ymd( $low );
my @upp = canon_to_ymd( $upp );
# lower date bound = tsrange:begin_date minus one day
@low = Add_Delta_Days( @low, -1 );
$low = ymd_to_canon( @low );
# upper date bound = tsrange:begin_date plus one day
@upp = Add_Delta_Days( @upp, 1 );
$upp = ymd_to_canon( @upp );
# check DOCHAZKA_INTERVAL_FILLUP_LIMIT
# - add two days to the limit to account for how we just stretched $low and $upp
my $fillup_limit = $site->DOCHAZKA_INTERVAL_FILLUP_LIMIT + 2;
if ( $fillup_limit < canon_date_diff( $low, $upp ) ) {
return $CELL->status_err( 'DOCHAZKA_FILLUP_TSRANGE_TOO_LONG', args => [ $ARGS{tsrange} ] )
}
$t_hash->{'lower_ymd'} = \@low;
$t_hash->{'upper_ymd'} = \@upp;
$t_hash->{'lower_canon'} = $low;
$t_hash->{'upper_canon'} = $upp;
}
$self->{'vetted'}->{'tsrange'} = 1;
return $CELL->status_ok( 'SUCCESS' );
}
=head2 _vet_employee
Expects to be called *after* C<_vet_tsrange>.
Takes an employee object. First, retrieves
from the database the employee object corresponding to the EID. Second,
checks that the employee's privlevel did not change during the tsrange.
Third, retrieves the prevailing schedule and checks that the schedule does
not change at all during the tsrange. Returns a status object.
=cut
sub _vet_employee {
my $self = shift;
my ( %ARGS ) = validate( @_, {
emp_obj => {
type => HASHREF,
isa => 'App::Dochazka::REST::Model::Employee',
},
} );
my $status;
die 'AKLDWW###%AAAAAH!' unless $ARGS{emp_obj}->eid;
$self->{'emp_obj'} = $ARGS{emp_obj};
$log->debug( "Fillup _vet_employee(): check for priv changes during the tsrange" );
if ( $self->{'emp_obj'}->priv_change_during_range(
$self->context->{'dbix_conn'},
$self->tsrange->{'tsrange'},
) ) {
return $CELL->status_err( 'DOCHAZKA_EMPLOYEE_PRIV_CHANGED' );
}
$log->debug( "Fillup _vet_employee(): check for schedule changes during the tsrange" );
if ( $self->{'emp_obj'}->schedule_change_during_range(
$self->context->{'dbix_conn'},
$self->tsrange->{'tsrange'},
) ) {
return $CELL->status_err( 'DOCHAZKA_EMPLOYEE_SCHEDULE_CHANGED' );
}
# get privhistory record prevailing at beginning of tsrange
my $probj = $self->{emp_obj}->privhistory_at_timestamp(
$self->context->{'dbix_conn'},
$self->tsrange->{'tsrange'},
);
if ( ! $probj->priv ) {
return $CELL->status_err( 'DISPATCH_EMPLOYEE_NO_PRIVHISTORY' );
}
if ( $probj->priv eq 'active' or $probj->priv eq 'admin' ) {
# all green
} else {
return $CELL->status_err( 'DOCHAZKA_INSUFFICIENT_PRIVILEGE', args => [ $probj->priv ] );
}
# get schedhistory record prevailing at beginning of tsrange
my $shobj = $self->{emp_obj}->schedhistory_at_timestamp(
$self->context->{'dbix_conn'},
$self->tsrange->{'tsrange'},
);
if ( ! $shobj->sid ) {
return $CELL->status_err( 'DISPATCH_EMPLOYEE_NO_SCHEDULE' );
}
my $sched_obj = App::Dochazka::REST::Model::Schedule->load_by_sid(
$self->context->{'dbix_conn'},
$shobj->sid,
)->payload;
die "AGAHO-NO!" unless ref( $sched_obj) eq 'App::Dochazka::REST::Model::Schedule'
and $sched_obj->schedule =~ m/high_dow/;
$self->{'sched_obj'} = $sched_obj;
$self->{'vetted'}->{'employee'} = 1;
return $CELL->status_ok( 'SUCCESS' );
}
=head2 _vet_activity
Takes a C<DBIx::Connector> object and an AID. Verifies that the AID exists
and populates the C<activity_obj> attribute.
=cut
sub _vet_activity {
my $self = shift;
my ( %ARGS ) = validate( @_, {
aid => { type => SCALAR|UNDEF, optional => 1 },
} );
my $status;
if ( exists( $ARGS{aid} ) and defined( $ARGS{aid} ) ) {
# load activity object from database into $self->{act_obj}
$status = App::Dochazka::REST::Model::Activity->load_by_aid(
$self->context->{'dbix_conn'},
$ARGS{aid}
);
if ( $status->ok and $status->code eq 'DISPATCH_RECORDS_FOUND' ) {
# all green; fall thru to success
$self->{'act_obj'} = $status->payload;
$self->{'aid'} = $status->payload->aid;
} elsif ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
# non-existent activity
return $CELL->status_err( 'DOCHAZKA_GENERIC_NOT_EXIST', args => [ 'activity', 'AID', $ARGS{aid} ] );
} else {
return $status;
}
} else {
# if no aid given, try to look up "WORK"
$status = App::Dochazka::REST::Model::Activity->load_by_code(
$self->context->{'dbix_conn'},
'WORK'
);
if ( $status->ok and $status->code eq 'DISPATCH_RECORDS_FOUND' ) {
# all green; fall thru to success
$self->{'act_obj'} = $status->payload;
$self->{'aid'} = $status->payload->aid;
} elsif ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
return $CELL->status_err( 'DOCHAZKA_GENERIC_NOT_EXIST', args => [ 'activity', 'code', 'WORK' ] );
} else {
return $status;
}
}
$self->{'vetted'}->{'activity'} = 1;
return $CELL->status_ok( 'SUCCESS' );
}
=head2 vetted
Returns boolean true if object has been completely vetted. Otherwise false.
=cut
sub vetted {
my $self = shift;
(
$self->{'vetted'}->{'tsrange'} and
$self->{'tsrange'} and
$self->{'vetted'}->{'employee'} and
$self->emp_obj and
ref( $self->emp_obj ) eq 'App::Dochazka::REST::Model::Employee' and
$self->{'vetted'}->{'activity'} and
$self->act_obj and
ref( $self->act_obj ) eq 'App::Dochazka::REST::Model::Activity'
) ? 1 : 0;
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
my $d = $self->tsrange->{'lower_canon'};
my $days_upper = Date_to_Days( @{ $self->tsrange->{upper_ymd} } );
WHILE_LOOP: while ( $d ne get_tomorrow( $self->tsrange->{'upper_canon'} ) ) {
if ( _is_holiday( $d, $holidays ) ) {
$d = get_tomorrow( $d );
next WHILE_LOOP;
}
my ( $ly, $lm, $ld ) = canon_to_ymd( $d );
my $days_lower = Date_to_Days( $ly, $lm, $ld );
my $ndow = Day_of_Week( $ly, $lm, $ld );
# get schedule entries starting on that DOW
foreach my $entry ( @{ $rest_sched_hash_lower->{ $ndow } } ) {
my ( $days_high_dow, $hy, $hm, $hd );
# convert "high_dow" into a number of days
$days_high_dow = $days_lower +
( $dow_to_num{ $entry->{'high_dow'} } - $dow_to_num{ $entry->{'low_dow'} } );
if ( $days_high_dow <= $days_upper ) {
# create a Tempintvl object
my $to = App::Dochazka::REST::Model::Tempintvl->spawn( tiid => $self->tiid );
die "COUGH! GAG! Tempintvl object tiid problem!"
unless $to->tiid and $to->tiid == $self->tiid;
# compile the intvl
( $hy, $hm, $hd ) = Days_to_Date( $days_high_dow );
$to->intvl( "[ " . ymd_to_canon( $ly,$lm,$ld ) . " " . $entry->{'low_time'} .
", " . ymd_to_canon( $hy,$hm,$hd ) . " ". $entry->{'high_time'} . " )" );
# insert the object
my $status = $to->insert( $self->context );
return $status unless $status->ok;
# push it onto results array
push @tempintvls, $to;
}
}
$d = get_tomorrow( $d );
}
$log->debug( "fillup_tempintvls completed successfully, " . scalar( @tempintvls ) .
" tempintvl objects created and inserted into database" );
$self->intervals( \@tempintvls );
return $CELL->status_ok( 'DOCHAZKA_TEMPINTVLS_INSERT_OK' );
}
=head2 new
Constructor method. Returns an C<App::Dochazka::REST::Fillup>
object.
The constructor method does everything up to C<fillup>. It also populates the
C<constructor_status> attribute with an C<App::CELL::Status> object.
=cut
sub new {
my $class = shift;
my ( %ARGS ) = validate( @_, {
context => { type => HASHREF },
emp_obj => {
type => HASHREF,
isa => 'App::Dochazka::REST::Model::Employee',
},
aid => { type => SCALAR|UNDEF, optional => 1 },
code => { type => SCALAR|UNDEF, optional => 1 },
tsrange => { type => SCALAR, optional => 1 },
date_list => { type => ARRAYREF, optional => 1 },
long_desc => { type => SCALAR|UNDEF, optional => 1 },
remark => { type => SCALAR|UNDEF, optional => 1 },
clobber => { default => 0 },
dry_run => { default => 0 },
} );
$log->debug( "Entering " . __PACKAGE__ . "::new" );
my ( $self, $status );
# (re-)initialize $self
if ( $class eq __PACKAGE__ ) {
$self = bless {}, $class;
$self->populate();
} else {
die "AGHOOPOWDD@! Constructor must be called like this App::Dochazka::REST::Fillup->new()";
}
die "AGHOOPOWDD@! No tiid in Fillup object!" unless $self->tiid;
map {
if ( ref( $ARGS{$_} ) eq 'JSON::PP::Boolean' ) {
$ARGS{$_} = $ARGS{$_} ? 1 : 0;
}
$self->$_( $ARGS{$_} ) if defined( $ARGS{$_} );
} qw( long_desc remark clobber dry_run );
# the order of the following checks is significant!
$self->constructor_status( $self->_vet_context( context => $ARGS{context} ) );
return $self unless $self->constructor_status->ok;
$self->constructor_status( $self->_vet_date_spec( %ARGS ) );
return $self unless $self->constructor_status->ok;
$self->constructor_status( $self->_vet_date_list( date_list => $ARGS{date_list} ) );
return $self unless $self->constructor_status->ok;
$self->constructor_status( $self->_vet_tsrange( %ARGS ) );
return $self unless $self->constructor_status->ok;
$self->constructor_status( $self->_vet_employee( emp_obj => $ARGS{emp_obj} ) );
return $self unless $self->constructor_status->ok;
$self->constructor_status( $self->_vet_activity( aid => $ARGS{aid} ) );
return $self unless $self->constructor_status->ok;
die "AGHGCHKFSCK! should be vetted by now!" unless $self->vetted;
$self->constructor_status( $self->fillup_tempintvls );
return $self unless $self->constructor_status->ok;
return $self;
}
=head2 commit
If the C<dry_run> attribute is true, assemble and return an array of attendance
intervals that would need to be created to reach 100% schedule fulfillment over
the tsranges.
( run in 0.928 second using v1.01-cache-2.11-cpan-2398b32b56e )