source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage.pm @ 2506

package LATMOS::Accounts::Bases::Partage;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases);
use LATMOS::Accounts::Log;

use LWP::UserAgent;
use XML::Simple;
use DateTime;
use Digest::HMAC_SHA1;
use XML::XPath;

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

=head1 NAME

    LATMOS::Accounts::Bases::Partage - Support for Renater mail solution

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases;
  my $base = LATMOS::Accounts::Bases->new('partage');
  ...

=head1 DESCRIPTION

Support for Renater Mail Solution called Partage

=cut

sub new {
    my ($class, %config) = @_;

    $config{url} =~ s:/*$:: if ( $config{url} );

    my $ua  = LWP::UserAgent->new(
        timeout => 10,
    );
    $ua->env_proxy;

    my $base = {
        apikey => $config{apikey},
        url    => $config{url} || 'https://api.partage.renater.fr/service/domain',
        domain => $config{domain},
        lwp    => $ua,
    };

    bless($base, $class);
    $base->_connect or return;

    $base;
}

sub _sendrequest {
    my ( $self, $subUri, %param ) = @_;

    my $ua = $self->{lwp};
    my $Uri = $self->{url} . '/' . $subUri;

    $Uri .= '/' . $self->{token} unless( $subUri eq 'Auth' );

    la_log(LA_DEBUG, sprintf(
            "Sending %s, %s",
            $subUri,
            join(', ', map { $_ . ' => ' . $param{ $_ } } sort keys %param)
    ));

    my $response = $ua->post( $Uri, \%param );

    unless ( $response->is_success ) {
        la_log(LA_ERR, "Cannot fetch $Uri: " . $response->status_line);
        return;
    }

    warn $response->content;
    return $response->content;
}

sub sendrequest {
    my ( $self, $subUri, %param ) = @_;


    my $res = $self->_sendrequest( $subUri, %param )
        or return;

    my $ref = XMLin(
        $res,
        forcearray => [ qw(account) ],
        KeyAttr => [],
    );

    $ref;
}

sub sendrequestasxpath {
    my ( $self, $subUri, %param ) = @_;

    my $xml = $self->_sendrequest( $subUri, %param );

    my $xpath = XML::XPath->new(xml => $xml);

    if (my $node = $xpath->findnodes('//faultstring')) {
        la_log(LA_ERR, "Saop error: %s", $node->string_value);
        return;
    }

    return $xpath;
}

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

    my $epoch = DateTime->now->epoch;
    my $clearPreauth = $self->{domain} . '|' . $epoch;
    my $preauth = Digest::HMAC_SHA1::hmac_sha1_hex( $clearPreauth, $self->{apikey} );
    my $res = $self->sendrequest(
        'Auth',
        domain    => $self->{domain},
        timestamp => DateTime->now->epoch,
        preauth   => $preauth,
    ) or return;

    $self->{token} = $res->{token};

    return $self->{token};
}

sub DESTROY {
    my ($self) = @_;
    $self->{_db} && $self->{_db}->rollback;
}


1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008-2022 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