Acq: Line item batch update API method

[working/Evergreen.git] / Open-ILS / src / perlmods / lib / OpenILS / Application / Acq / Lineitem / BatchUpdate.pm

package OpenILS::Application::Acq::Lineitem::BatchUpdate;

use strict;
use warnings;

use base qw/OpenILS::Application/;

# All of the packages we might 'use' are already imported in
# OpenILS::Application::Acq::Lineitem.  Only those that export symbols
# need to be mentioned explicitly here.

use List::Util qw/reduce/;
use OpenSRF::Utils::Logger qw/:logger/;
use OpenILS::Utils::CStoreEditor q/:funcs/;

my $U = "OpenILS::Application::AppUtils";


# lineitem_batch_update_perm_test(), helper for lineitem_batch_update_api()
#
# Tests permissions on targeted lineitems, purchase orders, and picklists.
# Returns undef on success, event on perm failure.
# Responsible for calling $e->die_event.
# Also sanitizes values in $target.
#
sub lineitem_batch_update_perm_test {
    my ($e, $target) = @_;

    return $e->die_event(new OpenILS::Event("BAD_PARAMS", note => "target"))
        unless ref $target eq "HASH";

    my $perm_for = {
        ordering_agency => "CREATE_PURCHASE_ORDER",
        org_unit => "UPDATE_PICKLIST"
    };

    if (ref $target->{lineitems} eq "ARRAY") {
        # Sanitization
        $target->{lineitems} = [ map { int $_ } @{$target->{lineitems}} ];

        return $e->die_event(
            new OpenILS::Event(
                "BAD_PARAMS", note => "target (lineitems list empty)"
            )
        ) unless @{$target->{lineitems}};

        # Get all PO & picklist linkings from lineitems in question.
        my $li_rows = $e->json_query({
            select => {
                jub => ["id"],
                acqpo => ["ordering_agency"],
                acqpl => ["org_unit"]
            },
            from => {
                jub => {acqpl => {type => "left"}, acqpo => {type => "left"}}
            },
            where => {
                "+jub" => {id => $target->{lineitems}}
            }
        }) or return $e->die_event;

        # Fail loudly rather than giving user any surprises if they asked to
        # update lineitems that don't exist.  This is an asymmetric difference
        # calculation.
        my %present = map { $_->{id} => 1 } @$li_rows;
        my @missing = grep { not exists $present{$_} } @{$target->{lineitems}};
        return $e->die_event(
            new OpenILS::Event("ACQ_LINEITEM_NOT_FOUND", payload => \@missing)
        ) if @missing;

        # To avoid repetition of perm tests, track them here.
        my $already_done = {
            ordering_agency => {},
            org_unit => {}
        };

        # Test all lineitems based on the context OU of all linked POs AND PLs.
        foreach my $row (@$li_rows) {
            foreach my $field (keys %$already_done) {
                if ($row->{$field}) {
                    if (not $already_done->{$row}{$field}) {
                        my $perm = $perm_for->{$field};
                        my $context = $row->{$field};

                        if (not $e->allowed($perm, $context)) {
                            my $evt = $e->die_event;

                            # Take the PERM_FAILURE event and annotate it with
                            # a list of the targeted lineitems that would fail
                            # the same permission check (i.e. that have the
                            # same context).
                            $evt->{payload} = [
                                map { $_->{id} } (
                                    grep { $_->{$field} == $context } @$li_rows
                                )
                            ];
                            return $evt;
                        } else {
                            $already_done->{$row}{$field} = 1;
                        }
                    }
                }
            }
        }
    } elsif ($target->{purchase_order}) {
        $target->{purchase_order} = int($target->{purchase_order});

        my $po = $e->retrieve_acq_purchase_order($target->{purchase_order}) or
            return $e->die_event;

        return $e->die_event unless
            $e->allowed($perm_for->{ordering_agency}, $po->ordering_agency);
    } elsif ($target->{picklist}) {
        $target->{picklist} = int($target->{picklist});

        my $pl = $e->retrieve_acq_picklist($target->{picklist}) or
            return $e->die_event;

        return $e->die_event unless
            $e->allowed($perm_for->{org_unit}, $pl->org_unit);
    } else {
        return $e->die_event(
            new OpenILS::Event("BAD_PARAMS", note => "target")
        );
    }

    return; # perm check pass
}


# $changes->{item_count} wins over distribution formula if both are present.
# It's also ok for neither to be present.
sub pick_winning_item_count {
    my ($changes, $dist_formula) = @_;

    if (exists $changes->{item_count}) {
        return $changes->{item_count};
    } elsif ($dist_formula) {
        return reduce { $a + $b->item_count } 0, @{$dist_formula->entries};
    }

    return;
}


