Open-ILS/src/perlmods/OpenILS/Utils/Penalty.pm

   1 package OpenILS::Utils::Penalty;
   2 use strict; use warnings;
   3 use DateTime;
   4 use Data::Dumper;
   5 use OpenSRF::EX qw(:try);
   6 use OpenSRF::Utils::Cache;
   7 use OpenSRF::Utils qw/:datetime/;
   8 use OpenILS::Application::AppUtils;
   9 use OpenSRF::Utils::Logger qw(:logger);
  10 use OpenILS::Utils::CStoreEditor qw/:funcs/;
  11 use OpenILS::Utils::Fieldmapper;
  12 use OpenILS::Const qw/:const/;
  13 my $U = "OpenILS::Application::AppUtils";
  14
  15
  16 # calculate and update the well-known penalties
  17 sub calculate_penalties {
  18     my($class, $e, $user_id, $user) = @_;
  19
  20     $user = $user || $e->retrieve_actor_user($user_id);
  21     $user_id = $user->id;
  22     my $grp_id = (ref $user->profile) ? $user->profile->id : $user->profile;
  23
  24     my $penalties = $e->search_actor_user_standing_penalty({usr => $user_id});
  25     my $stats = $class->collect_user_stats($e, $user_id);
  26     my $overdue = $stats->{overdue};
  27     my $mon_owed = $stats->{money_owed};
  28     my $thresholds = $class->get_group_penalty_thresholds($e, $grp_id);
  29
  30     $logger->info("patron $user_id in group $grp_id has $overdue overdue circulations and owes $mon_owed");
  31
  32     for my $thresh (@$thresholds) {
  33         my $evt;
  34
  35         if($thresh->penalty == OILS_PENALTY_PATRON_EXCEEDS_FINES) {
  36             $evt = $class->check_apply_penalty(
  37                 $e, $user_id, $penalties, OILS_PENALTY_PATRON_EXCEEDS_FINES, $thresh->threshold, $mon_owed);
  38             return $evt if $evt;
  39         }
  40
  41         if($thresh->penalty == OILS_PENALTY_PATRON_EXCEEDS_OVERDUE_COUNT) {
  42             $evt = $class->check_apply_penalty(
  43                 $e, $user_id, $penalties, OILS_PENALTY_PATRON_EXCEEDS_OVERDUE_COUNT, $thresh->threshold, $overdue);
  44             return $evt if $evt;
  45         }
  46     }
  47 }
  48
  49 # if a given penalty does not already exist in the DB, this creates it.
  50 # If it does exist and should not, this removes it.
  51 sub check_apply_penalty {
  52     my($class, $e, $user_id, $all_penalties, $penalty_id, $threshold, $value) = @_;
  53     my ($existing) = grep { $_->standing_penalty == $penalty_id } @$all_penalties;
  54
  55     # penalty threshold has been exceeded and needs to be added
  56     if($value >= $threshold and not $existing) {
  57         my $newp = Fieldmapper::actor::user_standing_penalty->new;
  58         $newp->standing_penalty($penalty_id);
  59         $newp->usr($user_id);
  60         $e->create_actor_user_standing_penalty($newp) or return $e->die_event;
  61
  62     # patron is within penalty range and existing penalty must be removed
  63     } elsif($value < $threshold and $existing) {
  64         $e->delete_actor_user_standing_penalty($existing)
  65             or return $e->die_event;
  66     }
  67
  68     return undef;
  69 }
  70
  71
  72 sub collect_user_stats {
  73     my($class, $e, $user_id) = @_;
  74
  75     my $stor_ses = $U->start_db_session();
  76         my $money_owed = $stor_ses->request(
  77         'open-ils.storage.actor.user.total_owed', $user_id)->gather(1);
  78     my $checkouts = $stor_ses->request(
  79             'open-ils.storage.actor.user.checked_out.count', $user_id)->gather(1);
  80         $U->rollback_db_session($stor_ses);
  81
  82     return {
  83         overdue => $checkouts->{overdue} || 0,
  84         money_owed => $money_owed || 0
  85     };
  86 }
  87
  88 # get the ranged set of penalties for a give group
  89 # XXX this could probably benefit from a stored proc
  90 sub get_group_penalty_thresholds {
  91     my($class, $e, $grp_id) = @_;
  92     my @thresholds;
  93     my $cur_grp = $grp_id;
  94     do {
  95         my $thresh = $e->search_permission_grp_penalty_threshold({grp => $cur_grp});
  96         for my $t (@$thresh) {
  97             push(@thresholds, $t) unless (grep { $_->name eq $t->name } @thresholds);
  98         }
  99     } while(defined ($cur_grp = $e->retrieve_permission_grp_tree($cur_grp)->parent));
 100
 101     return \@thresholds;
 102 }
 103
 104
 105 # any penalties whose block_list has an item from @fatal_mask will be sorted
 106 # into the fatal_penalties set.  Others will be sorted into the info_penalties set
 107 sub retrieve_penalties {
 108     my($class, $e, $user_id, @fatal_mask) = @_;
 109
 110     my $penalties = $e->search_actor_user_standing_penalty([
 111         {usr => $user_id},
 112         {flesh => 1, flesh_fields => {ausp => ['standing_penalty']}}
 113     ]);
 114
 115     my(@info, @fatal);
 116     for my $p (@$penalties) {
 117         my $pushed = 0;
 118         if($p->standing_penalty->block_list) {
 119             for my $m (@fatal_mask) {
 120                 if($p->standing_penalty->block_list =~ /$m/) {
 121                     push(@fatal, $p->name);
 122                     $pushed = 1;
 123                 }
 124             }
 125         }
 126         push(@info, $p->name) unless $pushed;
 127     }
 128
 129     return {fatal_penalties => \@fatal, info_penalties => \@info};
 130 }
 131
 132 1;