2009-04-07 22:38:24 +02:00
|
|
|
## @file
|
|
|
|
# UserDB SAML module
|
|
|
|
|
|
|
|
## @class
|
|
|
|
# UserDB SAML module
|
|
|
|
package Lemonldap::NG::Portal::UserDBSAML;
|
|
|
|
|
|
|
|
use strict;
|
|
|
|
use Lemonldap::NG::Portal::Simple;
|
2010-02-26 11:53:43 +01:00
|
|
|
use Lemonldap::NG::Portal::_SAML;
|
2010-06-28 17:04:40 +02:00
|
|
|
use Encode;
|
2010-02-26 11:53:43 +01:00
|
|
|
our @ISA = qw(Lemonldap::NG::Portal::_SAML);
|
2009-04-07 22:38:24 +02:00
|
|
|
|
|
|
|
our $VERSION = '0.01';
|
|
|
|
|
|
|
|
## @apmethod int userDBInit()
|
|
|
|
# Check if authentication module is SAML
|
|
|
|
# @return Lemonldap::NG::Portal error code
|
|
|
|
sub userDBInit {
|
|
|
|
my $self = shift;
|
|
|
|
if ( $self->{authentication} =~ /^SAML/
|
|
|
|
or $self->{stack}->[0]->[0]->{m} =~ /^SAML/ )
|
|
|
|
{
|
|
|
|
return PE_OK;
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
return PE_ERROR;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
## @apmethod int getUser()
|
|
|
|
# Does nothing
|
|
|
|
# @return Lemonldap::NG::Portal error code
|
|
|
|
sub getUser {
|
|
|
|
PE_OK;
|
|
|
|
}
|
|
|
|
|
|
|
|
## @apmethod int setSessionInfo()
|
2010-03-01 18:16:42 +01:00
|
|
|
# Get all required attributes
|
2009-04-07 22:38:24 +02:00
|
|
|
# @return Lemonldap::NG::Portal error code
|
|
|
|
sub setSessionInfo {
|
2010-06-21 17:29:59 +02:00
|
|
|
my $self = shift;
|
|
|
|
my $idp = $self->{_idp};
|
2010-05-28 17:31:20 +02:00
|
|
|
my $idpConfKey = $self->{_idpConfKey};
|
2010-06-01 16:43:49 +02:00
|
|
|
my $nameid = $self->{_nameID};
|
2010-03-01 18:16:42 +01:00
|
|
|
|
|
|
|
my $exportedAttr;
|
|
|
|
|
2010-05-28 17:31:20 +02:00
|
|
|
# Force UTF-8
|
|
|
|
my $force_utf8 =
|
|
|
|
$self->{samlIDPMetaDataOptions}->{$idpConfKey}
|
|
|
|
->{samlIDPMetaDataOptionsForceUTF8};
|
|
|
|
|
2010-03-01 18:16:42 +01:00
|
|
|
# Get all required attributes, not already set
|
|
|
|
# in setAuthSessionInfo()
|
2010-05-31 16:54:24 +02:00
|
|
|
foreach (
|
|
|
|
keys %{ $self->{samlIDPMetaDataExportedAttributes}->{$idpConfKey} } )
|
|
|
|
{
|
2010-03-01 18:16:42 +01:00
|
|
|
|
|
|
|
# Extract fields from exportedAttr value
|
|
|
|
my ( $mandatory, $name, $format, $friendly_name ) =
|
|
|
|
split( /;/,
|
2010-05-31 16:54:24 +02:00
|
|
|
$self->{samlIDPMetaDataExportedAttributes}->{$idpConfKey}->{$_} );
|
2010-03-01 18:16:42 +01:00
|
|
|
|
|
|
|
# Keep mandatory attributes not sent in authentication response
|
|
|
|
if ( $mandatory and not defined $self->{sessionInfo}->{$_} ) {
|
|
|
|
$exportedAttr->{$_} =
|
2010-05-31 16:54:24 +02:00
|
|
|
$self->{samlIDPMetaDataExportedAttributes}->{$idpConfKey}->{$_};
|
|
|
|
$self->lmLog( "Attribute $_ will be requested to $idpConfKey",
|
|
|
|
'debug' );
|
2010-03-01 18:16:42 +01:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
unless ( keys %$exportedAttr ) {
|
|
|
|
$self->lmLog(
|
|
|
|
"All mandatory attributes were present in authentication response",
|
|
|
|
'debug'
|
|
|
|
);
|
|
|
|
return PE_OK;
|
|
|
|
}
|
|
|
|
|
2010-06-25 17:38:14 +02:00
|
|
|
# Save current Lasso::Server object, and get a new one
|
|
|
|
my $current_server = $self->{_lassoServer};
|
|
|
|
$self->loadService(1);
|
|
|
|
my $server = $self->{_lassoServer};
|
2010-06-01 14:23:11 +02:00
|
|
|
|
|
|
|
unless ($server) {
|
2010-06-25 17:38:14 +02:00
|
|
|
$self->lmLog( "Unable to create service for attribute request",
|
|
|
|
'error' );
|
2010-06-01 14:23:11 +02:00
|
|
|
return PE_ERROR;
|
|
|
|
}
|
2010-06-25 17:38:14 +02:00
|
|
|
|
2010-06-01 14:23:11 +02:00
|
|
|
$self->lmLog( "Service for attribute request created", 'debug' );
|
|
|
|
|
|
|
|
# Add current IDP as Attribute Authority
|
2010-06-25 17:38:14 +02:00
|
|
|
my $idp_metadata =
|
|
|
|
$self->{samlIDPMetaDataXML}->{$idpConfKey}->{samlIDPMetaDataXML};
|
2010-06-01 14:23:11 +02:00
|
|
|
|
2010-06-28 17:04:40 +02:00
|
|
|
if ( $self->{samlMetadataForceUTF8} ) {
|
|
|
|
$idp_metadata = encode( "utf8", $idp_metadata );
|
|
|
|
}
|
|
|
|
|
2010-06-01 14:23:11 +02:00
|
|
|
# Add this IDP to Lasso::Server as AA
|
2010-06-25 17:38:14 +02:00
|
|
|
unless ( $self->addAA( $server, $idp_metadata ) ) {
|
2010-06-01 14:23:11 +02:00
|
|
|
$self->lmLog(
|
|
|
|
"Fail to use IDP $idpConfKey Metadata as Attribute Authority",
|
|
|
|
'error' );
|
|
|
|
return PE_ERROR;
|
|
|
|
}
|
|
|
|
|
2010-03-01 18:16:42 +01:00
|
|
|
# Build Attribute Request
|
2010-06-01 16:43:49 +02:00
|
|
|
my $query =
|
|
|
|
$self->createAttributeRequest( $server, $idp, $exportedAttr, $nameid );
|
2010-03-03 17:54:23 +01:00
|
|
|
|
|
|
|
unless ($query) {
|
2010-05-31 16:54:24 +02:00
|
|
|
$self->lmLog( "Unable to build attribute request for $idpConfKey",
|
|
|
|
'error' );
|
2010-03-03 17:54:23 +01:00
|
|
|
return PE_ERROR;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Use SOAP to send request and get response
|
|
|
|
my $query_url = $query->msg_url;
|
|
|
|
my $query_body = $query->msg_body;
|
|
|
|
|
|
|
|
# Send SOAP request and manage response
|
|
|
|
my $response = $self->sendSOAPMessage( $query_url, $query_body );
|
|
|
|
|
|
|
|
unless ($response) {
|
|
|
|
$self->lmLog( "No attribute response to SOAP request", 'error' );
|
|
|
|
return PE_ERROR;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Manage Attribute Response
|
|
|
|
my $result = $self->processAttributeResponse( $server, $response );
|
|
|
|
|
|
|
|
unless ($result) {
|
|
|
|
$self->lmLog( "Fail to process attribute response", 'error' );
|
|
|
|
return PE_ERROR;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Attributes in response
|
|
|
|
my @response_attributes;
|
|
|
|
eval {
|
|
|
|
@response_attributes =
|
2010-06-02 17:21:39 +02:00
|
|
|
$result->response()->Assertion()->AttributeStatement()->Attribute();
|
2010-03-03 17:54:23 +01:00
|
|
|
};
|
|
|
|
if ($@) {
|
|
|
|
$self->lmLog( "No attributes defined in attribute response", 'error' );
|
|
|
|
return PE_ERROR;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Check we have all required attributes
|
|
|
|
foreach ( keys %$exportedAttr ) {
|
|
|
|
|
|
|
|
# Extract fields from exportedAttr value
|
|
|
|
my ( $mandatory, $name, $format, $friendly_name ) =
|
|
|
|
split( /;/, $exportedAttr->{$_} );
|
|
|
|
|
|
|
|
# Try to get value
|
|
|
|
my $value = $self->getAttributeValue( $name, $format, $friendly_name,
|
2010-05-28 17:31:20 +02:00
|
|
|
\@response_attributes, $force_utf8 );
|
2010-03-03 17:54:23 +01:00
|
|
|
|
|
|
|
unless ($value) {
|
|
|
|
$self->lmLog(
|
2010-06-02 17:21:39 +02:00
|
|
|
"Attribute $_ is mandatory, but was not delivered by $idpConfKey",
|
|
|
|
'error'
|
|
|
|
);
|
2010-03-03 17:54:23 +01:00
|
|
|
return PE_ERROR;
|
|
|
|
}
|
|
|
|
|
2010-06-02 17:21:39 +02:00
|
|
|
$self->lmLog( "Get value $value for attribute $_", 'debug' );
|
|
|
|
|
2010-03-03 17:54:23 +01:00
|
|
|
# Store value in sessionInfo
|
|
|
|
$self->{sessionInfo}->{$_} = $value;
|
|
|
|
}
|
2010-03-01 18:16:42 +01:00
|
|
|
|
2010-06-25 17:38:14 +02:00
|
|
|
# Restore current Lasso::Server
|
|
|
|
$self->{_lassoServer} = $current_server;
|
|
|
|
|
2010-03-01 18:16:42 +01:00
|
|
|
return PE_OK;
|
|
|
|
|
2009-04-07 22:38:24 +02:00
|
|
|
}
|
|
|
|
|
2009-06-04 11:13:03 +02:00
|
|
|
## @apmethod int setGroups()
|
|
|
|
# Does nothing
|
|
|
|
# @return Lemonldap::NG::Portal error code
|
|
|
|
sub setGroups {
|
|
|
|
PE_OK;
|
|
|
|
}
|
2010-03-01 18:16:42 +01:00
|
|
|
|
2009-04-07 22:38:24 +02:00
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
|
|
|
|
=head1 NAME
|
|
|
|
|
2010-01-03 09:09:59 +01:00
|
|
|
=encoding utf8
|
|
|
|
|
2010-03-01 18:16:42 +01:00
|
|
|
Lemonldap::NG::Portal::UserDBSAML - SAML User backend
|
2009-04-07 22:38:24 +02:00
|
|
|
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
|
|
|
|
use Lemonldap::NG::Portal::UserDBSAML;
|
|
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
|
2010-03-01 18:16:42 +01:00
|
|
|
Collect all required attributes trough SAML Attribute Requests
|
2009-04-07 22:38:24 +02:00
|
|
|
|
|
|
|
=head1 SEE ALSO
|
|
|
|
|
2010-03-01 18:16:42 +01:00
|
|
|
L<Lemonldap::NG::Portal>, L<Lemonldap::NG::Portal::AuthSAML>, L<Lemonldap::NG::Portal::_SAML>
|
2009-04-07 22:38:24 +02:00
|
|
|
|
|
|
|
=head1 AUTHOR
|
|
|
|
|
2010-03-01 18:16:42 +01:00
|
|
|
Xavier Guimard, E<lt>x.guimard@free.frE<gt>, Clement Oudot, E<lt>coudot@linagora.comE<gt>
|
2009-04-07 22:38:24 +02:00
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
|
|
|
|
Copyright (C) 2009 by Xavier Guimard
|
|
|
|
|
|
|
|
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
|