# pick_winning_change() should be called in list context, so the caller can
# distinguish between empty result (no change at all) and undef result (clear
# field).
sub pick_winning_change {
    my ($changes, $dist_formula, $field, $position) = @_;

    if (exists $changes->{$field}) {
        # Remember: in $changes, not exists means no change, while undef
        # means clear.

        return $changes->{$field} if $position >= $changes->{position};
    }

    if ($dist_formula) {
        my $hit;

        my $count_over_entries = 0;
        foreach my $entry (@{$dist_formula->entries}) {
            $count_over_entries += $entry->item_count;

            if ($count_over_entries > $position) {
                # Abuse this virtual field on the distribution formula
                # to let the caller know we actually used it.

                $dist_formula->use_count(($dist_formula->use_count || 0) + 1);
                $hit = $entry->$field;
                last;
            }
        }

        # The database doesn't give us a way to distinguish between "not exists"
        # and undef like a hash does, so for dist formulas, undef (null) has
        # to mean no change, and so if we come up with nothing defined, we
        # don't return anything, not even the undef, since that would be
        # misunderstood by the caller.
        return $hit if defined $hit;
    }

    return; # return nothing, not even undef (in list context, anyway)
}


# adjust_lineitem_copy_counts() directly changes contents of @$lineitems
sub adjust_lineitem_copy_counts {
    my ($lineitems, $item_count) = @_;

    # Count how many lineitem details we have per lineitem, and for
    # each lineitem add or remove lineitems to match $item_count, as needed.

    my %counts;

    foreach my $jub (@$lineitems) {
        $counts{$jub->id} = scalar @{$jub->lineitem_details};

        if ($counts{$jub->id} > $item_count) {
            # Take care of excess lineitem details.

            for (my $i = $item_count; $i < $counts{$jub->id}; $i++) {
                $jub->lineitem_details->[$i]->isdeleted(1);
            }
        } elsif ($counts{$jub->id} < $item_count) {
            # Add missing lineitem details.

            for (my $i = $counts{$jub->id}; $i < $item_count; $i++) {
                my $lid = new Fieldmapper::acq::lineitem_detail;
                $lid->isnew(1);
                $lid->lineitem($jub->id);

                push @{$jub->lineitem_details}, $lid;
            }
        }
    }
}


# lineitem_batch_update_impl() should be handed everything pre-perm-checked
# and ready-to-go. $e is in a transaction.
sub lineitem_batch_update_impl {
    my ($conn, $e, $dry_run, $target, $changes, $dist_formula) = @_;

    # Keep client's attention.
    $conn->status(new OpenSRF::DomainObject::oilsContinueStatus);

    # First, retrieve existing lineitems with lineitem details.  We could do
    # with the lineitem details only if not for having to catch lineitems
    # with zero current lineitem details, so that we can augment those if
    # requested by the user via $changes->{item_count}.

    # The right ordering is important for adjusting lineitem detail counts.
    my %order_by = (order_by => [
        {class => "jub", field => "id"},
        {class => "acqlid", field => "id"}
    ]);

    # XXX The following could be refactored only to retrieve one lineitem at a
    # time, since the list of fleshed lineitem_details could conceivably be
    # very long for each one. We'd then update each lineitem_detail on that
    # lineitem before proceeding to the next.

    my $lineitems;

    if ($target->{lineitems}) {
        $lineitems = $e->search_acq_lineitem(
            [
                {id => $target->{lineitems}},
                {flesh => 1,
                    flesh_fields => {"jub" => ["lineitem_details"]}, %order_by}
            ], {substream => 1}
        ) or return $e->die_event;
    } else {
        my $where;

        if ($target->{purchase_order}) {
            $where = {purchase_order => $target->{purchase_order}};
        } else {
            $where = {picklist => $target->{picklist}};
        }

        $lineitems = $e->search_acq_lineitem(
            [
                $where,
                {flesh => 1,
                    flesh_fields => {"jub" => ["lineitem_details"]}, %order_by}
            ], {substream => 1}
        ) or return $e->die_event;
    }

    $conn->status(new OpenSRF::DomainObject::oilsContinueStatus);
    $logger->info(
        "lineitem_batch_update_impl() working with " .
        scalar(@$lineitems) . " lineitems"
    );

    my $item_count = pick_winning_item_count($changes, $dist_formula);
    adjust_lineitem_copy_counts($lineitems, $item_count) if defined $item_count;

    # Now, going through all our lineitem details, make the updates
    # called for in $changes, other than the 'item_count' field (handled above).

    my @fields = qw/owning_lib fund location collection_code circ_modifier/;
    foreach my $jub (@$lineitems) {
        # We use the counting style of loop below because we need to know our
        # position for dist_formula application.

        my $starting_use_count =
            $dist_formula ? $dist_formula->use_count : undef;

        for (my $i = 0; $i < scalar @{$jub->lineitem_details}; $i++) {
            my $lid = $jub->lineitem_details->[$i];

            # Handle copies needing a delete.
            if ($lid->isdeleted) {
                $e->delete_acq_lineitem_detail($lid) or return $e->die_event;
                next;
            }

            # Handle existing and new copies.
            foreach my $field (@fields) {
                # Calling pick_winning_change() in list context gets us an
                # empty list for "no change to make", (undef) for "clear the
                # field", and ($value) for "set the field to $value".

                my @change =
                    pick_winning_change($changes, $dist_formula, $field, $i);

                if (scalar @change) {
                    my $change = pop @change;

                    if (not defined $change) {
                        my $meth = "clear_$field";
                        $lid->$meth;
                    } else {
                        $lid->$field($change);
                    }
                }
            }

            my $method = ($lid->isnew ? "create" : "update") .
                "_acq_lineitem_detail";

            $e->$method($lid) or return $e->die_event;
        }

        if (defined $starting_use_count and
            $dist_formula->use_count > $starting_use_count) {

            # Record the application of the distribution formula.
            my $dfa = new Fieldmapper::acq::distribution_formula_application;

            $dfa->lineitem($jub->id);
            $dfa->formula($dist_formula->id);
            $dfa->creator($e->requestor->id);

            $e->create_acq_distribution_formula_application($dfa) or
                return $e->die_event;
        }

        $conn->respond($jub->id);
    }

    # Explicit bare return statements below avoid sending extra data to client.
    if ($dry_run) {
        $e->rollback;
        return;
    } else {
        $e->commit or return $e->die_event;
        return;
    }
}


