App-Dochazka-REST/lib/App/Dochazka/REST/Fillup.pm
# *************************************************************************
# Copyright (c) 2014-2017, SUSE LLC
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
# this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# 3. Neither the name of SUSE LLC nor the names of its contributors may be
# used to endorse or promote products derived from this software without
# specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# *************************************************************************
package App::Dochazka::REST::Fillup;
use 5.012;
use strict;
use warnings;
use App::CELL qw( $CELL $log $meta $site );
use App::Dochazka::Common::Model;
use App::Dochazka::REST::ConnBank qw( $dbix_conn );
use App::Dochazka::REST::Model::Employee;
use App::Dochazka::REST::Model::Interval qw(
fetch_intervals_by_eid_and_tsrange_inclusive
);
use App::Dochazka::REST::Model::Shared qw(
canonicalize_tsrange
split_tsrange
);
use App::Dochazka::REST::Model::Tempintvl qw(
fetch_tempintvls_by_tiid_and_tsrange
);
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
=cut
sub populate {
my $self = shift;
if ( ! exists( $self->{tiid} ) or ! defined( $self->{tiid} ) or $self->{tiid} == 0 ) {
my $ss = _next_tiid();
$log->info( "Got next TIID: $ss" );
$self->{tiid} = $ss;
}
return;
}
=head2 Accessors
Make accessors for all the attributes. Already done, above, in BEGIN block.
=cut
=head2 _vet_context
Performs various tests on the C<context> attribute. If the value of that
attribute is not what we're expecting, returns a non-OK status. Otherwise,
returns an OK status.
=cut
sub _vet_context {
my $self = shift;
my %ARGS = @_;
return $CELL->status_not_ok unless $ARGS{context};
return $CELL->status_not_ok unless $ARGS{context}->{dbix_conn};
return $CELL->status_not_ok unless $ARGS{context}->{dbix_conn}->isa('DBIx::Connector');
$self->context( $ARGS{context} );
$self->{'vetted'}->{'context'} = 1;
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,
);
return $status unless $status->ok;
# push canonicalized tsrange onto result stack
push @tsranges, { tsrange => $status->payload };
}
$self->tsranges( \@tsranges );
}
$self->{'vetted'}->{'date_list'} = 1;
return $CELL->status_ok;
}
=head2 _vet_tsrange
Takes constructor arguments. Checks the tsrange for sanity and populates
the C<tsrange>, C<lower_canon>, C<lower_ymd>, C<upper_canon>, C<upper_ymd>
attributes. Returns a status object.
=cut
sub _vet_tsrange {
my $self = shift;
my %ARGS = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_vet_tsrange to vet the tsrange " .
( defined( $ARGS{tsrange} ) ? $ARGS{tsrange} : "(undef)" ) );
die "YAHOOEY! No DBIx::Connector in object" unless $self->context->{dbix_conn};
# if a tsrange property was given in the arguments, that means no
# date_list was given: convert the tsrange argument into an arrayref
if ( my $t = $ARGS{tsrange} ) {
my $status = canonicalize_tsrange(
$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;
}
=head2 fillup_tempintvls
This method takes no arguments and expects to be called on a fully vetted
object (see C<vetted>, above).
This method creates (and attempts to INSERT records corresponding to) a
number of Tempintvl objects according to the C<tsrange> (as stored in the
Fillup object) and the employee's schedule.
Note that the purpose of this method is to generate a set of Tempintvl
objects that could potentially become attendance intervals. The
C<fillup_tempintvls> method only deals with Tempintvls. It is up to the
C<commit> method to choose the right Tempintvls for the fillup
operation in question and to construct and insert the corresponding
Interval objects.
Returns a status object.
=cut
sub fillup_tempintvls {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::fillup_tempintvls" );
die "FILLUP_OBJECT_NOT_VETTED" unless $self->vetted;
my $rest_sched_hash_lower = _init_lower_sched_hash( $self->{sched_obj}->schedule );
my $status;
my @pushed_intervals;
my $holidays = holidays_in_daterange(
'begin' => $self->tsrange->{lower_canon},
'end' => $self->tsrange->{upper_canon},
);
# create a bunch of Tempintvl objects
my @tempintvls;
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.
If the C<dry_run> attribute is false, iterate over all those intervals and
INSERT them into the intervals table.
Alternatively, if C<dry_run> is true and C<clobber> is true, ignore existing
attendance intervals that might conflict and just return the scheduled intervals.
If C<dry_run> is false, C<clobber> setting is ignored.
Returns a status object containing all the fillup intervals generated, divided
into "success" and "failure" sets, with the latter containing any intervals
that failed to be inserted for whatever reason. If C<dry_run> is true, all the
intervals will be in the "success" set.
=cut
sub commit {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::commit with dry_run " . ( $self->dry_run ? "TRUE" : "FALSE" ) );
my ( $code, $status, @result_set, @conflicting, @success_set, @failure_set );
foreach my $t_hash ( @{ $self->tsranges } ) {
my $tempintvls = fetch_tempintvls_by_tiid_and_tsrange(
$self->context->{dbix_conn},
$self->tiid,
$t_hash->{tsrange},
);
# Iterate over the tempintvl objects, each of which corresponds
# to a scheduled interval in the fillup period.
TEMPINTVL_LOOP: foreach my $tempintvl ( @$tempintvls ) {
if ( $self->clobber ) {
push @result_set, $self->_gen_int( $tempintvl->intvl );
next TEMPINTVL_LOOP;
}
# check for existing attendance intervals that conflict
@conflicting = ();
push @conflicting, @{ $self->_conflicting_intervals( $tempintvl ) };
$log->debug( "Conflicting intervals" . Dumper \@conflicting );
# for each conflicting interval, generate new intervals to
# reach 100% fulfillment of the scheduled interval
my $conflicts = scalar @conflicting;
my $count = 0;
CONFLICTING_LOOP: foreach my $this ( @conflicting ) {
my ( $next, $newintvl );
if ( $count == 0 ) {
# $newintvl might be from the beginning of $tempintvl to the $beginning of $this
$self->_tsrange_begin_to_begin( $tempintvl, $this, \@result_set );
}
if ( $count < $conflicts - 1 ) {
$next = $conflicting[$count + 1];
# $newintvl might be from the end of $this to the beginning of $next
$self->_tsrange_end_to_begin( $this, $next, \@result_set );
}
if ( $count == $conflicts - 1 ) {
# $newintvl might be from the end of $this to the end of $tempintvl
$self->_tsrange_end_to_end( $this, $tempintvl, \@result_set );
}
$count += 1;
}
if ( $count == 0 ) {
push @result_set, $self->_gen_int( $tempintvl->intvl );
}
}
}
foreach my $int ( @result_set ) {
if ( $self->dry_run ) {
push @success_set, $int;
} else {
$status = $int->insert( $self->context );
if ( $status->ok ) {
push @success_set, $int;
} else {
push @failure_set, {
interval => $int,
status => $status->expurgate,
};
}
}
}
my $pl = {
"success" => {
count => scalar @success_set,
intervals => \@success_set,
},
"failure" => {
count => scalar @failure_set,
intervals => \@failure_set,
},
};
if ( my $count = scalar @result_set ) {
$code = 'DISPATCH_SCHEDULED_INTERVALS_' . ( $self->dry_run ? 'IDENTIFIED' : 'CREATED' );
return $CELL->status_ok(
$code,
args => [ $count ],
payload => $pl,
count => $count,
);
}
$code = 'DISPATCH_NO_SCHEDULED_INTERVALS_' . ( $self->dry_run ? 'IDENTIFIED' : 'CREATED' );
return $CELL->status_ok( $code, count => 0 );
}
sub _gen_int {
my ( $self, $intvl ) = @_;
return App::Dochazka::REST::Model::Interval->spawn(
eid => $self->emp_obj->eid,
aid => $self->act_obj->aid,
code => $self->act_obj->code,
intvl => $intvl,
long_desc => $self->long_desc,
remark => $self->remark || 'fillup',
partial => 0,
);
}
# Given two intervals which are assumed to be in order, construct a new
# interval from the beginning of the first to the beginning of the second
# and push it onto @$result_set
sub _tsrange_begin_to_begin {
my ( $self, $this, $next, $result_set ) = @_;
my ( $status, $pl, $t );
$status = tsrange_to_dates_and_times( $this->intvl );
return unless $status->ok;
$pl = $status->payload;
my $this_begin = "\"" . $pl->{begin}->[0] . " " . $pl->{begin}->[1] . "\"";
$status = tsrange_to_dates_and_times( $next->intvl );
return unless $status->ok;
$pl = $status->payload;
my $next_begin = "\"" . $pl->{begin}->[0] . " " . $pl->{begin}->[1] . "\"";
$t = "[ " . $this_begin . ", " . $next_begin . " )";
$status = canonicalize_tsrange( $self->context->{dbix_conn}, $t );
return unless $status->ok;
push @$result_set, $self->_gen_int( $status->payload );
}
# Given two intervals which are assumed to be in order, construct a new
# interval from the end of the first to the beginning of the second
# and push it onto @$result_set
sub _tsrange_end_to_begin {
my ( $self, $this, $next, $result_set ) = @_;
my ( $status, $pl, $t );
$status = tsrange_to_dates_and_times( $this->intvl );
return unless $status->ok;
$pl = $status->payload;
my $this_end = "\"" . $pl->{end}->[0] . " " . $pl->{end}->[1] . "\"";
$status = tsrange_to_dates_and_times( $next->intvl );
return unless $status->ok;
$pl = $status->payload;
my $next_begin = "\"" . $pl->{begin}->[0] . " " . $pl->{begin}->[1] . "\"";
$t = "[ " . $this_end . ", " . $next_begin . " )";
$status = canonicalize_tsrange( $self->context->{dbix_conn}, $t );
return unless $status->ok;
push @$result_set, $self->_gen_int( $status->payload );
}
# Given two intervals which are assumed to be in order, construct a new
# interval from the end of the first to the end of the second
# and push it onto @$result_set
sub _tsrange_end_to_end {
my ( $self, $this, $next, $result_set ) = @_;
my ( $status, $pl, $t );
$status = tsrange_to_dates_and_times( $this->intvl );
return unless $status->ok;
$pl = $status->payload;
my $this_end = "\"" . $pl->{end}->[0] . " " . $pl->{end}->[1] . "\"";
$status = tsrange_to_dates_and_times( $next->intvl );
return unless $status->ok;
$pl = $status->payload;
my $next_end = "\"" . $pl->{end}->[0] . " " . $pl->{end}->[1] . "\"";
$t = "[ " . $this_end . ", " . $next_end . " )";
$status = canonicalize_tsrange( $self->context->{dbix_conn}, $t );
return unless $status->ok;
push @$result_set, $self->_gen_int( $status->payload );
}
# Given a tempintvl object (which represents a single scheduled interval), find
# and return reference to array of existing attendance intervals that conflict
# with it.
sub _conflicting_intervals {
my ( $self, $tempintvl ) = @_;
my @conflicting_intervals = ();
my $status = fetch_intervals_by_eid_and_tsrange_inclusive(
$self->context->{'dbix_conn'},
$self->emp_obj->eid,
$tempintvl->intvl,
);
if ( $status->ok and $status->code eq 'DISPATCH_RECORDS_FOUND' ) {
foreach my $int ( @{ $status->payload } ) {
push @conflicting_intervals, $int;
}
} elsif ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
$log->debug( "Scheduled interval " . $tempintvl->intvl .
" does not overlap with any existing intervals" );
} else {
$log->crit( "IN FILLUP, FAILED TO FETCH CONFLICTING INTERVALS: " . $status->text );
}
return \@conflicting_intervals;
}
=head2 DESTROY
Instance destructor. Once we are done with the scratch intervals, they can be deleted.
Returns a status object.
=cut
sub DESTROY {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::DESTROY with arguments " . join( ' ', @_ ) );
$log->notice( "GLOBAL DESTRUCTION" ) if ${^GLOBAL_PHASE} eq 'DESTRUCT';
my $status;
try {
$dbix_conn->run( fixup => sub {
my $sth = $_->prepare( $site->SQL_TEMPINTVLS_DELETE_MULTIPLE );
$sth->bind_param( 1, $self->tiid );
$sth->execute;
my $rows = $sth->rows;
if ( $rows > 0 ) {
$status = $CELL->status_ok( 'DOCHAZKA_RECORDS_DELETED', args => [ $rows ], count => $rows );
} elsif ( $rows == 0 ) {
$status = $CELL->status_warn( 'DOCHAZKA_RECORDS_DELETED', args => [ $rows ], count => $rows );
} else {
die( "\$sth->rows returned a weird value $rows" );
}
} );
} catch {
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
};
$log->notice( "Fillup destructor says " . $status->level . ": " . $status->text );
return $status if $status;
return $CELL->status_ok;
}
=head1 FUNCTIONS
=head2 _next_tiid
Get next value from the temp_intvl_seq sequence
=cut
sub _next_tiid {
my $val;
my $status;
try {
$dbix_conn->run( fixup => sub {
( $val ) = $_->selectrow_array( $site->SQL_NEXT_TIID );
} );
} catch {
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
};
if ( $status ) {
$log->crit( $status->text );
return;
}
return $val;
}
=head2 Days_to_Date
Missing function in L<Date::Calc>
=cut
sub Days_to_Date {
my $canonical = shift;
my ( $year, $month, $day ) = Add_Delta_Days(1,1,1, $canonical - 1);
return ( $year, $month, $day );
}
=head2 _init_lower_sched_hash
Given schedule hash (JSON string from database), return schedule
hash keyed on the "low_dow" property. In other words, convert the
schedule to hash format keyed on numeric form of "low_dow" i.e. 1 for
MON, 2 for TUE, etc. The values are references to arrays containing
the entries beginning on the given DOW.
=cut
sub _init_lower_sched_hash {
my $rest_sched_json = shift;
# initialize
my $rest_sched_hash_lower = {};
foreach my $ndow ( 1 .. 7 ) {
$rest_sched_hash_lower->{ $ndow } = [];
}
# fill up
foreach my $entry ( @{ decode_json $rest_sched_json } ) {
my $ndow = $dow_to_num{ $entry->{'low_dow'} };
push @{ $rest_sched_hash_lower->{ $ndow } }, $entry;
}
return $rest_sched_hash_lower;
}
=head2 _is_holiday
Takes a date and a C<$holidays> hashref. Returns true or false.
=cut
sub _is_holiday {
my ( $datum, $holidays ) = @_;
return exists( $holidays->{ $datum } );
}
=head1 AUTHOR
Nathan Cutler, C<< <presnypreklad@gmail.com> >>
=cut
1;