269 lines
8.4 KiB
Perl
269 lines
8.4 KiB
Perl
## @file
|
|
# Subclass of Net::OpenID::Server that manage OpenID extensions
|
|
|
|
## @class
|
|
# Subclass of Net::OpenID::Server that manage OpenID extensions
|
|
package Lemonldap::NG::Portal::OpenID::Server;
|
|
|
|
use strict;
|
|
use base qw(Net::OpenID::Server);
|
|
use fields qw(_extensions);
|
|
use Net::OpenID::Server;
|
|
use Lemonldap::NG::Common::Regexp;
|
|
|
|
use constant DEBUG => 0;
|
|
|
|
our $VERSION = '1.0.0';
|
|
|
|
my $OPENID2_NS = qq!http://specs.openid.net/auth/2.0!;
|
|
my $OPENID2_ID_SELECT = qq!http://specs.openid.net/auth/2.0/identifier_select!;
|
|
|
|
*_push_url_arg = *Net::OpenID::Server::_push_url_arg;
|
|
|
|
## @cmethod Lemonldap::NG::Portal::OpenID::Server new(hash opts)
|
|
# Call Net::OpenID::Server::new() and store extensions
|
|
# @param %opts Net::OpenID::Server options
|
|
# @return Lemonldap::NG::Portal::OpenID::Server new object
|
|
sub new {
|
|
my $class = shift;
|
|
my $self = fields::new($class);
|
|
my %opts = splice @_;
|
|
$self->$_( delete $opts{$_} ) foreach (qw(extensions));
|
|
$self->SUPER::new(%opts);
|
|
|
|
#$self->{get_args} = sub { $self->param(@_) };
|
|
}
|
|
|
|
## @method protected void extensions()
|
|
# Manage "extensions" constructor parameter
|
|
sub extensions {
|
|
my $self = shift;
|
|
$self->{_extensions} = shift;
|
|
}
|
|
|
|
## @method protected list _mode_checkid(string mode, boolean redirect_for_setup)
|
|
# Overload Net::OpenID::Server::_mode_checkid to call extensions hook
|
|
# @param $mode OpenID mode
|
|
# @param $redirect_for_setup indicates that user must be redirected or not for
|
|
# setup
|
|
# @return (string $type, hashref parameters)
|
|
sub _mode_checkid {
|
|
my Lemonldap::NG::Portal::OpenID::Server $self = shift;
|
|
my ( $mode, $redirect_for_setup ) = @_;
|
|
|
|
my $return_to = $self->args("openid.return_to");
|
|
return $self->_fail("no_return_to")
|
|
unless ( $return_to
|
|
and $return_to =~ Lemonldap::NG::Common::Regexp::HTTP_URI );
|
|
|
|
my $trust_root = $self->args("openid.trust_root") || $return_to;
|
|
$trust_root = $self->args("openid.realm")
|
|
if $self->args('openid.ns') eq $OPENID2_NS;
|
|
return $self->_fail("invalid_trust_root")
|
|
unless ( $trust_root =~ Lemonldap::NG::Common::Regexp::HTTP_URI
|
|
and Net::OpenID::Server::_url_is_under( $trust_root, $return_to ) );
|
|
|
|
my $identity = $self->args("openid.identity");
|
|
|
|
# chop off the query string, in case our trust_root came from the return_to URL
|
|
$trust_root =~ s/\?.*//;
|
|
|
|
my $u = $self->_proxy("get_user");
|
|
if ( $self->args('openid.ns') eq $OPENID2_NS
|
|
&& $identity eq $OPENID2_ID_SELECT )
|
|
{
|
|
$identity = $self->_proxy( "get_identity", $u, $identity );
|
|
}
|
|
my $is_identity = $self->_proxy( "is_identity", $u, $identity );
|
|
my $is_trusted =
|
|
$self->_proxy( "is_trusted", $u, $trust_root, $is_identity );
|
|
|
|
my ( %extVars, %is_ext_trusted );
|
|
my $is_exts_trusted = 1;
|
|
if ( ref( $self->{_extensions} ) ) {
|
|
my @list = $self->get_args->();
|
|
my %extArgs;
|
|
foreach my $arg (@list) {
|
|
next unless ( $arg =~ /^openid\.(\w+)\.([\w\.]+)?/ );
|
|
my $tmp = $1;
|
|
my $val = $2;
|
|
$extArgs{$tmp}->{$val} = scalar $self->args->($arg);
|
|
}
|
|
foreach my $ns ( keys %{ $self->{_extensions} } ) {
|
|
print STDERR "Launching OpenIP $ns hook\n" if (DEBUG);
|
|
my $h;
|
|
( $is_ext_trusted{$ns}, $h ) = $self->{_extensions}->{$ns}->(
|
|
$u, $trust_root, $is_identity, $is_trusted,
|
|
delete( $extArgs{$ns} ) || {}
|
|
);
|
|
if ($h) {
|
|
while ( my ( $k, $v ) = each %$h ) {
|
|
print STDERR "$ns returned data: $k => $v\n" if (DEBUG);
|
|
$extVars{"$ns.$k"} = $v;
|
|
}
|
|
}
|
|
$is_exts_trusted &&= $is_ext_trusted{$ns};
|
|
}
|
|
|
|
# TODO: warn if keys(%extArgs)
|
|
}
|
|
|
|
# assertion path:
|
|
if ( $is_identity && $is_trusted && $is_exts_trusted ) {
|
|
my %sArgs = (
|
|
identity => $identity,
|
|
claimed_id => $self->args('openid.claimed_id'),
|
|
return_to => $return_to,
|
|
assoc_handle => $self->args("openid.assoc_handle"),
|
|
ns => $self->args('openid.ns'),
|
|
);
|
|
$sArgs{additional_fields} = \%extVars if (%extVars);
|
|
my $ret_url = $self->signed_return_url(%sArgs);
|
|
return ( "redirect", $ret_url );
|
|
}
|
|
|
|
# Assertion could not be made, so user requires setup (login/trust...
|
|
# something). Two ways that can happen: caller might have asked us for an
|
|
# immediate return with a setup URL (the default), or explictly said that
|
|
# we're in control of the user-agent's full window, and we can do whatever
|
|
# we want with them now.
|
|
|
|
# TODO: call extension sub for setup
|
|
my %setup_args = (
|
|
$self->_setup_map("trust_root"), $trust_root,
|
|
$self->_setup_map("realm"), $trust_root,
|
|
$self->_setup_map("return_to"), $return_to,
|
|
$self->_setup_map("identity"), $identity,
|
|
$self->_setup_map("assoc_handle"), $self->args("openid.assoc_handle"),
|
|
%extVars,
|
|
);
|
|
$setup_args{ $self->_setup_map('ns') } = $self->args('openid.ns')
|
|
if $self->args('openid.ns');
|
|
|
|
my $setup_url = $self->{setup_url}
|
|
or Carp::croak("No setup_url defined.");
|
|
_push_url_arg( \$setup_url, %setup_args );
|
|
|
|
if ( $mode eq "checkid_immediate" ) {
|
|
my $ret_url = $return_to;
|
|
if ( $self->args('openid.ns') eq $OPENID2_NS ) {
|
|
_push_url_arg( \$ret_url, "openid.ns", $self->args('openid.ns') );
|
|
_push_url_arg( \$ret_url, "openid.mode", "setup_needed" );
|
|
}
|
|
else {
|
|
_push_url_arg( \$ret_url, "openid.mode", "id_res" );
|
|
_push_url_arg( \$ret_url, "openid.user_setup_url", $setup_url );
|
|
}
|
|
return ( "redirect", $ret_url );
|
|
}
|
|
else {
|
|
|
|
# the "checkid_setup" mode, where we take control of the user-agent
|
|
# and return to their return_to URL later.
|
|
|
|
if ($redirect_for_setup) {
|
|
return ( "redirect", $setup_url );
|
|
}
|
|
else {
|
|
return ( "setup", \%setup_args );
|
|
}
|
|
}
|
|
}
|
|
|
|
#*args = \&get_args;
|
|
|
|
#sub get_args {
|
|
# my $self = shift;
|
|
#
|
|
# if ( my $what = shift ) {
|
|
# Carp::croak("Too many parameters") if @_;
|
|
#
|
|
# # Lemonldap::NG only (direct CGI)
|
|
# $self->{get_args} = sub { $what->param( $_[0] ) };
|
|
#
|
|
# # INCLUDE IN PROPOSED PATCH FOR Net::OpenID::Server
|
|
# #my $getter;
|
|
# #if ( !ref $what ) {
|
|
# # Carp::croak("No get_args defined") unless $self->{get_args};
|
|
# # return $self->{get_args}->($what) || "";
|
|
# #}
|
|
# #elsif ( ref $what eq "HASH" ) {
|
|
# # $getter = sub { $_[0] ? $what->{ $_[0] } : ( keys %$what ); };
|
|
# #}
|
|
# #elsif ( ref $what eq "Apache" ) {
|
|
# # my %get = $what->args;
|
|
# # $getter = sub { $_[0] ? $get{ $_[0] } : ( keys %get ); };
|
|
# #}
|
|
# #elsif ( ref $what eq "CODE" ) {
|
|
# # $getter = $what;
|
|
# #}
|
|
# #else {
|
|
# # my $r = eval { $what->can('param') };
|
|
# # if ( $@ or not $r ) {
|
|
# # Carp::croak("Unknown parameter type ($what)");
|
|
# # }
|
|
# # else {
|
|
# # $getter = sub {
|
|
# # $_[0] ? scalar $what->param( $_[0] ) : ( $what->param() );
|
|
# # };
|
|
# # }
|
|
# #}
|
|
# #if ($getter) {
|
|
# # $self->{get_args} = $getter;
|
|
# #}
|
|
# }
|
|
# $self->{get_args};
|
|
#}
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Lemonldap::NG::Portal::OpenID::Server - Add capability to manage extensions to
|
|
Net::OpenID::Server
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Lemonldap::NG::Portal::OpenID::Server;
|
|
blah blah blah
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Stub documentation for Lemonldap::NG::Portal::OpenID::Server, created by h2xs. It looks like the
|
|
author of the extension was negligent enough to leave the stub
|
|
unedited.
|
|
|
|
Blah blah blah.
|
|
|
|
=head2 EXPORT
|
|
|
|
None by default.
|
|
|
|
|
|
|
|
=head1 SEE ALSO
|
|
|
|
Mention other useful documentation such as the documentation of
|
|
related modules or operating system documentation (such as man pages
|
|
in UNIX), or any relevant external documentation such as RFCs or
|
|
standards.
|
|
|
|
If you have a mailing list set up for your module, mention it here.
|
|
|
|
If you have a web site set up for your module, mention it here.
|
|
|
|
=head1 AUTHOR
|
|
|
|
guimard, E<lt>guimard@E<gt>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
Copyright (C) 2010 by 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
|