source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/DataRequest.pm @ 1904

package LATMOS::Accounts::Bases::Sql::DataRequest;

use 5.010000;
use strict;
use warnings;

use LATMOS::Accounts::Utils;
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Acls::Acl;

our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Accounts::Bases::Sql::DataRequest - Object modification request

=head1 DESCRIPTION

Object to handle request forms in Link::Accounts system

=cut

=head1 FUNCTIONS

=head2 new($accreq, $id)

Instanciate a C<LATMOS::Accounts::Bases::Sql::DataRequest> object over an
existing form definition (C<$accreq>).

C<$id> is an optional DataRequest id to fetch an aready stored set of data.

=cut

sub new {
    my ($class, $accreq, $id) = @_;

    bless {
        id => $id,
        accreq => $accreq,
    }, $class
}

=head2 ar_id

Return the id of this form

=cut

sub ar_id { $_[0]->{id} }

=head2 otype

=cut

sub otype { $_[0]->accreq->get_attributes('oType') }

=head2 attributes ($attr)

Return the value for attributes C<$attr> of attached C<Accreq>.

Return attr

=cut

sub attributes {
    $_[0]->accreq->get_attributes('attributes')
}

=head2 attribute_info ($attr)

Return information for attribute C<$attr> of attached C<Accreq>.

=cut

sub attribute_info {
    my ($self, $attr) = @_;
    $self->accreq->attr_info($attr);
}

=head2 oobject

Return object attached to this form if any

=cut

sub oobject {
    my ($self) = @_;
    if (my $name = $self->object_name) {
        return $self->base->get_object($self->otype, $name);
    } else {
        return undef;
    }
}

=head2 set_ptr_object ($ptr)

Set the name of attached object, C<$ptr> can either the object name, either the
object itself.

=cut

sub set_ptr_object {
    my ($self, $ptr) = @_;

    if (ref $ptr) {
        $self->{_object_name} = $ptr->id;
    } else {
        $self->{_object_name} = $ptr;
    }
}

=head2 is_for_new_object

Return true if the form is about object creation

=cut

sub is_for_new_object {
    my ($self) = @_;

    $self->accreq->get_attributes('requireObject') ? 0 : 1;
}

# Fetch informations and cache it
sub _infos {
    my ($self) = @_;

    return $self->{_infos} if ($self->{_infos});

    my $sth = $self->accreq->db->prepare(q{
        select *, now() >= apply as due
        from request where id = ?
    });

    $sth->execute($self->ar_id);

    return $self->{_infos} = $sth->fetchrow_hashref;
}

=head2 object_name

Return the name of attached object

=cut

sub object_name {
    my ($self) = @_;

    return $self->{_object_name} if ($self->{_object_name});

    return ($self->_infos || {})->{object};
}

=head2 user

Return the user id submiting the request if any

=cut

sub user {
    my ($self) = @_;

    return ($self->_infos || {})->{user};
}

=head2 o_user

Return the user object, see L</user>

=cut

sub o_user {
    my ($self) = @_;

    my $user = ($self->_infos || {})->{user};
    return $self->base->get_object('user', $user);
}

=head2 apply

Return the date the form must be validated

=cut

sub apply {
    my ($self) = @_;

    return ($self->_infos || {})->{apply};
}

=head2 due

=cut

sub due {
    my ($self) = @_;

    return ($self->_infos || {})->{due};
}

=head2 automated

Return true if form is an automated one

=cut

sub automated {
    my ($self) = @_;

    return ($self->_infos || {})->{automated};
}

=head2 objrev

Return the object revision at form registration

=cut

sub objrev {
    my ($self) = @_;

    return ($self->_infos || {})->{objrev};
}

=head2 register ($config, %info)

Register the form. C<%info> must contains submitted informations.

C<$config> is a hashref where

=over 4

=item user

The username registering this form

=item auto

The form must automatically be validated

=item apply

The date the form must be validated

=back

=cut

sub register {
    my ($self, $config, %param) = @_;

    my $user = $config->{user};
    my $apply = $config->{apply};
    my $auto = $config->{auto};

    my $rev;

    if (!$self->is_for_new_object()) {
        if ($self->oobject) {
            $rev = $self->oobject->get_attributes('rev');
        } else {
            la_log(LA_ERR, "An object type %s is required", $self->otype);
            return;
        }
    }

    my $sth_req = $self->base->db->prepare(q{
        INSERT into request (name, object, "user", apply, automated, objrev)
        values (?,?,?,?,?,?)
        });
    $apply ||= scalar(localtime);
    $sth_req->execute($self->accreq->id, $self->object_name, $user, $apply,
        $auto ? 1 : 0, $rev) or return;

    my $newid = $self->base->db->last_insert_id(
        undef,undef,undef,undef,
        { sequence => 'request_id_seq'}
    ) or do {
        la_log(LA_ERR, "Cannot get new request id");
        $self->base->db->rollback;
        return;
    };

    my $sth_attr = $self->base->db->prepare(q{
        insert into request_attributes (reqid, attribute, value)
        values (?,?,?)
    });

    my $attr_count = 0;
    foreach ($self->attributes) {
        if (exists($param{$_})) {
            if ($self->oobject) {
                if (join('|', $self->oobject->get_attributes($_) || '')
                    eq
                    join('|', ref $param{$_} ? @{ $param{$_} } : $param{$_})) {
                    # No diff
                    next;
                }
            }
            if (!$param{$_}) {
                $attr_count += $sth_attr->execute($newid, $_, undef)
                    if ($self->oobject);
            } elsif(ref $param{$_}) {
                foreach my $v (@{$param{$_}}) {
                    $attr_count += $sth_attr->execute($newid, $_, $v);
                }
            } else {
                $attr_count += $sth_attr->execute($newid, $_, $param{$_});
            }
        }
    }

    if ($attr_count) {
        $self->{id} = $newid;
        $self->base->db->commit;
        $self->notify;
        # flush cache
        $self->{_infos} = undef;
        return 1;
    } else {
        la_log(LA_ERR, "Nothing to store into the request");
        $self->base->db->rollback;
        return;
    }
}