__PACKAGE__->register_method(
    method => "lineitem_batch_update_api",
    api_name => "open-ils.acq.lineitem.batch_update",
    signature => {
        desc => "Apply changes to the lineitem details realted to specified lineitems in batch",
        params => [
            {desc => "Authentication token", type => "string"},
            {desc => "Target. Object key must be one of lineitems, purchase_order or picklist.  The value for 'lineitems' must be an array of IDs, and the values for either of the other two must be single IDs.", type => "object"},
            {desc => "Changes (optional).  If these changes conflict with distribution formula, these changes win.", type => "object"},
            {desc => "Distribution formula ID (optional). Note that a distribution formula's 'skip_count' field does nothing, but the 'position' and 'item_count' fields of distribution formula *entries* do what they ought to. ", type => "number"}
        ],
        return => {
            desc => q/A stream of lineitem IDs affected upon success.  Events
                on failure.  ANY events in the results, even after any number
                of lineitem IDs, should be interpreted by the client to mean
                that a rollback has happened and nothing has changed./,
            type => "mixed"
        }
    }
);

__PACKAGE__->register_method(
    method => "lineitem_batch_update_api",
    api_name => "open-ils.acq.lineitem.batch_update.dry_run",
    signature => {
        desc => "Impotent version of open-ils.acq.lineitem.batch_update that always ends in a rollback",
        params => "See open-ils.acq.lineitem.batch_update",
        return => "See open-ils.acq.lineitem.batch_update"
    }
);

sub lineitem_batch_update_api {
    my ($self, $conn, $auth, $target, $changes, $dist_formula) = @_;

    # Make sure that $changes->{item_count}, if it exists, is a natural number.
    # Other things in $change are safe to treat somewhat more casually,
    # except fund, which is handled later.
    $changes ||= {};
    if (exists $changes->{item_count}) {
        $changes->{item_count} = int($changes->{item_count});
        return new OpenILS::Event("BAD_PARAMS", note => "changes (item_count)")
            unless $changes->{item_count} >= 0;
    }

    # We want to do our perm tests and everything within a transaction.
    my $e = new_editor(authtoken => $auth, xact => 1);
    return $e->die_event unless $e->checkauth;

    # If any distribution formula ID is given, fetch distribution formula
    # (with entries fleshed) early so we can get a quick permission check
    # out of the way.
    if ($dist_formula) {

        # It's important that we NOT flesh use_count here, if that [ever]
        # does anything.  We're going to abuse that field internally.

        $dist_formula = $e->acq->retrieve_acq_distribution_formula([
            int($dist_formula), {flesh=>1, flesh_fields=>["entries","fund"]}
        ]) or return $e->die_event;

        return $e->die_event unless
            $e->allowed("ADMIN_ACQ_DISTRIB_FORMULA", $dist_formula->owner);

        # If the distribution formula has a fund, there's an additional perm
        # test to do before proceeding.
        if ($dist_formula->fund) {
            return $e->die_event unless $e->allowed(
                ["ADMIN_FUND", "MANAGE_FUND"],
                $dist_formula->fund->org, $dist_formula->fund
            );
        }

        # The following sort is crucial later.
        $dist_formula->entries([
            sort { $a->position cmp $b->position } @{$dist_formula->entries}
        ]);
    }

    # Next, test permissions on fund to set, if any, from $changes.
    if ($changes->{fund}) {
        my $fund = $e->retrieve_acq_fund($changes->{fund}) or
            return $e->die_event;

        return $e->die_event unless
            $e->allowed(["ADMIN_FUND", "MANAGE_FUND"], $fund->org, $fund);
    }

    # Now test permissions on the targets.  lineitem_batch_update_perm_test()
    # calls die_event() for us if needed.  Has side-effect of target
    # sanitization.
    my $evt = lineitem_batch_update_perm_test($e, $target);
    return $evt if $U->event_code($evt);

    # Finally do the actual work.
    return lineitem_batch_update_impl(
        $conn, $e, scalar($self->api_name =~ /dry_run/),
        $target, $changes, $dist_formula
    );
}

1;