Commit 43fb1620 authored by david.verdin's avatar david.verdin
Browse files

[feature][Submitted by M. Overmeer, overmeer.net, funded and led by Surfnet,...

[feature][Submitted by M. Overmeer, overmeer.net, funded and led by Surfnet, http://www.surfnet.nl] Full VOOT 2.0 protocol support. VOOT is an opensocial subset to manage group membership. fulle details on this IETF draft here: http://openvoot.org/voot-2.0.html. This feature enables Sympa to be both group provider and consumer in the VOOT protocol. VOOT in Sympa uses both Oauth 1.0 and 2.0 for authorization from and to a peer in the VOOT protocol.


git-svn-id: https://subversion.renater.fr/sympa/branches/sympa-6.2-branch@10081 05aa8bb8-cd2b-0410-b1d7-8918dfa770ce
parent 1ba23b1f
# Setup development paths
# Usually, this can be arranged with PERL5LIB, however we have daemons here.
use lib
'/home/sympa/lib',
'/home/sympa/ext/NetVOOT/lib',
'/home/sympa/ext/OAuth1C/lib',
'/home/sympa/ext/OAuth2C/lib',
'/home/sympa/ext/Plugin/lib',
'/home/sympa/ext/VOOT/lib'
;
1;
===== version history of Net::VOOT
version 0.11:
- more documentation
- return cleanup user data
- rename Net::VOOT::SURFnet into Net::VOOT::SURFconext
version 0.10: Tue Jan 24 13:50:10 CET 2013
- initial implementation
use ExtUtils::MakeMaker;
WriteMakefile
( NAME => 'Net::VOOT'
, VERSION => '0.11'
, PREREQ_PM =>
{ Test::More => 0
, LWP::UserAgent => '0'
}
, AUTHOR => 'Mark Overmeer'
, ABSTRACT => 'a VOOT client'
, LICENSE => 'perl'
, EXE_FILES => []
);
#### the next lines are added for OODoc, which generates the
#### distribution.
sub MY::postamble { <<'__POSTAMBLE' }
# for DIST
RAWDIR = ../public_html/net-voot/raw
DISTDIR = ../public_html/net-voot/source
LICENSE = artistic
# for POD
FIRST_YEAR = 2013
EMAIL = perl@overmeer.net
WEBSITE = http://perl.overmeer.net
__POSTAMBLE
#!/usr/bin/env perl
use warnings;
use strict;
use Net::OAuth2::Profile::WebServer;
use Net::VOOT::SURFnet;
use MIME::Base64;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 0;
# see https://frko.surfnetlabs.nl/workshop/
my %passwords =
( admin => 'adm1n' # Carlos Catalano
, teacher => 'teach3r' # Margie Korn
, jstroud => 'xDIosd9j' # Jerry Stroud
, mwisdom => 'LQ32xvaV' # Myra Wisdom
, bmcatee => 'ySVk4B9d' # Bobby Mcatee
, jmatson => '8r5yyIV3' # Janie Matson
, mcram => '62xX1Fid' # Margaret Cram
);
my %urn =
( admin => 'urn:x-oauth:entitlement:applications'
, teacher => 'urn:x-oauth:entitlement:administration'
);
@ARGV==1
or die "Usage: $0 <username>\n";
my $username = shift;
my $password = $passwords{$username}
or die "user $username does not exist. Pick from:\n "
. join(', ', sort keys %passwords) . "\n";
my $voot = Net::VOOT::SURFconext->new
( test => 1
, client_id => 'sympa'
, client_secret => 'apsym'
, redirect_uri => 'http://localhost/sympa'
);
my $token = $voot->token;
warn Dumper $token;
my $token_info_url = $auth->site_url('php-oauth/tokeninfo.php');
my $api = $auth->site_url('php-oauth/api.php');
# Implements the VOOT group interface
# https://frko.surfnetlabs.nl/workshop/voot-specification/VOOT.md
my $user = undef;
my $group = undef;
warn Dumper $voot->userGroupInfo($user);
warn Dumper $voot->groupMemberInfo($group, $user);
warn Dumper $voot->userInfo($user);
package Net::VOOT;
use warnings;
use strict;
use Log::Report 'net-voot';
use URI ();
use JSON ();
=chapter NAME
Net::VOOT - access to a VOOT Server
=chapter SYNOPSIS
my $voot = Net::VOOT->new(provider => 'surfnet');
=chapter DESCRIPTION
The VOOT (Virtual Organization Orthogonal Technology) protocol is a subset
of OpenSocial, used to manage group membership. The primary motivation
for VOOT is as a simple tool for managing virtual organization in RE<amp>E
federations.
One of the alternative specifications for VOOT can be found at
L<http://openvoot.org>
=chapter METHODS
=section Constructors
=c_method new OPTIONS
=requires provider NAME
Representative NAME for a VOOT server, mainly used in error and
log messages.
=requires voot_base URI
URI used as base for addressing the VOOT service.
=cut
sub new(@) { my $class = shift; (bless {}, $class)->init({@_}) }
sub init($)
{ my ($self, $args) = @_;
my $provider = $self->{NV_provider} = $args->{provider}
or error __x"provider needed for VOOT";
$self->{NV_voot_base} = $args->{voot_base}
or error __x"VOOT need base for {provider}", provider => $provider;
$self;
}
#---------------------------
=section Attributes
=method provider
=method vootBase
=method authType
=cut
sub provider() {shift->{NV_provider}}
sub vootBase() {shift->{NV_voot_base}}
sub authType() {panic "not implemented"}
#---------------------------
=section Sessions
=method newSession OPTIONS
Create a new session, which will trigger authentication.
=method restoreSession DATA
=cut
sub newSession(%) { panic "not implemented" }
sub restoreSession(%) { panic "not implemented" }
#---------------------------
=section Actions
=subsection Interpreted return
=method userGroups [USER]
Returns a HASH which contains information about all groups for the USER,
by default '@me'. The HASH maps group-id's to a HASH with more info about
that group.
=cut
sub userGroups(;$)
{ my $self = shift;
my $user = shift || '@me';
my $r = $self->userGroupInfo($user) or return {};
use Data::Dumper;
if(open OUT, '>/tmp/user-groups') {print OUT Dumper $r; close OUT }
my $got = $r->{entry} or return {};
my %groups;
foreach my $g (@$got)
{ my $id = $g->{id};
$groups{$id} =
{ name => $g->{title}
, id => $id
, description => $g->{description}
, role => $g->{voot_membership_role}
};
}
if(open OUT, '>/tmp/user-groups2') {print OUT Dumper \%groups; close OUT }
\%groups;
}
=method groupMembership GROUP, [USER]
Returns a LIST of membership records (HASHes).
=cut
sub groupMembership($;$)
{ my $self = shift;
my $r = $self->groupMemberInfo(@_) or return ();
my $got = $r->{entry} or return ();
my @members;
foreach my $m (@$got)
{ my $emails = $m->{emails} or next;
my @emails = map {ref $_ eq 'HASH' ? $_->{value} : $_} @$emails;
my %member =
( name => $m->{displayName}
, emails => \@emails
, role => $m->{voot_membership_role}
);
push @members, \%member;
}
@members;
}
=method user [USER]
=cut
sub user(;$)
{ my $self = shift;
my $user = shift || '@me';
my $r = $self->userInfo($user);
my $info = $r->{entry}[0] or return;
+{ name => $info->{displayName}
, id => $info->{id}
, email => $info->{mail}
};
}
#---------------------------
=subsection Raw return information
=method userGroupInfo [USER][REQPARAMS]
Returns a raw HASH of information about the groups of the USER.
M<userGroups()> is more convenient.
=cut
sub userGroupInfo(;$%)
{ my $self = shift;
my $user = (@_%2 ? shift : undef) || '@me';
my %params = @_;
$self->query("/groups/$user", \%params);
}
=method groupMemberInfo GROUP, [USER], [REQPARAMS]
Returns a raw HASH of information about USER in GROUP.
M<groupMembership()> is more convenient.
=cut
sub groupMemberInfo($;$)
{ my $self = shift;
my $groupid = shift;
my $userid = (@_%1 ? shift: undef) || '@me';
my %params = @_;
$self->query("/people/$userid/$groupid", \%params);
}
=method userInfo [USER][REQPARAMS]
Returns a raw HASH with information about the user.
=cut
sub userInfo(;$%)
{ my $self = shift;
my $user = (@_%1 ? shift : undef) || '@me';
my %params = @_;
$self->query("/people/$user", \%params);
}
#---------------------------
=section Helpers
=method get URI
=cut
sub get($) { panic }
=method query ACTION, PARAMS
Call the VOOT server to perform ACTION. Generic query parameters:
C<sortBy>, C<startIndex>, and C<count>.
=cut
sub query($$)
{ my ($self, $action, $params) = @_;
my $uri = URI->new($self->vootBase.$action);
$uri->query_form($params) if $params;
my $resp = $self->get($uri->as_string)
or return;
my $data = JSON->new->decode($resp->decoded_content || $resp->content);
use Data::Dumper;
if(open OUT, '>/tmp/query') {print OUT Dumper $data; close OUT}
$data;
}
=method hasAccess
Returns true when there is a token to use with the VOOT provider.
=cut
sub hasAccess() { panic "not implemented" }
=method getAuthorizationStarter
=cut
sub getAuthorizationStarter() {panic}
1;
package Net::VOOT::Renater;
use base 'Net::VOOT';
use warnings;
use strict;
use Log::Report 'net-voot';
use OAuth::Lite::Consumer ();
use OAuth::Lite::Token ();
# default parameters for Renater servers
# XXX MO: to be filled in
my %auth_defaults;
=chapter NAME
Net::VOOT::Renater - access to a VOOT server of Renater
=chapter SYNOPSIS
my $voot = Net::VOOT::Renater->new(auth => $auth);
=chapter DESCRIPTION
This module provides an implementation of a VOOT client in a Renater-style
VOOT setup, which may be served via Sympa.
=chapter METHODS
=section Constructors
=c_method new OPTIONS
=requires auth M<OAuth::Lite::Consumer>|HASH
=cut
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args) or return;
my $auth = $args->{auth};
$auth = OAuth::Lite::Consumer->new(%auth_defaults, %$auth)
if ref $auth eq 'HASH';
$self->{NVR_auth} = $auth
or error __x"no configuration for authorization provided";
$self;
}
#---------------------------
=section Attributes
=method auth
=cut
sub auth() {shift->{NVR_auth}}
sub authType() { 'OAuth1' }
#---------------------------
=section Actions
=cut
sub get($$$)
{ my ($self, $session, $url, $params) = @_;
my $resp = $self->auth->request
( method => 'GET'
, url => $url
, token => $self->accessToken($session)
, params => $params
);
return $resp
if $resp->is_success;
if($resp->status > 400)
{ my $auth_header = $resp->header('WWW-Authenticate') || '';
# access token may be expired, retry
$self->triggerFlow if $auth_header =~ /^OAuth/;
}
$resp;
}
=method getAuthorizationStarter SESSION
=cut
sub getAuthorizationStarter($)
{ my ($self, $session) = @_;
$self->auth->url_to_authorize(token => $session->requestToken);
}
=section Session
The session is managed outside the scope of this module. However, it
is a HASH which contains a C<request> (request token) and C<access>
(access token) field. Both may be either undefined or an
L<OAuth::Lite::Token>.
=method getRequestToken SESSION, CALLBACK
=cut
sub getRequestToken($$)
{ my ($self, $session, $callback) = @_;
my $req_token = $self->auth->get_request_token(callback_url => $callback)
or error __x"unable to get request token: {err}", $auth->errstr;
$session->{request} = $req_token;
}
=method requestToken SESSION
=cut
sub requestToken($)
{ my ($self, $session) = @_;
$session->{request};
}
=method accessToken SESSION
=cut
sub accessToken($)
{ my ($self, $session) = @_;
$session->{access};
}
1;
package Net::VOOT::SURFconext;
use base 'Net::VOOT';
use warnings;
use strict;
use Log::Report 'net-voot';
use Net::OAuth2::Profile::WebServer ();
use Scalar::Util qw/blessed/;
my $test_site = 'https://frko.surfnetlabs.nl/frkonext/';
my $live_site = 'https://api.surfconext.nl/v1';
my %providers =
( 'surfconext-test' =>
{ voot_base => "$test_site/php-voot-proxy/voot.php"
, oauth2 =>
{ site => $test_site
, authorize_path => 'php-oauth/authorize.php'
, access_token_path => 'php-oauth/token.php'
}
}
, surfconext =>
{ voot_base => "$live_site/social/rest"
, oauth2 =>
{ site => "$live_site/oauth2/"
, authorize_path => 'authorize'
, access_token_path => 'token'
}
}
);
=chapter NAME
Net::VOOT::SURFconext - access to a VOOT server of SURFnet
=chapter SYNOPSIS
my $voot = Net::VOOT::SURFconext->new(test => 1);
=chapter DESCRIPTION
"SURFconext" is a Dutch (i.e. The Netherlands) national infrastructure
(organized by SURFnet) which arranges access rights to people on
universities and research institutes (participants) to facilities offered
by other participants. For instance, a student on one university can
use the library and WiFi of an other university when he is on visit there.
SURFconext uses OAuth2 authentication.
=chapter METHODS
=section Constructors
=c_method new OPTIONS
=requires provider 'surfconext'|'surfconext-test'
=default voot_base <depends on provider>
=option auth M<Net::OAuth2::Profile::WebServer>|HASH
=default auth <created for you>
If you do not provide an object, you need to add some parameters to
initialize the object. See M<createAuth()> for the OPTIONS.
=option token M<Net::OAuth2::AccessToken>-object
=default token <requested when needed>
=cut
sub init($)
{ my ($self, $args) = @_;
my $provid = $args->{provider} || 'surfconext';
my $config = $providers{$provid}
or error __x"unknown provider `{name}' for SURFconext", name => $provid;
$args->{voot_base} ||= $config->{voot_base};
$self->SUPER::init($args) or return;
$self->{NVS_token} = $args->{token};
my $auth = $args->{auth};
$self->{NVS_auth} = blessed $auth ? $auth : $self->createAuth(%$auth);
$self;
}
#---------------------------
=section Attributes
=method auth
=method authType
=method token
=cut
sub authType() { 'OAuth2' }
sub auth() {shift->{NVS_auth}}
sub token() {shift->{NVS_token}}
sub site() {shift->{NVS_site}}
=method setAccessToken TOKEN
=cut
sub setAccessToken($) { $_[0]->{NVS_token} = $_[1] }
#---------------------------
=section Actions
=cut
sub get($)
{ my ($self, $uri) = @_;
my $token = $self->token or return;
$token->get($uri);
}
#---------------------------
=section Helpers
=method createAuth OPTIONS
Returns an M<Net::OAuth2::Profile::WebServer> object.
The C<client_id>, C<client_secret> and C<redirect_uri> are registered
at the VOOT provider: they relate to the C<site>.
=requires site URI
=requires client_id STRING
=requires client_secret PASSWORD
=requires redirect_uri URI
=cut
sub createAuth(%)
{ my ($self, %args) = @_;
my $provname = $self->provider;
my $settings = $providers{$provname}{oauth2}
or error __x"unknown oauth2 provider `{name}' for SURFconext"
, name => $provname;