=head2 notify

Send mail when registering

=cut

sub notify {
    my ($self) = @_;

    if (!$self->accreq->get_attributes('notifyMail')) {
        return;
    }

    require LATMOS::Accounts::Mail;

    my $submiter = $self->user
        ? $self->base->get_object('user', $self->user)
        : undef;

    my %mail = (
        to => $self->accreq->get_attributes('notifyMail'),
        cc => ($submiter
            ? $submiter->get_attributes('mail')
            : ''),
        Subject => sprintf('New request: %s',
            $self->accreq->get_attributes('description')),
        'X-LATMOS-Reason' => 'User request',
    );

    my $text = '';

    if ($submiter) {
        $text.= "\n";
        $text .= "Request from " . $submiter->get_attributes('displayName');
        $text .= "\n";
    }

    if (my $obj = $self->oobject) {
        $text .= "For object " . $self->otype . ' ';
        $text .= $obj->id;
        if (my $dpn = $obj->get_attributes('displayName')) {
            $text .= " ($dpn)"; 
        }
        $text .= "\n\n";
    }

    my %vals = $self->get_values;
    foreach my $attr ($self->attributes) {
        if (exists($vals{$attr})) {
            foreach (ref $vals{$attr} ? @{ $vals{$attr} } : $vals{$attr}) {
                $text .= "$attr: $_\n";
            }
        }
    }

    $text .= "\n\n";
    $text .= "To apply: " . $self->apply;

    my $lamail = LATMOS::Accounts::Mail->new(
        $self->base->la,
        \$text,
    );


    if ($lamail->process(
        \%mail,
        )) {
        la_log(LA_NOTICE, "Request mail sent to %s", $mail{to});
    }
}

=head2 get_values

Return hash with registering value

=cut

sub get_values {
    my ($self) = @_;

    my $sth_f = $self->base->db->prepare(q{
        select attribute, value from request_attributes where reqid = ?
            order by attribute
    });

    my %values;
    $sth_f->execute($self->ar_id);
    while (my $res = $sth_f->fetchrow_hashref) {
        my $attr = $res->{attribute};
        if (exists($values{$attr})) {
            if (!ref($values{$attr})) {
                if (my $v = $values{$attr}) {
                    $values{$attr} = [ grep { $_ } ($v, $res->{value}) ];
                } else {
                    $values{$attr} = $res->{value};
                }
            } elsif ($res->{value}) {
                push(@{$values{$attr}}, $res->{value});
            }
        } else {
            $values{$attr} = $res->{value};
        }
    }

    %values
}

sub _register_applied {
    my ($self, $comment) = @_;

    my $sth = $self->base->db->prepare(q{
        update request set done=now(), applied = true,
        reason = ? where id = ?
    });
    $sth->execute($comment, $self->ar_id);
}

=head2 register_discard ($comment)

Discard the form

=cut

sub register_discard {
    my ($self, $comment) = @_;

    my $sth = $self->base->db->prepare(q{
        update request set done=now(), applied = false,
        reason = ? where id = ?
    });
    $sth->execute($comment, $self->ar_id);
}

sub _prepare_attrs {
    my ($self, %attrs) = @_;

    my %newvalues = $self->get_values;
    foreach (keys %attrs) {
        $newvalues{$_} = $attrs{$_};
    }
    foreach (keys %newvalues) {
        if (!$self->base->attribute($self->otype, $_)) {
            delete($newvalues{$_});
        }
    }

    return %newvalues;
}

=head2 unset_auto

Set the form has no longer automatic

=cut

sub unset_auto {
    my ($self) = @_;

    my $sth = $self->accreq->db->prepare(q{
        update request  set automated = false where id = ?
    });
    return $sth->execute($self->ar_id);
}

=head2 auto_apply_to_object ($comment)

Apply modification automatically

=cut

sub auto_apply_to_object {
    my ($self, $comment) = @_;

    if (!$self->is_for_new_object) {
        if (my $obj = $self->oobject) {
            if ($obj->get_attributes('rev') != $self->objrev) {
                $self->base->log(LA_WARN,
                    'Object %s has been modified, set request as non
                    automated');

                $self->unset_auto;
                return 1; # The automatic action "succeed"
            }
        } else {
            $self->base->log('Cannot apply to non existing object %s',
                $self->object_name);
            return;
        }
    }
    $self->apply_to_object($comment);
}

=head2 apply_to_object ($comment, %attrs)

Apply modification to the object, C<%attrs> overload informations from forms.

=cut

sub apply_to_object {
    my ($self, $comment, %attrs) = @_;

    $self->check_acl or do {
        $self->base->log(LA_ERR, 'Can\'t apply to object, permission denied by acl');
    };

    my %newvalues = $self->_prepare_attrs(%attrs);

    if ($self->is_for_new_object) {
        if ($self->base->create_object(
            $self->otype,
            $attrs{_name},
            %attrs
        )) {
            $self->_register_applied($comment);
            return 1;
        } else {
            $self->base->log(
                LA_ERR,
                'Error applying DataRequest id=%d to create object %s/%s: %s',
                $self->ar_id,
                $self->otype,
                $attrs{_name},
                $self->base->db->errstr,
            );
            return;
        }
    } else {
        my $obj = $self->oobject or return;

        if (defined($obj->set_c_fields(%newvalues)) &&
            $self->_register_applied($comment)) {
            $self->base->log(
                LA_INFO,
                'DataRequest id=%d applied to object %s/%s',
                $self->ar_id,
                $self->otype,
                $obj->id,
            );
            return 1;
        } else {
            $self->base->log(
                LA_ERR,
                'Error applying DataRequest id=%d to object %s/%s: %s',
                $self->ar_id,
                $self->otype,
                $obj->id,
                $self->base->db->errstr,
            );
            $self->base->rollback;
            return;
        }
    }
}

=head2 FUNCTION TO HANDLE OBJECT

The following functions are provided to use a
C<Datarequest> with the same way a C<LATMOS::Accounts::Bases::Object>.

See L<LATMOS::Accounts::Bases::Object> documentation.

=cut

=head2 id

=cut

sub id { $_[0]->object_name }

=head2 base

=cut

sub base { $_[0]->accreq->base }

=head2 accreq

=cut

sub accreq { $_[0]->{accreq} }

=head2 type

=cut

sub type { $_[0]->otype }

=head2 get_attributes

=cut

sub get_attributes {
    my ($self, @args) = @_;
    if ($self->ar_id) {
        # TODO not fetching all values each time
        my %values = $self->get_values;
        return $values{$args[0]};
    } elsif (my $obj = $self->oobject) {
        return $obj->get_attributes(@args);
    } else {
        return;
    }
}

=head2 attribute

=cut

sub attribute {
    my ($self, $attrname) = @_;

    my $attr = $self->_attribute($attrname);

    $attr->{_noacl} = 1;

    $attr
}

sub _attribute {
    my ($self, $attrname) = @_;

    if (my $info = $self->attribute_info($attrname)) {
        return $self->base->attribute($self->otype, $info);
    } else {
        my $obj = $self->oobject;
        my $oo =  $obj
            ? $obj->attribute($attrname)
            : $self->base->attribute($self->otype, $attrname);
        return $oo || $self->base->attribute($self->otype, { name => $attrname });
    }
}

=head2 check_acl

Return true if current connected user can validate the request

=cut

sub check_acl {
    my ($self) = @_;

    my $attr = $self->accreq->parse_form();
    if (exists($attr->{validators})) {
        my $acl = LATMOS::Accounts::Acls::Acl->new(
            '*.*',
            [ map { "  $_: write"} @{$attr->{validators} || [] } ]
        );
        my ($who, $groups) = ($self->base->user || '');
        if ($who && (my $uo = $self->base->get_object('user', $who))) {
            $groups = [ $uo->_get_attributes('memberOf') ];
        } else {
            $who = '';
        } 

        my $res = $acl->match($self->oobject || $self->otype, 'valid', 'w', $self->base->user, $groups);
        defined($res) and return $res;

        return;
    }

    # Check global Acl
    if ($self->base->check_acl('request', 'VALIDATE', 'w')) {
        return 1;
    }

    my $res = $self->_check_attr_acl;
    return $res
}

sub _check_attr_acl {
    my ($self) = @_;

    if ($self->is_for_new_object) {
        return $self->base->check_acl($self->otype, 'CREATE', 'w');
    } else {
        my $obj = $self->oobject;
        foreach my $attr ($self->attributes) {
            $self->base->check_acl($obj, $attr, 'w') or return;
        }
        return 1;
    }
}

=head2 check_is_owner

Return true if the connected user is the original requester

=cut

sub check_is_owner {
    my ($self) = @_;

    return (($self->base->user || '')  eq ($self->user || '--'))
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Bases::Sql>, L<LATMOS::Accounts::Bases::Sql::Accreq>

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut