[libnet-openid-consumer-perl] 09/39: new upstream release
Damyan Ivanov
dmn at moszumanska.debian.org
Fri Jul 24 13:08:14 UTC 2015
This is an automated email from the git hooks/post-receive script.
dmn pushed a commit to branch master
in repository libnet-openid-consumer-perl.
commit 9a119fbb5e67145247d43af601a5a7be10166fe9
Author: Dominic Hargreaves <dom at earth.li>
Date: Fri Jun 5 16:13:55 2009 +0000
new upstream release
---
ChangeLog | 68 +++-
MANIFEST | 7 +
META.yml | 6 +-
Makefile.PL | 2 +-
debian/changelog | 6 +
debian/control | 3 +-
lib/Net/OpenID/Association.pm | 29 +-
lib/Net/OpenID/ClaimedIdentity.pm | 176 ++++++++--
lib/Net/OpenID/Consumer.pm | 678 +++++++++++++++++++++++++++++++------
lib/Net/OpenID/IndirectMessage.pm | 255 ++++++++++++++
lib/Net/OpenID/URIFetch.pm | 183 ++++++++++
lib/Net/OpenID/VerifiedIdentity.pm | 149 +++++++-
lib/Net/OpenID/Yadis.pm | 453 +++++++++++++++++++++++++
lib/Net/OpenID/Yadis/Service.pm | 74 ++++
t/01-misc.t | 6 +-
t/02-canonical.t | 35 ++
t/03-messages.t | 150 ++++++++
17 files changed, 2131 insertions(+), 149 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 64a8e15..99c0c8c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,72 @@
+1.03:
+
+ * Enforce the rules from the Auth 2.0 spec about which fields
+ MUST be signed in positive assertion messages.
+
+ * Return a more sensible error (no_head_tag) if the identifier
+ URL returns an empty (0-byte) HTML document.
+
+ * Verify delegate on the non-fragment version of the resulting
+ identifier, so that you can delegate to providers that add
+ fragments to their identifiers.
+ Found and fixed by avarix <mindsectr at gmail.com>.
+
+1.02:
+
+ * Declare dependency on XML::Simple
+
+1.01:
+
+ * Make the verified_identity bit accept assertions from any
+ declared endpoint, rather than only the primary one.
+ This implementation kinda sucks because it hits the identity
+ URL over and over doing discovery.
+
+ * Refactor the discovery code a little so that the whole list
+ of valid endpoints can optionally be returned. This is in
+ preparation for fixing the assertion verification code
+ so that providers other than the primary one are able to
+ make assertions.
+
+ * Support indirect messages encapsualated in POST requests
+ when args are given as a CGI, Apache, or Apache::Request
+ object.
+
+ * Support the 1.1 and 1.0 namespace values required by
+ Auth 2.0 section 4.1.2.
+
+ * Deal with cases where Net::OpenID::Yadis returns arrayref
+ or hashref for Service->URI, including a basic support for
+ the priority attribute. Based on a patch from
+ Fumiaki Yoshimatsu <fyoshimatsu at sixapart.com>.
+
+ * when dealing with a 2.0 server, send 2.0-shaped association
+ requests.
+
+ * add the set_extension_args method to ClaimedIdentity and the
+ extension_fields and signed_extension_fields methods to
+ VerifiedIdentity, which together form a higher-level API
+ for using protocol extensions such as SREG and PAPE.
+
+ * add support for OpenID 2.0-style messages from providers
+
+ * use our own simplified fork of Net::Yadis::Discovery to avoid
+ dependency on Module::Pluggable::Fast. Or on Net::Yadis::Discovery,
+ for that matter.
+
+ * add hooks for openid-test project. (bradfitz)
+
+ * add OpenID 2.0-compliant discovery and authentication request.
+
+ * add method on claimed identity object to get delgated URL
+
0.14: (2007-08-03)
- * allow CGI subclasses (like CGI::Fast) for args. bug fix
- from Chris Kastorff <encryptio at gmail.com>.
+ * allow CGI subclasses (like CGI::Fast) for args. bug fix
+ from Chris Kastorff <encryptio at gmail.com>.
0.13:
- * work-around bug in some openid servers that don't escape "+".
+ * work-around bug in some openid servers that don't escape "+".
so treat a space as a +. (from Thomas Sibley
<trs at bestpractical.com>)
diff --git a/MANIFEST b/MANIFEST
index 2b04e47..ab0ad88 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5,6 +5,13 @@ lib/Net/OpenID/Consumer.pm
lib/Net/OpenID/VerifiedIdentity.pm
lib/Net/OpenID/ClaimedIdentity.pm
lib/Net/OpenID/Association.pm
+lib/Net/OpenID/IndirectMessage.pm
+lib/Net/OpenID/URIFetch.pm
+lib/Net/OpenID/Yadis.pm
+lib/Net/OpenID/Yadis/Service.pm
t/00-use.t
t/01-misc.t
+t/02-canonical.t
+t/03-messages.t
+
META.yml Module meta-data (added by MakeMaker)
diff --git a/META.yml b/META.yml
index 8fdf095..47ccb83 100644
--- a/META.yml
+++ b/META.yml
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Net-OpenID-Consumer
-version: 0.14
+version: 1.03
version_from: lib/Net/OpenID/Consumer.pm
installdirs: site
requires:
@@ -12,7 +12,7 @@ requires:
MIME::Base64: 0
Time::Local: 0
URI: 0
- URI::Fetch: 0.02
+ XML::Simple: 0
distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.17
+generated_by: ExtUtils::MakeMaker version 6.30_01
diff --git a/Makefile.PL b/Makefile.PL
index 57c1f75..63a7294 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -8,7 +8,7 @@ WriteMakefile( 'NAME' => 'Net::OpenID::Consumer',
'Digest::SHA1' => 0,
'URI' => 0,
'Time::Local' => 0,
- 'URI::Fetch' => 0.02,
+ 'XML::Simple' => 0,
'Crypt::DH' => 0.05,
},
($] >= 5.005 ?
diff --git a/debian/changelog b/debian/changelog
index 1a20769..2e41ee5 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+libnet-openid-consumer-perl (1.03-1) UNRELEASED; urgency=low
+
+ * New upstream release (closes: #531748)
+
+ -- Dominic Hargreaves <dom at earth.li> Fri, 05 Jun 2009 17:05:00 +0100
+
libnet-openid-consumer-perl (0.14-4) unstable; urgency=low
* Remove dependency and build-dependency on libmime-tools-perl; only
diff --git a/debian/control b/debian/control
index 3d9f85e..1142053 100644
--- a/debian/control
+++ b/debian/control
@@ -10,8 +10,7 @@ Homepage: http://search.cpan.org/dist/Net-OpenID-Consumer/
Package: libnet-openid-consumer-perl
Architecture: all
Depends: ${perl:Depends}, ${misc:Depends}, libwww-perl, libdigest-sha1-perl,
- liburi-perl, libcrypt-dh-perl (>= 0.05),
- liburi-fetch-perl (>= 0.02)
+ liburi-perl, libcrypt-dh-perl (>= 0.05), libxml-simple-perl
Description: library for consumers of OpenID identities
After Net::OpenID::Consumer crawls a user's declared identity URL
and finds openid.server link tags in the HTML head, you get this
diff --git a/lib/Net/OpenID/Association.pm b/lib/Net/OpenID/Association.pm
index fa23c48..61f32b0 100644
--- a/lib/Net/OpenID/Association.pm
+++ b/lib/Net/OpenID/Association.pm
@@ -37,6 +37,12 @@ sub secret {
$self->{'secret'};
}
+sub type {
+ my $self = shift;
+ die if @_;
+ $self->{'type'};
+}
+
sub server {
my Net::OpenID::Association $self = shift;
Carp::croak("Too many parameters") if @_;
@@ -63,7 +69,10 @@ sub usable {
# goes into dumb consumer mode. will do a POST and allocate
# a new assoc_handle if none is found, or has expired
sub server_assoc {
- my ($csr, $server) = @_;
+ my ($csr, $server, $force_reassociate, %opts) = @_;
+
+ my $protocol_version = delete $opts{protocol_version} || 1;
+ Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
# closure to return undef (dumb consumer mode) and log why
my $dumb = sub {
@@ -74,13 +83,15 @@ sub server_assoc {
my $cache = $csr->cache;
return $dumb->("no_cache") unless $cache;
- # try first from cached association handle
- if (my $handle = $cache->get("shandle:$server")) {
- my $assoc = handle_assoc($csr, $server, $handle);
+ unless ($force_reassociate) {
+ # try first from cached association handle
+ if (my $handle = $cache->get("shandle:$server")) {
+ my $assoc = handle_assoc($csr, $server, $handle);
- if ($assoc && $assoc->usable) {
- $csr->_debug("Found association from cache (handle=$handle)");
- return $assoc;
+ if ($assoc && $assoc->usable) {
+ $csr->_debug("Found association from cache (handle=$handle)");
+ return $assoc;
+ }
}
}
@@ -94,6 +105,10 @@ sub server_assoc {
"openid.dh_consumer_public" => OpenID::util::bi2arg($dh->pub_key),
);
+ if ($protocol_version == 2) {
+ $post{"openid.ns"} = OpenID::util::version_2_namespace();
+ }
+
my $req = HTTP::Request->new(POST => $server);
$req->header("Content-Type" => "application/x-www-form-urlencoded");
$req->content(join("&", map { "$_=" . OpenID::util::eurl($post{$_}) } keys %post));
diff --git a/lib/Net/OpenID/ClaimedIdentity.pm b/lib/Net/OpenID/ClaimedIdentity.pm
index 448450b..6dc8bf7 100644
--- a/lib/Net/OpenID/ClaimedIdentity.pm
+++ b/lib/Net/OpenID/ClaimedIdentity.pm
@@ -4,23 +4,33 @@ use Carp ();
############################################################################
package Net::OpenID::ClaimedIdentity;
use fields (
- 'identity', # the canonical URL that was found, following redirects
- 'server', # author-identity identity server endpoint
- 'consumer', # ref up to the Net::OpenID::Consumer which generated us
- 'delegate', # the delegated URL actually asserted by the server
- );
+ 'identity', # the canonical URL that was found, following redirects
+ 'server', # author-identity identity server endpoint
+ 'consumer', # ref up to the Net::OpenID::Consumer which generated us
+ 'delegate', # the delegated URL actually asserted by the server
+ 'protocol_version', # The version of the OpenID Authentication Protocol that is used
+ 'semantic_info', # Stuff that we've discovered in the identifier page's metadata
+ 'extension_args', # Extension arguments that the caller wants to add to the request
+);
sub new {
my Net::OpenID::ClaimedIdentity $self = shift;
$self = fields::new( $self ) unless ref $self;
my %opts = @_;
- for my $f (qw( identity server consumer delegate )) {
+ for my $f (qw( identity server consumer delegate protocol_version semantic_info )) {
$self->{$f} = delete $opts{$f};
}
+ $self->{protocol_version} ||= 1;
+ unless ($self->{protocol_version} == 1 || $self->{protocol_version} == 2) {
+ Carp::croak("Unsupported protocol version");
+ }
+
# lowercase the scheme and hostname
$self->{'identity'} =~ s!^(https?://.+?)(/(?:.*))?$!lc($1) . $2!ie;
+ $self->{extension_args} = {};
+
Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
return $self;
}
@@ -31,12 +41,46 @@ sub claimed_url {
return $self->{'identity'};
}
+sub delegated_url {
+ my Net::OpenID::ClaimedIdentity $self = shift;
+ Carp::croak("Too many parameters") if @_;
+ return $self->{'delegate'};
+}
+
sub identity_server {
my Net::OpenID::ClaimedIdentity $self = shift;
Carp::croak("Too many parameters") if @_;
return $self->{server};
}
+sub protocol_version {
+ my Net::OpenID::ClaimedIdentity $self = shift;
+ Carp::croak("Too many parameters") if @_;
+ return $self->{protocol_version};
+}
+
+sub semantic_info {
+ my Net::OpenID::ClaimedIdentity $self = shift;
+ Carp::croak("Too many parameters") if @_;
+ return $self->{semantic_info} if $self->{semantic_info};
+ my $final_url = '';
+ my $info = $self->{consumer}->_find_semantic_info($self->claimed_url, \$final_url);
+ # Don't return anything if the URL has changed. Something bad may be happening.
+ $info = {} if $final_url ne $self->claimed_url;
+ return $self->{semantic_info} = $info;
+}
+
+sub set_extension_args {
+ my Net::OpenID::ClaimedIdentity $self = shift;
+ my $ext_uri = shift;
+ my $args = shift;
+ Carp::croak("Too many parameters") if @_;
+ Carp::croak("No extension URI given") unless $ext_uri;
+ Carp::croak("Expecting hashref of args") if defined($args) && ref $args ne 'HASH';
+
+ $self->{extension_args}{$ext_uri} = $args;
+}
+
sub check_url {
my Net::OpenID::ClaimedIdentity $self = shift;
my (%opts) = @_;
@@ -44,6 +88,9 @@ sub check_url {
my $return_to = delete $opts{'return_to'};
my $trust_root = delete $opts{'trust_root'};
my $delayed_ret = delete $opts{'delayed_return'};
+ my $force_reassociate = delete $opts{'force_reassociate'};
+ my $use_assoc_handle = delete $opts{'use_assoc_handle'};
+ my $actually_return_association = delete $opts{'actually_return_association'};
Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
Carp::croak("Invalid/missing return_to") unless $return_to =~ m!^https?://!;
@@ -54,12 +101,25 @@ sub check_url {
Carp::croak("No identity server");
# get an assoc (or undef for dumb mode)
- my $assoc = Net::OpenID::Association::server_assoc($csr, $ident_server);
+ my $assoc;
+ if ($use_assoc_handle) {
+ $assoc = Net::OpenID::Association::handle_assoc($csr, $ident_server, $use_assoc_handle);
+ } else {
+ $assoc = Net::OpenID::Association::server_assoc($csr, $ident_server, $force_reassociate, (
+ protocol_version => $self->protocol_version,
+ ));
+ }
+
+ # for the openid-test project: (doing interop testing)
+ if ($actually_return_association) {
+ return $assoc;
+ }
my $identity_arg = $self->{'delegate'} || $self->{'identity'};
# make a note back to ourselves that we're using a delegate
- if ($self->{'delegate'}) {
+ # but only in the 1.1 case because 2.0 has a core field for this
+ if ($self->{'delegate'} && $self->protocol_version == 1) {
OpenID::util::push_url_arg(\$return_to,
"oic.identity", $self->{identity});
}
@@ -72,17 +132,63 @@ sub check_url {
"oic.time", "${sig_time}-$sig");
my $curl = $ident_server;
- OpenID::util::push_url_arg(\$curl,
- "openid.mode", ($delayed_ret ? "checkid_setup" : "checkid_immediate"),
- "openid.identity", $identity_arg,
- "openid.return_to", $return_to,
-
- ($trust_root ?
- ("openid.trust_root", $trust_root) : ()),
+ if ($self->protocol_version == 1) {
+ OpenID::util::push_url_arg(\$curl,
+ "openid.mode" => ($delayed_ret ? "checkid_setup" : "checkid_immediate"),
+ "openid.identity" => $identity_arg,
+ "openid.return_to" => $return_to,
+
+ ($trust_root ? (
+ "openid.trust_root" => $trust_root
+ ) : ()),
+
+ ($assoc ? (
+ "openid.assoc_handle" => $assoc->handle
+ ) : ()),
+ );
+ }
+ elsif ($self->protocol_version == 2) {
+ # NOTE: OpenID Auth 2.0 uses different terminology for a bunch
+ # of things than 1.1 did. This library still uses the 1.1 terminology
+ # in its API.
+ OpenID::util::push_openid2_url_arg(\$curl,
+ "mode" => ($delayed_ret ? "checkid_setup" : "checkid_immediate"),
+ "claimed_id" => $self->claimed_url,
+ "identity" => $identity_arg,
+ "return_to" => $return_to,
+
+ ($trust_root ? (
+ "realm" => $trust_root
+ ) : ()),
+
+ ($assoc ? (
+ "assoc_handle" => $assoc->handle
+ ) : ()),
+ );
+ }
- ($assoc ?
- ("openid.assoc_handle", $assoc->handle) : ()),
- );
+ # Finally we add in the extension arguments, if any
+ my %ext_url_args = ();
+ my $ext_idx = 1;
+ foreach my $ext_uri (keys %{$self->{extension_args}}) {
+ my $ext_alias;
+
+ if ($self->protocol_version >= 2) {
+ $ext_alias = 'e'.($ext_idx++);
+ $ext_url_args{'openid.ns.'.$ext_alias} = $ext_uri;
+ }
+ else {
+ # For OpenID 1.1 only the "SREG" extension is allowed,
+ # and it must use the "openid.sreg." prefix.
+ next unless $ext_uri eq "http://openid.net/extensions/sreg/1.1";
+ $ext_alias = "sreg";
+ }
+
+ foreach my $k (keys %{$self->{extension_args}{$ext_uri}}) {
+ $ext_url_args{'openid.'.$ext_alias.'.'.$k} = $self->{extension_args}{$ext_uri}{$k};
+ }
+ }
+ OpenID::util::push_url_arg(\$curl, %ext_url_args) if %ext_url_args;
$self->{consumer}->_debug("check_url for (del=$self->{delegate}, id=$self->{identity}) = $curl");
return $curl;
@@ -143,6 +249,38 @@ check_url, though.
Returns the identity server that will assert whether or not this
claimed identity is valid, and sign a message saying so.
+=item $url = $cident->B<delegated_url>
+
+If the claimed URL is using delegation, this returns the delegated identity that will
+actually be sent to the identity server.
+
+=item $version = $cident->B<protocol_version>
+
+Determines whether this identifier is to be verified by OpenID 1.1
+or by OpenID 2.0. Returns C<1> or C<2> respectively. This will
+affect the way the C<check_url> is constructed.
+
+=item $cident->B<set_extension_args>($ns_uri, $args)
+
+If called before you access C<check_url>, the arguments given in the hashref
+$args will be added to the request in the given extension namespace.
+For example, to use the Simple Registration (SREG) extension:
+
+ $cident->set_extension_args(
+ 'http://openid.net/extensions/sreg/1.1',
+ {
+ required => 'email',
+ optional => 'fullname,nickname',
+ policy_url => 'http://example.com/privacypolicy.html',
+ },
+ );
+
+Note that when making an OpenID 1.1 request, only the Simple Registration
+extension is supported. There was no general extension mechanism defined
+in OpenID 1.1, so SREG (with the namespace URI as in the example above)
+is supported as a special case. All other extension namespaces will
+be silently ignored when making a 1.1 request.
+
=item $url = $cident->B<check_url>( %opts )
Makes the URL that you have to somehow send the user to in order to
@@ -203,5 +341,5 @@ L<Net::OpenID::VerifiedIdentity>
L<Net::OpenID::Server>
-Website: L<http://www.danga.com/openid/>
+Website: L<http://www.openid.net/>
diff --git a/lib/Net/OpenID/Consumer.pm b/lib/Net/OpenID/Consumer.pm
index ca6ae45..204ec38 100644
--- a/lib/Net/OpenID/Consumer.pm
+++ b/lib/Net/OpenID/Consumer.pm
@@ -3,28 +3,33 @@
use strict;
use Carp ();
use LWP::UserAgent;
-use URI::Fetch 0.02;
+use Storable;
############################################################################
package Net::OpenID::Consumer;
use vars qw($VERSION);
-$VERSION = "0.14";
+$VERSION = "1.03";
use fields (
- 'cache', # the Cache object sent to URI::Fetch
- 'ua', # LWP::UserAgent instance to use
- 'args', # how to get at your args
- 'consumer_secret', # scalar/subref
- 'required_root', # the default required_root value, or undef
- 'last_errcode', # last error code we got
- 'last_errtext', # last error code we got
- 'debug', # debug flag or codeblock
- );
+ 'cache', # a Cache object to store HTTP responses and associations
+ 'ua', # LWP::UserAgent instance to use
+ 'args', # how to get at your args
+ 'message', # args interpreted as an IndirectMessage, if possible
+ 'consumer_secret', # scalar/subref
+ 'required_root', # the default required_root value, or undef
+ 'last_errcode', # last error code we got
+ 'last_errtext', # last error code we got
+ 'debug', # debug flag or codeblock
+ 'minimum_version', # The minimum protocol version to support
+);
use Net::OpenID::ClaimedIdentity;
use Net::OpenID::VerifiedIdentity;
use Net::OpenID::Association;
+use Net::OpenID::Yadis;
+use Net::OpenID::IndirectMessage;
+use Net::OpenID::URIFetch;
use MIME::Base64 ();
use Digest::SHA1 ();
@@ -37,11 +42,14 @@ sub new {
$self = fields::new( $self ) unless ref $self;
my %opts = @_;
+ $opts{minimum_version} ||= 1;
+
$self->{ua} = delete $opts{ua};
$self->args ( delete $opts{args} );
$self->cache ( delete $opts{cache} );
$self->consumer_secret ( delete $opts{consumer_secret} );
$self->required_root ( delete $opts{required_root} );
+ $self->minimum_version ( delete $opts{minimum_version} );
$self->{debug} = delete $opts{debug};
@@ -49,9 +57,20 @@ sub new {
return $self;
}
+# NOTE: This method is here only to support the openid-test library.
+# Don't call it from anywhere else, or you'll break when it gets
+# removed. Instead, set the minimum_version property.
+# FIXME: Can we just make openid-test set minimum_version and get
+# rid of this?
+sub disable_version_1 {
+ my $self = shift;
+ $self->{minimum_version} = 2.0;
+}
+
sub cache { &_getset; }
sub consumer_secret { &_getset; }
sub required_root { &_getset; }
+sub minimum_version { &_getset; }
sub _getset {
my Net::OpenID::Consumer $self = shift;
@@ -90,32 +109,41 @@ sub args {
my Net::OpenID::Consumer $self = shift;
if (my $what = shift) {
- Carp::croak("Too many parameters") if @_;
- my $getter;
- if (! ref $what){
- Carp::croak("No args defined") unless $self->{args};
- return $self->{args}->($what);
- } elsif (ref $what eq "HASH") {
- $getter = sub { $what->{$_[0]}; };
- } elsif (UNIVERSAL::isa($what, "CGI")) {
- $getter = sub { scalar $what->param($_[0]); };
- } elsif (ref $what eq "Apache") {
- my %get = $what->args;
- $getter = sub { $get{$_[0]}; };
- } elsif (ref $what eq "Apache::Request") {
- $getter = sub { scalar $what->param($_[0]); };
- } elsif (ref $what eq "CODE") {
- $getter = $what;
- } else {
- Carp::croak("Unknown parameter type ($what)");
+ unless (ref $what) {
+ return $self->{args} ? $self->{args}->($what) : Carp::croak("No args defined");
}
- if ($getter) {
- $self->{args} = $getter;
+ else {
+ Carp::croak("Too many parameters") if @_;
+ my $message = Net::OpenID::IndirectMessage->new($what, (
+ minimum_version => $self->minimum_version,
+ ));
+ $self->{message} = $message;
+ $self->{args} = $message ? $message->getter : sub { undef };
}
}
$self->{args};
}
+sub message {
+ my Net::OpenID::Consumer $self = shift;
+ if (my $key = shift) {
+ return $self->{message} ? $self->{message}->get($key) : undef;
+ }
+ else {
+ return $self->{message};
+ }
+}
+
+sub _message_mode {
+ my $message = $_[0]->message;
+ return $message ? $message->mode : undef;
+}
+
+sub _message_version {
+ my $message = $_[0]->message;
+ return $message ? $message->protocol_version : undef;
+}
+
sub ua {
my Net::OpenID::Consumer $self = shift;
$self->{ua} = shift if @_;
@@ -140,6 +168,10 @@ sub _fail {
'bogus_url' => "Invalid URL.",
'no_head_tag' => "URL provided doesn't seem to have a head tag.",
'url_fetch_err' => "Error fetching the provided URL.",
+ 'bad_mode' => "The openid.mode argument is not correct",
+ 'protocol_version_incorrect' => "The provided URL uses the wrong protocol version",
+ 'naive_verify_failed_return' => "Provider says signature is invalid",
+ 'naive_verify_failed_network' => "Could not contact provider to verify signature",
}->{$code};
$self->{last_errcode} = $code;
@@ -172,28 +204,16 @@ sub errtext {
$self->{last_errtext};
}
-
sub _get_url_contents {
my Net::OpenID::Consumer $self = shift;
- my ($url, $final_url_ref, $hook) = @_;
+ my ($url, $final_url_ref, $hook) = @_;
$final_url_ref ||= do { my $dummy; \$dummy; };
- my $ures = URI::Fetch->fetch($url,
- UserAgent => $self->ua,
- Cache => $self->cache,
- ContentAlterHook => $hook,
- )
- or return $self->_fail("url_fetch_error", "Error fetching URL: " . URI::Fetch->errstr);
+ my $res = Net::OpenID::URIFetch->fetch($url, $self, $hook);
- # who actually uses HTTP gone response status? uh, nobody.
- if ($ures->status == URI::Fetch::URI_GONE()) {
- return $self->_fail("url_gone", "URL is no longer available");
- }
-
- my $res = $ures->http_response;
- $$final_url_ref = $res->request->uri->as_string;
+ $$final_url_ref = $res->final_uri;
- return $ures->content;
+ return $res ? $res->content : undef;
}
sub _find_semantic_info {
@@ -209,8 +229,7 @@ sub _find_semantic_info {
$$htmlref =~ s/<body\b.*//is;
};
- my $doc = $self->_get_url_contents($url, $final_url_ref, $trim_hook) or
- return;
+ my $doc = $self->_get_url_contents($url, $final_url_ref, $trim_hook) || '';
# find <head> content of document (notably: the first head, if an attacker
# has added others somehow)
@@ -241,6 +260,15 @@ sub _find_semantic_info {
next;
}
+ # OpenID2 providers / local identifiers
+ # <link rel="openid2.provider" href="http://www.livejournal.com/misc/openid.bml" />
+ if ($type eq "link" &&
+ $val =~ /\brel=.openid2\.(provider|local_id)./i && ($temp = $1) &&
+ $val =~ m!\bhref=[\"\']([^\"\']+)[\"\']!i) {
+ $ret->{"openid2.$temp"} = $1;
+ next;
+ }
+
# FOAF documents
#<link rel="meta" type="application/rdf+xml" title="FOAF" href="http://brad.livejournal.com/data/foaf" />
if ($type eq "link" &&
@@ -301,7 +329,7 @@ sub _find_semantic_info {
$ret->{$k} =~ s/&(\w+);/$emap->{$1} || ""/eg;
}
- $self->_debug("semantic info ($url) = " . join(", ", %$ret));
+ $self->_debug("semantic info ($url) = " . join(", ", map { $_.' => '.$ret->{$_} } keys %$ret)) if $self->{debug};
return $ret;
}
@@ -318,6 +346,211 @@ sub _find_openid_server {
$sem_info->{"openid.server"};
}
+sub is_server_response {
+ my Net::OpenID::Consumer $self = shift;
+ return $self->_message_mode ? 1 : 0;
+}
+
+sub handle_server_response {
+ my Net::OpenID::Consumer $self = shift;
+ my %callbacks_in = @_;
+ my %callbacks = ();
+
+ foreach my $cb (qw(not_openid setup_required cancelled verified error)) {
+ $callbacks{$cb} = delete($callbacks_in{$cb}) || sub { Carp::croak("No ".$cb." callback") };
+ }
+ Carp::croak("Unknown callbacks ".join(',', keys %callbacks)) if %callbacks_in;
+
+ unless ($self->is_server_response) {
+ return $callbacks{not_openid}->();
+ }
+
+ if (my $setup_url = $self->user_setup_url) {
+ return $callbacks{setup_required}->($setup_url);
+ }
+ elsif ($self->user_cancel) {
+ return $callbacks{cancelled}->();
+ }
+ elsif (my $vident = $self->verified_identity) {
+ return $callbacks{verified}->($vident);
+ }
+ else {
+ return $callbacks{error}->($self->errcode, $self->errtext);
+ }
+
+}
+
+sub _discover_acceptable_endpoints {
+ my Net::OpenID::Consumer $self = shift;
+ my $url = shift;
+ my %opts = @_;
+
+ # if return_early is set, we'll return as soon as we have enough
+ # information to determine the "primary" endpoint, and return
+ # that as the first (and possibly only) item in our response.
+ my $primary_only = delete $opts{primary_only} ? 1 : 0;
+
+ my $force_version = delete $opts{force_version};
+
+ Carp::croak("Unknown option(s) ".join(', ', keys(%opts))) if %opts;
+
+ # trim whitespace
+ $url =~ s/^\s+//;
+ $url =~ s/\s+$//;
+ return $self->_fail("empty_url", "Empty URL") unless $url;
+
+ # do basic canonicalization
+ $url = "http://$url" if $url && $url !~ m!^\w+://!;
+ return $self->_fail("bogus_url", "Invalid URL") unless $url =~ m!^https?://!i;
+ # add a slash, if none exists
+ $url .= "/" unless $url =~ m!^https?://.+/!i;
+
+ my @discovered_endpoints = ();
+ my $result = sub {
+ # We always prefer 2.0 endpoints to 1.1 ones, regardless of
+ # the priority chosen by the identifier.
+ return [
+ (grep { $_->{version} == 2 } @discovered_endpoints),
+ (grep { $_->{version} == 1 } @discovered_endpoints),
+ ];
+ };
+
+ # TODO: Support XRI too?
+
+ # First we Yadis service discovery
+ my $yadis = Net::OpenID::Yadis->new(consumer => $self);
+ if ($yadis->discover($url)) {
+ # FIXME: Currently we don't ever do _find_semantic_info in the Yadis
+ # code path, so an extra redundant HTTP request is done later
+ # when the semantic info is accessed.
+
+ my $final_url = $yadis->identity_url;
+ my @services = $yadis->services(
+ OpenID::util::version_2_xrds_service_url(),
+ OpenID::util::version_2_xrds_directed_service_url(),
+ OpenID::util::version_1_xrds_service_url(),
+ );
+ my $version2 = OpenID::util::version_2_xrds_service_url();
+ my $version1 = OpenID::util::version_1_xrds_service_url();
+ my $version2_directed = OpenID::util::version_2_xrds_directed_service_url();
+
+ foreach my $service (@services) {
+ my $service_uris = $service->URI;
+
+ # Service->URI seems to return all sorts of bizarre things, so let's
+ # normalize it to always be an arrayref.
+ if (ref($service_uris) eq 'ARRAY') {
+ my @sorted_id_servers = sort {
+ my $pa = $a->{priority};
+ my $pb = $b->{priority};
+ return 0 unless defined($pa) || defined($pb);
+ return -1 unless defined ($pb);
+ return 1 unless defined ($pa);
+ return $a->{priority} <=> $b->{priority}
+ } @$service_uris;
+ $service_uris = \@sorted_id_servers;
+ }
+ if (ref($service_uris) eq 'HASH') {
+ $service_uris = [ $service_uris->{content} ];
+ }
+ unless (ref($service_uris)) {
+ $service_uris = [ $service_uris ];
+ }
+
+ my $delegate = undef;
+ my @versions = ();
+
+ if (grep(/^${version2}$/, $service->Type)) {
+ # We have an OpenID 2.0 end-user identifier
+ $delegate = $service->extra_field("LocalID");
+ push @versions, 2;
+ }
+ if (grep(/^${version1}$/, $service->Type)) {
+ # We have an OpenID 1.1 end-user identifier
+ $delegate = $service->extra_field("Delegate", "http://openid.net/xmlns/1.0");
+ push @versions, 1;
+ }
+
+ if (@versions) {
+ foreach my $version (@versions) {
+ next if defined($force_version) && $force_version != $version;
+ foreach my $uri (@$service_uris) {
+ push @discovered_endpoints, {
+ uri => $uri,
+ version => $version,
+ final_url => $final_url,
+ delegate => $delegate,
+ sem_info => undef,
+ mechanism => "Yadis",
+ };
+ }
+ }
+ }
+
+ if (grep(/^${version2_directed}$/, $service->Type)) {
+ # We have an OpenID 2.0 OP identifier (i.e. we're doing directed identity)
+ my $version = 2;
+ # In this case, the user's claimed identifier is a magic value
+ # and the actual identifier will be determined by the provider.
+ my $final_url = OpenID::util::version_2_identifier_select_url();
+ my $delegate = OpenID::util::version_2_identifier_select_url();
+
+ foreach my $uri (@$service_uris) {
+ push @discovered_endpoints, {
+ uri => $uri,
+ version => $version,
+ final_url => $final_url,
+ delegate => $delegate,
+ sem_info => undef,
+ mechanism => "Yadis",
+ };
+ }
+ }
+
+ if ($primary_only && scalar(@discovered_endpoints)) {
+ # We've got at least one endpoint now, so return early
+ return $result->();
+ }
+ }
+ }
+
+ # Now HTML-based discovery, both 2.0- and 1.1-style.
+ {
+ my $final_url = undef;
+ my $sem_info = $self->_find_semantic_info($url, \$final_url);
+
+ if ($sem_info) {
+ if ($sem_info->{"openid2.provider"}) {
+ unless (defined($force_version) && $force_version != 2) {
+ push @discovered_endpoints, {
+ uri => $sem_info->{"openid2.provider"},
+ version => 2,
+ final_url => $final_url,
+ delegate => $sem_info->{"openid2.local_id"},
+ sem_info => $sem_info,
+ mechanism => "HTML",
+ };
+ }
+ }
+ if ($sem_info->{"openid.server"}) {
+ unless (defined($force_version) && $force_version != 1) {
+ push @discovered_endpoints, {
+ uri => $sem_info->{"openid.server"},
+ version => 1,
+ final_url => $final_url,
+ delegate => $sem_info->{"openid.delegate"},
+ sem_info => $sem_info,
+ mechanism => "HTML",
+ };
+ }
+ }
+ }
+ }
+
+ return $result->();
+
+}
+
# returns Net::OpenID::ClaimedIdentity
sub claimed_identity {
my Net::OpenID::Consumer $self = shift;
@@ -333,27 +566,42 @@ sub claimed_identity {
$url = "http://$url" if $url && $url !~ m!^\w+://!;
return $self->_fail("bogus_url", "Invalid URL") unless $url =~ m!^https?://!i;
# add a slash, if none exists
- $url .= "/" unless $url =~ m!^http://.+/!i;
+ $url .= "/" unless $url =~ m!^https?://.+/!i;
- my $final_url;
+ my $endpoints = $self->_discover_acceptable_endpoints($url, primary_only => 1);
- my $sem_info = $self->_find_semantic_info($url, \$final_url) or
- return;
+ if (ref($endpoints) && @$endpoints) {
+ foreach my $endpoint (@$endpoints) {
+
+ next unless $endpoint->{version} >= $self->minimum_version;
+
+ $self->_debug("Discovered version $endpoint->{version} endpoint at $endpoint->{uri} via $endpoint->{mechanism}");
+ $self->_debug("Delegate is $endpoint->{delegate}") if $endpoint->{delegate};
- my $id_server = $sem_info->{"openid.server"} or
+ return Net::OpenID::ClaimedIdentity->new(
+ identity => $endpoint->{final_url},
+ server => $endpoint->{uri},
+ consumer => $self,
+ delegate => $endpoint->{delegate},
+ protocol_version => $endpoint->{version},
+ semantic_info => $endpoint->{sem_info},
+ );
+
+ }
+
+ # If we've fallen out here, then none of the available services are of the required version.
+ return $self->_fail("protocol_version_incorrect");
+
+ }
+ else {
return $self->_fail("no_identity_server");
+ }
- return Net::OpenID::ClaimedIdentity->new(
- identity => $final_url,
- server => $id_server,
- consumer => $self,
- delegate => $sem_info->{'openid.delegate'},
- );
}
sub user_cancel {
my Net::OpenID::Consumer $self = shift;
- return $self->args("openid.mode") eq "cancel";
+ return $self->_message_mode eq "cancel";
}
sub user_setup_url {
@@ -361,9 +609,15 @@ sub user_setup_url {
my %opts = @_;
my $post_grant = delete $opts{'post_grant'};
Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
- return $self->_fail("bad_mode") unless $self->args("openid.mode") eq "id_res";
- my $setup_url = $self->args("openid.user_setup_url");
+ if ($self->_message_version == 1) {
+ return $self->_fail("bad_mode") unless $self->_message_mode eq "id_res";
+ }
+ else {
+ return undef unless $self->_message_mode eq 'setup_needed';
+ }
+
+ my $setup_url = $self->message("user_setup_url");
OpenID::util::push_url_arg(\$setup_url, "openid.post_grant", $post_grant)
if $setup_url && $post_grant;
@@ -378,21 +632,56 @@ sub verified_identity {
my $rr = delete $opts{'required_root'} || $self->{required_root};
Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
- return $self->_fail("bad_mode") unless $self->args("openid.mode") eq "id_res";
+ return $self->_fail("bad_mode") unless $self->_message_mode eq "id_res";
# the asserted identity (the delegated one, if there is one, since the protocol
# knows nothing of the original URL)
- my $a_ident = $self->args("openid.identity") or return $self->_fail("no_identity");
+ my $a_ident = $self->message("identity") or return $self->_fail("no_identity");
+
+ my $sig64 = $self->message("sig") or return $self->_fail("no_sig");
- my $sig64 = $self->args("openid.sig") or return $self->_fail("no_sig");
-
# fix sig if the OpenID auth server failed to properly escape pluses (+) in the sig
$sig64 =~ s/ /+/g;
- my $returnto = $self->args("openid.return_to") or return $self->_fail("no_return_to");
- my $signed = $self->args("openid.signed");
+ my $returnto = $self->message("return_to") or return $self->_fail("no_return_to");
+ my $signed = $self->message("signed");
+
+ my $possible_endpoints;
+ my $server;
+ my $claimed_identity;
+
+ my $real_ident;
+ if ($self->_message_version == 1) {
+ $real_ident = $self->args("oic.identity") || $a_ident;
+
+ # In version 1, we have to assume that the primary server
+ # found during discovery is the one sending us this message.
+ $possible_endpoints = $self->_discover_acceptable_endpoints($real_ident, force_version => 1);
+
+ if ($possible_endpoints && @$possible_endpoints) {
+ $possible_endpoints = [ $possible_endpoints->[0] ];
+ $server = $possible_endpoints->[0]{uri};
+ }
+ else {
+ # We just fall out of here and bail out below for having no endpoints.
+ }
+ }
+ else {
+ $real_ident = $self->message("claimed_id") || $a_ident;
+
+ # In version 2, the OP tells us its URL.
+ $server = $self->message("op_endpoint");
+ $possible_endpoints = $self->_discover_acceptable_endpoints($real_ident, force_version => 2);
- my $real_ident = $self->args("oic.identity") || $a_ident;
+ # FIXME: It kinda sucks that the above will always do both Yadis and HTML discovery, even though
+ # in most cases only one will be in use.
+ }
+
+ $self->_debug("Server is $server");
+
+ unless ($possible_endpoints && @$possible_endpoints) {
+ return $self->_fail("no_identity_server");
+ }
# check that returnto is for the right host
return $self->_fail("bogus_return_to") if $rr && $returnto !~ /^\Q$rr\E/;
@@ -412,25 +701,100 @@ sub verified_identity {
return $self->_fail("time_bad_sig") unless $sig eq $good_sig;
}
- my $final_url;
- my $sem_info = $self->_find_semantic_info($real_ident, \$final_url);
- return $self->_fail("unexpected_url_redirect") unless $final_url eq $real_ident;
+ my $last_error = undef;
- my $server = $sem_info->{"openid.server"} or
- return $self->_fail("no_identity_server");
+ foreach my $endpoint (@$possible_endpoints) {
+ my $final_url = $endpoint->{final_url};
+ my $endpoint_uri = $endpoint->{uri};
+ my $delegate = $endpoint->{delegate};
+
+ my $error = sub {
+ $self->_debug("$endpoint_uri not acceptable: ".$_[0]);
+ $last_error = $_[0];
+ };
+
+ # The endpoint_uri must match our $server
+ if ($endpoint_uri ne $server) {
+ $error->("server_not_allowed");
+ next;
+ }
- # if openid.delegate was used, check that it was done correctly
- if ($a_ident ne $real_ident) {
- return $self->_fail("bogus_delegation") unless $sem_info->{"openid.delegate"} eq $a_ident;
+ # OpenID 2.0 wants us to exclude the fragment part of the URL when doing equality checks
+ my $a_ident_nofragment = $a_ident;
+ my $real_ident_nofragment = $real_ident;
+ my $final_url_nofragment = $final_url;
+ if ($self->_message_version >= 2) {
+ $a_ident_nofragment =~ s/\#.*$//x;
+ $real_ident_nofragment =~ s/\#.*$//x;
+ $final_url_nofragment =~ s/\#.*$//x;
+ }
+ unless ($final_url_nofragment eq $real_ident_nofragment) {
+ $error->("unexpected_url_redirect");
+ next;
+ }
+
+ # Protocol version must match
+ unless ($endpoint->{version} == $self->_message_version) {
+ $error->("protocol_version_incorrect");
+ next;
+ }
+
+ # if openid.delegate was used, check that it was done correctly
+ if ($a_ident_nofragment ne $real_ident_nofragment) {
+ unless ($delegate eq $a_ident_nofragment) {
+ $error->("bogus_delegation");
+ next;
+ }
+ }
+
+ # If we've got this far then we've found the right endpoint.
+
+ $claimed_identity = Net::OpenID::ClaimedIdentity->new(
+ identity => $endpoint->{final_url},
+ server => $endpoint->{uri},
+ consumer => $self,
+ delegate => $endpoint->{delegate},
+ protocol_version => $endpoint->{version},
+ semantic_info => $endpoint->{sem_info},
+ );
+ last;
+
+ }
+
+ unless ($claimed_identity) {
+ # We failed to find a good endpoint in the above loop, so
+ # lets bail out.
+ return $self->_fail($last_error);
}
- my $assoc_handle = $self->args("openid.assoc_handle");
+ my $assoc_handle = $self->message("assoc_handle");
$self->_debug("verified_identity: assoc_handle: $assoc_handle");
my $assoc = Net::OpenID::Association::handle_assoc($self, $server, $assoc_handle);
my %signed_fields; # key (without openid.) -> value
+ # Auth 2.0 requires certain keys to be signed.
+ if ($self->_message_version >= 2) {
+ my %signed_fields = map {$_ => 1} split /,/, $signed;
+ my %unsigned_fields;
+ # these fields must be signed unconditionally
+ foreach my $f (qw/op_endpoint return_to response_nonce assoc_handle/) {
+ $unsigned_fields{$f}++ if !$signed_fields{$f};
+ }
+ # these fields must be signed if present
+ foreach my $f (qw/claimed_id identity/) {
+ next unless $self->args("openid.$f");
+ $unsigned_fields{$f}++ if !$signed_fields{$f};
+ }
+ if (%unsigned_fields) {
+ return $self->_fail(
+ "unsigned_field",
+ "Field(s) must be signed: " . join(", ", keys %unsigned_fields)
+ );
+ }
+ }
+
if ($assoc) {
$self->_debug("verified_identity: verifying with found association");
@@ -462,7 +826,7 @@ sub verified_identity {
# and copy in all signed parameters that we don't already have into %post
foreach my $param (split(/,/, $signed)) {
next unless $param =~ /^[\w\.]+$/;
- my $val = $self->args("openid.$param");
+ my $val = $self->args('openid.'.$param);
$signed_fields{$param} = $val;
next if $post{"openid.$param"};
$post{"openid.$param"} = $val;
@@ -470,7 +834,7 @@ sub verified_identity {
# if the server told us our handle as bogus, let's ask in our
# check_authentication mode whether that's true
- if (my $ih = $self->args("openid.invalidate_handle")) {
+ if (my $ih = $self->message("invalidate_handle")) {
$post{"openid.invalidate_handle"} = $ih;
}
@@ -501,14 +865,10 @@ sub verified_identity {
# verified!
return Net::OpenID::VerifiedIdentity->new(
- identity => $real_ident,
- foaf => $sem_info->{"foaf"},
- foafmaker => $sem_info->{"foaf.maker"},
- rss => $sem_info->{"rss"},
- atom => $sem_info->{"atom"},
- consumer => $self,
- signed_fields => \%signed_fields,
- );
+ claimed_identity => $claimed_identity,
+ consumer => $self,
+ signed_fields => \%signed_fields,
+ );
}
sub supports_consumer_secret { 1; }
@@ -533,6 +893,30 @@ sub _get_consumer_secret {
package OpenID::util;
+use constant VERSION_1_NAMESPACE => "http://openid.net/signon/1.1";
+use constant VERSION_2_NAMESPACE => "http://specs.openid.net/auth/2.0";
+
+# I guess this is a bit daft since constants are subs anyway,
+# but whatever.
+sub version_1_namespace {
+ return VERSION_1_NAMESPACE;
+}
+sub version_2_namespace {
+ return VERSION_2_NAMESPACE;
+}
+sub version_1_xrds_service_url {
+ return VERSION_1_NAMESPACE;
+}
+sub version_2_xrds_service_url {
+ return "http://specs.openid.net/auth/2.0/signon";
+}
+sub version_2_xrds_directed_service_url {
+ return "http://specs.openid.net/auth/2.0/server";
+}
+sub version_2_identifier_select_url {
+ return "http://specs.openid.net/auth/2.0/identifier_select";
+}
+
# From Digest::HMAC
sub hmac_sha1_hex {
unpack("H*", &hmac_sha1);
@@ -612,6 +996,17 @@ sub push_url_arg {
}
}
+sub push_openid2_url_arg {
+ my $uref = shift;
+ my %args = @_;
+ push_url_arg($uref,
+ 'openid.ns' => VERSION_2_NAMESPACE,
+ map {
+ 'openid.'.$_ => $args{$_}
+ } keys %args,
+ );
+}
+
sub time_to_w3c {
my $time = shift || time();
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
@@ -711,8 +1106,31 @@ Net::OpenID::Consumer - library for consumers of OpenID identities
);
# so you send the user off there, and then they come back to
- # openid-check.app, then you see what the identity server said;
+ # openid-check.app, then you see what the identity server said.
+
+ # Either use callback-based API (recommended)...
+ $csr->handle_server_response(
+ not_openid => sub {
+ die "Not an OpenID message";
+ },
+ setup_required => sub {
+ my $setup_url = shift;
+ # Redirect the user to $setup_url
+ },
+ cancelled => sub {
+ # Do something appropriate when the user hits "cancel" at the OP
+ },
+ verified => sub {
+ my $vident = shift;
+ # Do something with the VerifiedIdentity object $vident
+ },
+ error => sub {
+ my $err = shift;
+ die($err);
+ },
+ );
+ # ... or handle the various cases yourself
if (my $setup_url = $csr->user_setup_url) {
# redirect/link/popup user to $setup_url
} elsif ($csr->user_cancel) {
@@ -731,7 +1149,7 @@ This is the Perl API for (the consumer half of) OpenID, a distributed
identity system based on proving you own a URL, which is then your
identity. More information is available at:
- http://www.danga.com/openid/
+ http://openid.net/
=head1 CONSTRUCTOR
@@ -742,8 +1160,8 @@ identity. More information is available at:
my $csr = Net::OpenID::Consumer->new([ %opts ]);
You can set the C<ua>, C<cache>, C<consumer_secret>, C<required_root>,
-and C<args> in the constructor. See the corresponding method
-descriptions below.
+C<minimum_version> and C<args> in the constructor. See the corresponding
+method descriptions below.
=back
@@ -794,6 +1212,27 @@ the same time.)
Your secret may not exceed 255 characters.
+=item $csr->B<minimum_version>(2)
+
+=item $csr->B<minimum_version>
+
+Get or set the minimum OpenID protocol version supported. Currently
+the only useful value you can set here is 2, which will cause
+1.1 identifiers to fail discovery with the error C<protocol_version_incorrect>.
+
+In most cases you'll want to allow both 1.1 and 2.0 identifiers,
+which is the default. If you want, you can set this property to 1
+to make this behavior explicit.
+
+=item $csr->B<message>($key)
+
+Obtain a value from the message contained in the request arguments
+with the given key. This can only be used to obtain core arguments,
+not extension arguments.
+
+Call this method without a C<$key> argument to get a L<Net::OpenID::IndirectMessage>
+object representing the message.
+
=item $csr->B<args>($ref)
=item $csr->B<args>($param)
@@ -810,6 +1249,10 @@ Where $reference is either a HASH ref, CODE ref, Apache $r,
Apache::Request $apreq, or CGI.pm $cgi. If a CODE ref, the subref
must return the value given one argument (the parameter to retrieve)
+If you pass in an Apache $r object, you must not have already called
+$r->content as the consumer module will want to get the request
+arguments out of here in the case of a POST request.
+
2. Get a paramater:
my $foo = $csr->args("foo");
@@ -817,6 +1260,9 @@ my $foo = $csr->args("foo");
When given an unblessed scalar, it retrieves the value. It croaks if
you haven't defined a way to get at the parameters.
+Most callers should instead use the C<message> method above, which
+abstracts away the need to understand OpenID's message serialization.
+
3. Get the getter:
my $code = $csr->args;
@@ -824,6 +1270,10 @@ my $code = $csr->args;
Without arguments, returns a subref that returns the value given a
parameter name.
+Most callers should instead use the C<message> method above with no
+arguments, which returns an object from which extension attributes
+can be obtained by their documented namespace URI.
+
=item $nos->B<required_root>($url_prefix)
=item $url_prefix = $nos->B<required_root>
@@ -858,6 +1308,33 @@ codes (from $csr->B<errcode>) to decide what to present to the user:
=back
+=item $csr->B<handle_server_response>( %callbacks );
+
+When a request comes in that contains a response from an OpenID provider,
+figure out what it means and dispatch to an appropriate callback to handle
+the request. This is the callback-based alternative to explicitly calling
+the methods below in the correct sequence, and is recommended unless you
+need to do something strange.
+
+Anything you return from the selected callback function will be returned
+by this method verbatim. This is useful if the caller needs to return
+something different in each case.
+
+The available callbacks are:
+
+=over 8
+
+=item B<not_openid> - the request isn't an OpenID response after all.
+
+=item B<setup_required>($setup_url) - the provider needs to present some UI to the user before it can respond. Send the user to the given URL by some means.
+
+=item B<cancelled> - the user cancelled the authentication request from the provider's UI
+
+=item B<verified>($verified_identity) - the user's identity has been successfully verified. A L<Net::OpenID::VerifiedIdentity> object is passed in.
+
+=item B<error>($errcode, $errmsg) - an error has occured. An error code and message are provided.
+
+=back
=item $csr->B<user_setup_url>( [ %opts ] )
@@ -943,9 +1420,15 @@ maintainer.
This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
+=head1 MAILING LIST
+
+The Net::OpenID family of modules has a mailing list powered
+by Google Groups. For more information, see
+http://groups.google.com/group/openid-perl .
+
=head1 SEE ALSO
-OpenID website: http://www.danga.com/openid/
+OpenID website: http://openid.net/
L<Net::OpenID::ClaimedIdentity> -- part of this module
@@ -956,3 +1439,8 @@ L<Net::OpenID::Server> -- another module, for acting like an OpenID server
=head1 AUTHORS
Brad Fitzpatrick <brad at danga.com>
+
+Tatsuhiko Miyagawa <miyagawa at sixapart.com>
+
+Martin Atkins <mart at degeneration.co.uk>
+
diff --git a/lib/Net/OpenID/IndirectMessage.pm b/lib/Net/OpenID/IndirectMessage.pm
new file mode 100644
index 0000000..639d546
--- /dev/null
+++ b/lib/Net/OpenID/IndirectMessage.pm
@@ -0,0 +1,255 @@
+
+package Net::OpenID::IndirectMessage;
+
+use strict;
+use Carp;
+use Net::OpenID::Consumer;
+
+sub new {
+ my $class = shift;
+ my $what = shift;
+ my %opts = @_;
+
+ my $self = bless {}, $class;
+
+ $self->{minimum_version} = delete $opts{minimum_version};
+
+ Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
+
+ my $getter;
+ my $enumer;
+ if (ref $what eq "HASH") {
+ # In this case it's the caller's responsibility to determine
+ # whether the method is GET or POST.
+ $getter = sub { $what->{$_[0]}; };
+ $enumer = sub { keys(%$what); };
+ }
+ elsif (UNIVERSAL::isa($what, "CGI")) {
+ # CGI automatically does what we need when method is POST
+ $getter = sub { scalar $what->param($_[0]); };
+ $enumer = sub { $what->param; };
+ }
+ elsif (ref $what eq "Apache") {
+ my %get;
+ if ($what->method eq 'POST') {
+ %get = $what->content;
+ }
+ else {
+ %get = $what->args;
+ }
+ $getter = sub { $get{$_[0]}; };
+ $enumer = sub { keys(%get); };
+ }
+ elsif (ref $what eq "Apache::Request") {
+ # Apache::Request includes the POST and GET arguments in ->param
+ # when doing a POST request, which is close enough to what
+ # the spec requires.
+ $getter = sub { scalar $what->param($_[0]); };
+ $enumer = sub { $what->param; };
+ }
+ elsif (ref $what eq "CODE") {
+ $getter = $what;
+ # We can't enumerate with just a coderef.
+ # OpenID 2 spec only requires enumeration to support
+ # extension namespaces, so we don't care too much.
+ $enumer = sub { return (); };
+ }
+ else {
+ $what = 'undef' if !defined $what;
+ Carp::croak("Unknown parameter type ($what)");
+ }
+ $self->{getter} = $getter;
+ $self->{enumer} = $enumer;
+
+ # Now some quick pre-configuration of a few bits
+
+ # Is this an OpenID message at all?
+ # All OpenID messages have an openid.mode value...
+ return undef unless $self->get('mode');
+
+ # Is this an OpenID 2.0 message?
+ my $ns = $self->get('ns');
+
+
+ # The 2.0 spec section 4.1.2 requires that we support these namespace values
+ # but act like it's a normal 1.1 request.
+ # We do this by just pretending that ns wasn't set at all.
+ if ($ns && ($ns eq 'http://openid.net/signon/1.1' || $ns eq 'http://openid.net/signon/1.0')) {
+ $ns = undef;
+ }
+
+ if (defined($ns) && $ns eq OpenID::util::version_2_namespace()) {
+ $self->{protocol_version} = 2;
+ }
+ elsif (! defined($ns)) {
+ # No namespace at all means a 1.1 message
+ if (($self->{minimum_version}||0) <= 1) {
+ $self->{protocol_version} = 1;
+ }
+ else {
+ # Pretend we don't understand the message.
+ return undef;
+ }
+ }
+ else {
+ # Unknown version is the same as not being an OpenID message at all
+ return undef;
+ }
+
+ # This will be populated in on demand
+ $self->{extension_prefixes} = undef;
+
+ return $self;
+}
+
+sub protocol_version {
+ return $_[0]->{protocol_version};
+}
+
+sub mode {
+ my $self = shift;
+ return $self->get('mode');
+}
+
+sub get {
+ my $self = shift;
+ my $key = shift or Carp::croak("No argument name supplied to get method");
+
+ # NOTE: There is intentionally no way to get all of the keys in the core
+ # namespace because that means we don't need to be able to enumerate
+ # to support the core protocol, and there is no requirement to enumerate
+ # anyway.
+
+ # Arguments can only contain letters, numbers, underscores and dashes
+ Carp::croak("Invalid argument key $key") unless $key =~ /^[\w\-]+$/;
+ Carp::croak("Too many arguments") if scalar(@_);
+
+ return $self->{getter}->("openid.$key");
+}
+
+sub raw_get {
+ my $self = shift;
+ my $key = shift or Carp::croak("No argument name supplied to raw_get method");
+
+ return $self->{getter}->($key);
+}
+
+sub getter {
+ my $self = shift;
+
+ return $self->{getter};
+}
+
+sub get_ext {
+ my $self = shift;
+ my $namespace = shift or Carp::croak("No namespace URI supplied to get_ext method");
+ my $key = shift;
+
+ Carp::croak("Too many arguments") if scalar(@_);
+
+ $self->_compute_extension_prefixes() unless defined($self->{extension_prefixes});
+
+ my $alias = $self->{extension_prefixes}{$namespace};
+ return $key ? undef : {} unless $alias;
+
+ if ($key) {
+ return $self->{getter}->("openid.$alias.$key");
+ }
+ else {
+ my $prefix = "openid.$alias.";
+ my $prefixlen = length($prefix);
+ my $ret = {};
+ foreach my $key ($self->{enumer}->()) {
+ next unless substr($key, 0, $prefixlen) eq $prefix;
+ $ret->{substr($key, $prefixlen)} = $self->{getter}->($key);
+ }
+ return $ret;
+ }
+}
+
+sub has_ext {
+ my $self = shift;
+ my $namespace = shift or Carp::croak("No namespace URI supplied to get_ext method");
+
+ Carp::croak("Too many arguments") if scalar(@_);
+
+ $self->_compute_extension_prefixes() unless defined($self->{extension_prefixes});
+
+ return defined($self->{extension_prefixes}{$namespace}) ? 1 : 0;
+}
+
+sub _compute_extension_prefixes {
+ my ($self) = @_;
+
+ return unless $self->{enumer};
+
+ $self->{extension_prefixes} = {};
+ if ($self->protocol_version != 1) {
+ foreach my $key ($self->{enumer}->()) {
+ next unless $key =~ /^openid\.ns\.(\w+)$/;
+ my $alias = $1;
+ my $uri = $self->{getter}->($key);
+ $self->{extension_prefixes}{$uri} = $alias;
+ }
+ }
+ else {
+ # Synthesize the SREG namespace as it was used in OpenID 1.1
+ $self->{extension_prefixes}{"http://openid.net/extensions/sreg/1.1"} = "sreg";
+ }
+}
+
+1;
+
+=head1 NAME
+
+Net::OpenID::IndirectMessage - Class representing a collection of namespaced arguments
+
+=head1 DESCRIPTION
+
+This class acts as an abstraction layer over a collection of flat URL arguments
+which supports namespaces as defined by the OpenID Auth 2.0 specification.
+
+It also recognises when its is given OpenID 1.1 non-namespaced arguments and
+acts as if the relevant namespaces were present. In this case, it only
+supports the basic OpenID 1.1 arguments and the extension arguments
+for Simple Registration.
+
+This class can operate on a normal hashref, a L<CGI> object, an L<Apache>
+object, an L<Apache::Request> object or an arbitrary C<CODE> ref that takes
+a key name as its first parameter and returns a value. However,
+if you use a coderef then extension arguments are not supported.
+
+If you pass in a hashref or a coderef it is your responsibility as the caller
+to check the HTTP request method and pass in the correct set of arguments. If
+you use an Apache, Apache::Request or CGI object then this module will do
+the right thing automatically.
+
+=head1 SYNOPSIS
+
+ use Net::OpenID::IndirectMessage;
+
+ # Pass in something suitable for the underlying flat dictionary.
+ # Will return an instance if the request arguments can be understood
+ # as a supported OpenID Message format.
+ # Will return undef if this doesn't seem to be an OpenID Auth message.
+ # Will croak if the $argumenty_thing is not of a suitable type.
+ my $args = Net::OpenID::IndirectMessage->new($argumenty_thing);
+
+ # Determine which protocol version the message is using.
+ # Currently this can be either 1 for 1.1 or 2 for 2.0.
+ # Expect larger numbers for other versions in future.
+ # Most callers don't really need to care about this.
+ my $version = $args->protocol_version();
+
+ # Get a core argument value ("openid.mode")
+ my $mode = $args->get("mode");
+
+ # Get an extension argument value
+ my $nickname = $args->get_ext("http://openid.net/extensions/sreg/1.1", "nickname");
+
+ # Get hashref of all arguments in a given namespace
+ my $sreg = $args->get_ext("http://openid.net/extensions/sreg/1.1");
+
+Most of the time callers won't need to use this class directly, but will instead
+access it through a L<Net::OpenID::Consumer> instance.
+
diff --git a/lib/Net/OpenID/URIFetch.pm b/lib/Net/OpenID/URIFetch.pm
new file mode 100644
index 0000000..125a2f7
--- /dev/null
+++ b/lib/Net/OpenID/URIFetch.pm
@@ -0,0 +1,183 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+Net::OpenID::URIFetch - fetch and cache content from HTTP URLs
+
+=head1 DESCRIPTION
+
+This is roughly based on Ben Trott's URI::Fetch module, but
+URI::Fetch doesn't cache enough headers that Yadis can be implemented
+with it, so this is a lame copy altered to allow Yadis support.
+
+Hopefully one day URI::Fetch can be modified to do what we need and
+this can go away.
+
+This module is tailored to the needs of Net::OpenID::Consumer and probably
+isn't much use outside of it. See URI::Fetch for a more general module.
+
+=cut
+
+package Net::OpenID::URIFetch;
+
+use HTTP::Request;
+use HTTP::Status;
+use strict;
+use warnings;
+use Carp;
+
+our $HAS_ZLIB;
+BEGIN {
+ $HAS_ZLIB = eval "use Compress::Zlib (); 1;";
+}
+
+use constant URI_OK => 200;
+use constant URI_MOVED_PERMANENTLY => 301;
+use constant URI_NOT_MODIFIED => 304;
+use constant URI_GONE => 410;
+
+sub fetch {
+ my ($class, $uri, $consumer, $content_hook) = @_;
+
+ if ($uri eq 'x-xrds-location') {
+ Carp::confess("Buh?");
+ }
+
+ my $ua = $consumer->ua;
+ my $cache = $consumer->cache;
+ my $ref;
+
+ # By prefixing the cache key, we can ensure we won't
+ # get left-over cache items from older versions of Consumer
+ # that used URI::Fetch.
+ my $cache_key = 'URIFetch:'.$uri;
+
+ if ($cache) {
+ if (my $blob = $cache->get($cache_key)) {
+ $ref = Storable::thaw($blob);
+ }
+ }
+
+ # We just serve anything from the last 60 seconds right out of the cache,
+ # thus avoiding doing several requests to the same URL when we do
+ # Yadis, then HTML discovery.
+ # TODO: Make this tunable?
+ if ($ref && $ref->{CacheTime} > (time() - 60)) {
+ $consumer->_debug("Cache HIT for $uri");
+ return Net::OpenID::URIFetch::Response->new(
+ status => 200,
+ content => $ref->{Content},
+ headers => $ref->{Headers},
+ final_uri => $ref->{FinalURI},
+ );
+ }
+ else {
+ $consumer->_debug("Cache MISS for $uri");
+ }
+
+ my $req = HTTP::Request->new(GET => $uri);
+ if ($HAS_ZLIB) {
+ $req->header('Accept-Encoding', 'gzip');
+ }
+ if ($ref) {
+ if (my $etag = ($ref->{Headers}->{etag})) {
+ $req->header('If-None-Match', $etag);
+ }
+ if (my $ts = ($ref->{Headers}->{'last-modified'})) {
+ $req->if_modified_since($ts);
+ }
+ }
+
+ my $res = $ua->request($req);
+
+ # There are only a few headers that OpenID/Yadis care about
+ my @useful_headers = qw(last-modified etag content-type x-yadis-location x-xrds-location);
+
+ my %response_fields;
+
+ if ($res->code == HTTP::Status::RC_NOT_MODIFIED()) {
+ $consumer->_debug("Server says it's not modified. Serving from cache.");
+ return Net::OpenID::URIFetch::Response->new(
+ status => 200,
+ content => $ref->{Content},
+ headers => $ref->{Headers},
+ final_uri => $ref->{FinalURI},
+ );
+ }
+ else {
+ my $content = $res->content;
+ my $final_uri = $res->request->uri->as_string();
+ my $final_cache_key = "URIFetch:".$final_uri;
+
+ if ($res->content_encoding && $res->content_encoding eq 'gzip') {
+ $content = Compress::Zlib::memGunzip($content);
+ }
+
+ if ($content_hook) {
+ $content_hook->(\$content);
+ }
+
+ my $headers = {};
+ foreach my $k (@useful_headers) {
+ $headers->{$k} = $res->header($k);
+ }
+
+ my $ret = Net::OpenID::URIFetch::Response->new(
+ status => $res->code,
+ content => $content,
+ headers => $headers,
+ final_uri => $final_uri,
+ );
+
+ if ($cache && $res->code == 200) {
+ my $cache_data = {
+ Headers => $ret->headers,
+ Content => $ret->content,
+ CacheTime => time(),
+ FinalURI => $final_uri,
+ };
+ my $cache_blob = Storable::freeze($cache_data);
+ $cache->set($final_cache_key, $cache_blob);
+ $cache->set($cache_key, $cache_blob);
+ }
+
+ return $ret;
+ }
+
+}
+
+package Net::OpenID::URIFetch::Response;
+
+sub new {
+ my ($class, %opts) = @_;
+
+ my $self = {};
+ $self->{final_uri} = delete($opts{final_uri});
+ $self->{status} = delete($opts{status});
+ $self->{content} = delete($opts{content});
+ $self->{headers} = delete($opts{headers});
+
+ return bless $self, $class;
+}
+
+sub final_uri {
+ return $_[0]->{final_uri};
+}
+
+sub status {
+ return $_[0]->{status};
+}
+
+sub content {
+ return $_[0]->{content};
+}
+
+sub headers {
+ return $_[0]->{headers};
+}
+
+sub header {
+ return $_[0]->{headers}{lc($_[1])};
+}
+
+1;
diff --git a/lib/Net/OpenID/VerifiedIdentity.pm b/lib/Net/OpenID/VerifiedIdentity.pm
index d39e36d..b99a485 100644
--- a/lib/Net/OpenID/VerifiedIdentity.pm
+++ b/lib/Net/OpenID/VerifiedIdentity.pm
@@ -4,18 +4,17 @@ use Carp ();
############################################################################
package Net::OpenID::VerifiedIdentity;
use fields (
- 'identity', # the verified identity URL
- 'id_uri', # the verified identity's URI object
+ 'identity', # the verified identity URL
+ 'id_uri', # the verified identity's URI object
- 'foaf', # discovered foaf URL
- 'foafmaker', # discovered foaf maker
- 'rss', # discovered rss feed
- 'atom', # discovered atom feed
+ 'claimed_identity', # The ClaimedIdentity object that we've verified
+ 'semantic_info', # The "semantic info" (RSS URLs, etc) at the verified identity URL
- 'consumer', # The Net::OpenID::Consumer module which created us
+ 'consumer', # The Net::OpenID::Consumer module which created us
- 'signed_fields' , # hashref of key->value of things that were signed. without "openid." prefix
- );
+ 'signed_fields' , # hashref of key->value of things that were signed. without "openid." prefix
+ 'signed_message', # the signed fields as an IndirectMessage object. Created when needed.
+);
use URI;
sub new {
@@ -25,13 +24,14 @@ sub new {
$self->{'consumer'} = delete $opts{'consumer'};
- if ($self->{'identity'} = delete $opts{'identity'}) {
+ if ($self->{'claimed_identity'} = delete $opts{'claimed_identity'}) {
+ $self->{identity} = $self->{claimed_identity}->claimed_url;
unless ($self->{'id_uri'} = URI->new($self->{identity})) {
return $self->{'consumer'}->_fail("invalid_uri");
}
}
- for my $par (qw(foaf foafmaker rss atom signed_fields)) {
+ for my $par (qw(signed_fields)) {
$self->$par(delete $opts{$par});
}
@@ -49,17 +49,85 @@ sub display {
return DisplayOfURL($self->{'identity'});
}
-sub foafmaker { &_getset; }
+sub _semantic_info_hash {
+ my ($self) = @_;
+ return $self->{semantic_info} if $self->{semantic_info};
+ my $sem_info = $self->{claimed_identity}->semantic_info;
+ $self->{semantic_info} = {
+ 'foaf' => $self->_identity_relative_uri($sem_info->{"foaf"}),
+ 'foafmaker' => $sem_info->{"foaf.maker"},
+ 'rss' => $self->_identity_relative_uri($sem_info->{"rss"}),
+ 'atom' => $self->_identity_relative_uri($sem_info->{"atom"}),
+ };
+ return $self->{semantic_info};
+}
+
+sub _identity_relative_uri {
+ my $self = shift;
+ my $url = shift;
+
+ return $url if ref $url;
+ return undef unless $url;
+ return URI->new_abs($url, $self->{'id_uri'});
+}
+
sub signed_fields { &_getset; }
sub foaf { &_getset_semurl; }
sub rss { &_getset_semurl; }
sub atom { &_getset_semurl; }
+sub foafmaker { &_getset_sem; }
sub declared_foaf { &_dec_semurl; }
sub declared_rss { &_dec_semurl; }
sub declared_atom { &_dec_semurl; }
+sub extension_fields {
+ my ($self, $ns_uri) = @_;
+ return $self->_extension_fields($ns_uri, $self->{consumer}->message);
+}
+
+sub signed_extension_fields {
+ my ($self, $ns_uri) = @_;
+
+ return $self->_extension_fields($ns_uri, $self->signed_message);
+}
+
+sub _extension_fields {
+ my ($self, $ns_uri, $args) = @_;
+
+ return $args->get_ext($ns_uri);
+}
+
+sub signed_message {
+ my ($self) = @_;
+
+ return $self->{signed_message} if $self->{signed_message};
+
+ # This is maybe a bit hacky.
+ # We need to synthesize an IndirectMessage object
+ # representing the signed fields, which means
+ # that we need to fake up the mandatory message
+ # arguments that probably weren't signed.
+
+ my %args = map { 'openid.'.$_ => $self->{signed_fields}{$_} } keys %{$self->{signed_fields}};
+
+ my $real_message = $self->{consumer}->message;
+ if ($real_message->protocol_version == 1) {
+ # OpenID 1.1 just needs a mode.
+ $args{'openid.mode'} = 'id_res';
+ }
+ else {
+ # OpenID 2.2 needs the namespace URI as well
+ $args{'openid.ns'} = 'http://specs.openid.net/auth/2.0';
+ $args{'openid.mode'} = 'id_res';
+ }
+
+ my $message = Net::OpenID::IndirectMessage->new(\%args);
+
+ return $self->{signed_message} = $message;
+}
+
sub _getset {
my $self = shift;
my $param = (caller(1))[3];
@@ -73,20 +141,36 @@ sub _getset {
return $self->{$param};
}
+sub _getset_sem {
+ my $self = shift;
+ my $param = (caller(1))[3];
+ $param =~ s/.+:://;
+
+ my $info = $self->_semantic_info_hash;
+
+ if (my $value = shift) {
+ Carp::croak("Too many parameters") if @_;
+ $info->{$param} = $value;
+ }
+ return $info->{$param};
+}
+
sub _getset_semurl {
my $self = shift;
my $param = (caller(1))[3];
$param =~ s/.+:://;
+ my $info = $self->_semantic_info_hash;
+
if (my $surl = shift) {
Carp::croak("Too many parameters") if @_;
# TODO: make absolute URL from possibly relative one
my $abs = URI->new_abs($surl, $self->{'id_uri'});
- $self->{$param} = $abs;
+ $info->{$param} = $abs;
}
- my $uri = $self->{$param};
+ my $uri = $info->{$param};
return $uri && _url_is_under($self->{'id_uri'}, $uri) ? $uri->as_string : undef;
}
@@ -95,7 +179,9 @@ sub _dec_semurl {
my $param = (caller(1))[3];
$param =~ s/.+::declared_//;
- my $uri = $self->{$param};
+ my $info = $self->_semantic_info_hash;
+
+ my $uri = $info->{$param};
return $uri ? $uri->as_string : undef;
}
@@ -223,7 +309,38 @@ the tilde form, or "/users/USERNAME" or "/members/USERNAME". If the
path component is empty or just "/", then the display form is just the
hostname, so "http://myblog.com/" is just "myblog.com".
-Suggestions for improving this function are welcome!
+Suggestions for improving this function are welcome, but you'll probably
+get more satisfying results if you make use of the data returned by
+the Simple Registration (SREG) extension, which allows the user to
+choose a preferred nickname to use on your site.
+
+=item $vident->B<extension_fields>($ns_uri)
+
+Return the fields from the given extension namespace, if any, that
+were included in the assertion request. The fields are returned in
+a hashref.
+
+In most cases you'll probably want to use B<signed_extension_fields> instead,
+to avoid attacks where a man-in-the-middle alters the extension fields in transit.
+
+Note that for OpenID 1.1 transactions only Simple Registration (SREG) 1.1
+is supported.
+
+=item $vident->B<signed_extension_fields>($ns_uri)
+
+The same as B<extension_fields> except that only fields that were signed
+as part of the assertion are included in the returned hashref. For example,
+if you included a Simple Registration request in your initial message,
+you might fetch the results (if any) like this:
+
+ $sreg = $vident->signed_extension_fields(
+ 'http://openid.net/extensions/sreg/1.1',
+ );
+
+An important gotcha to bear in mind is that for OpenID 2.0 responses
+no extension fields can be considered signed unless the corresponding
+extension namespace declaration is also signed. If that is not the case,
+this method will behave as if no extension fields for that URI were signed.
=item $vident->B<rss>
diff --git a/lib/Net/OpenID/Yadis.pm b/lib/Net/OpenID/Yadis.pm
new file mode 100644
index 0000000..3866ff4
--- /dev/null
+++ b/lib/Net/OpenID/Yadis.pm
@@ -0,0 +1,453 @@
+package Net::OpenID::Yadis;
+
+use strict;
+use warnings;
+use vars qw($VERSION @EXPORT);
+$VERSION = "0.05";
+
+use base qw(Exporter);
+use Carp ();
+use Net::OpenID::URIFetch;
+use XML::Simple;
+use Net::OpenID::Yadis::Service;
+
+ at EXPORT = qw(YR_HEAD YR_GET YR_XRDS);
+
+use constant {
+ YR_GET => 1,
+ YR_XRDS => 2,
+};
+
+use fields (
+ 'last_errcode', # last error code we got
+ 'last_errtext', # last error code we got
+ 'debug', # debug flag or codeblock
+ 'consumer', # consumer object
+ 'identity_url', # URL to be identified
+ 'xrd_url', # URL of XRD file
+ 'xrd_objects', # Yadis XRD decoded objects
+ );
+
+sub new {
+ my $self = shift;
+ $self = fields::new( $self ) unless ref $self;
+ my %opts = @_;
+
+ $self->consumer(delete($opts{consumer}));
+
+ $self->{debug} = delete $opts{debug};
+
+ Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
+
+ return $self;
+}
+
+sub consumer { &_getset; }
+
+sub identity_url { &_getset; }
+sub xrd_url { &_getset; }
+sub xrd_objects { _pack_array(&_getset); }
+sub _getset {
+ my $self = shift;
+ my $param = (caller(1))[3];
+ $param =~ s/.+:://;
+
+ if (@_) {
+ my $val = shift;
+ Carp::croak("Too many parameters") if @_;
+ $self->{$param} = $val;
+ }
+ return $self->{$param};
+}
+
+sub _debug {
+ my $self = shift;
+ return unless $self->{debug};
+
+ if (ref $self->{debug} eq "CODE") {
+ $self->{debug}->($_[0]);
+ } else {
+ print STDERR "[DEBUG Net::OpenID::Yadis] $_[0]\n";
+ }
+}
+
+sub _fail {
+ my $self = shift;
+ my ($code, $text) = @_;
+
+ $text ||= {
+ 'xrd_parse_error' => "Error occured since parsing yadis document.",
+ 'xrd_format_error' => "This is not yadis document (not xrds format).",
+ 'too_many_hops' => 'Too many hops by X-XRDS-Location.',
+ 'empty_url' => 'Empty URL',
+ 'no_yadis_document' => 'Cannot find yadis Document',
+ 'url_gone' => 'URL is no longer available',
+ }->{$code};
+
+ $self->{last_errcode} = $code;
+ $self->{last_errtext} = $text;
+
+ $self->_debug("fail($code) $text");
+ wantarray ? () : undef;
+}
+sub err {
+ my $self = shift;
+ $self->{last_errcode} . ": " . $self->{last_errtext};
+}
+sub errcode {
+ my $self = shift;
+ $self->{last_errcode};
+}
+sub errtext {
+ my $self = shift;
+ $self->{last_errtext};
+}
+sub _clear_err {
+ my $self = shift;
+ $self->{last_errtext} = '';
+ $self->{last_errcode} = '';
+}
+
+sub _get_contents {
+ my $self = shift;
+ my ($url, $final_url_ref, $content_ref, $headers_ref) = @_;
+
+ my $alter_hook = sub {
+ my $htmlref = shift;
+ $$htmlref =~ s/<body\b.*//is;
+ };
+
+ my $res = Net::OpenID::URIFetch->fetch($url, $self->consumer, $alter_hook);
+
+ if ($res) {
+ $$final_url_ref = $res->final_uri;
+ my $headers = $res->headers;
+ foreach my $k (keys %$headers) {
+ $headers_ref->{$k} ||= $headers->{$k};
+ }
+ $$content_ref = $res->content;
+ return 1;
+ }
+ else {
+ return undef;
+ }
+}
+
+sub discover {
+ my $self = shift;
+ my $url = shift or return $self->_fail("empty_url");
+ my $count = shift || YR_GET;
+ Carp::croak("Too many parameters") if @_;
+
+ # trim whitespace
+ $url =~ s/^\s+//;
+ $url =~ s/\s+$//;
+ return $self->_fail("empty_url") unless $url;
+
+ my $final_url;
+ my %headers;
+
+ my $xrd;
+ $self->_get_contents($url, \$final_url, \$xrd, \%headers) or return;
+
+ $self->identity_url($final_url) if ($count < YR_XRDS);
+
+ my $doc_url;
+ if (($doc_url = $headers{'x-yadis-location'} || $headers{'x-xrds-location'}) && ($count < YR_XRDS)) {
+ return $self->discover($doc_url, YR_XRDS);
+ }
+ elsif ( (split /;\s*/, $headers{'content-type'})[0] eq 'application/xrds+xml') {
+ $self->xrd_url($final_url);
+ return $self->parse_xrd($xrd);
+ }
+ else {
+ return $self->_fail($count == YR_GET ? "no_yadis_document" : "too_many_hops");
+ }
+}
+
+sub parse_xrd {
+ my $self = shift;
+ my $xrd = shift;
+ Carp::croak("Too many parameters") if @_;
+
+ my $xs_hash = XMLin($xrd) or return $self->_fail("xrd_parse_error");
+ ($xs_hash->{'xmlns'} and $xs_hash->{'xmlns'} eq 'xri://$xrd*($v*2.0)') or $self->_fail("xrd_format_error");
+ my %xmlns;
+ foreach (map { /^(xmlns:(.+))$/ and [$1,$2] } keys %$xs_hash) {
+ next unless ($_);
+ $xmlns{$_->[1]} = $xs_hash->{$_->[0]};
+ }
+ my @priority;
+ my @nopriority;
+ foreach my $service (_pack_array($xs_hash->{'XRD'}{'Service'})) {
+ bless $service, "Net::OpenID::Yadis::Service";
+ $service->{'Type'} or next;
+ $service->{'URI'} ||= $self->identity_url;
+
+ foreach my $sname (keys %$service) {
+ foreach my $ns (keys %xmlns) {
+ $service->{"{$xmlns{$ns}}$1"} = delete $service->{$sname} if ($sname =~ /^${ns}:(.+)$/);
+ }
+ }
+ defined($service->{'priority'}) ? push(@priority,$service) : push(@nopriority,$service);
+ # Services without priority fields are lowest priority
+ }
+ my @service = sort {$a->{'priority'} <=> $b->{'priority'}} @priority;
+ push (@service, at nopriority);
+ foreach (grep {/^_protocol/} keys %$self) { delete $self->{$_} }
+
+ $self->xrd_objects(\@service);
+}
+
+sub _pack_array { wantarray ? ref($_[0]) eq 'ARRAY' ? @{$_[0]} : ($_[0]) : $_[0] }
+
+sub services {
+ my $self = shift;
+ my %protocols;
+ my @protocols;
+ my $code_ref;
+ my $protocol = undef;
+
+ Carp::croak("You haven't called the discover method yet") unless $self->xrd_objects;
+
+ foreach my $option (@_) {
+ Carp::croak("No further arguments allowed after code reference argument") if $code_ref;
+ my $ref = ref($option);
+ if ($ref eq 'CODE') {
+ $code_ref = $option;
+ } else {
+ my $default = {versionarray => []};
+
+ $protocols{$option} = $default;
+ $protocol = $option;
+ push @protocols, $option;
+ }
+ }
+
+ my @servers;
+ @servers = $self->xrd_objects if (keys %protocols == 0);
+ foreach my $key (@protocols) {
+ my $regex = $protocols{$key}->{urlregex} || $key;
+ my @ver = @{$protocols{$key}->{versionarray}};
+ my $ver_regex = @ver ? '('.join('|',map { $_ =~ s/\./\\./g; $_ } @ver).')' : '.+' ;
+ $regex =~ s/\\ver/$ver_regex/;
+
+ push (@servers,map { $protocols{$key}->{objectclass} ? bless($_ , $protocols{$key}->{objectclass}) : $_ } grep {join(",",$_->Type) =~ /$regex/} $self->xrd_objects);
+ }
+
+ @servers = $code_ref->(@servers) if ($code_ref);
+
+ wantarray ? @servers : \@servers;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Net::OpenID::Yadis - Perform Yadis discovery on URLs
+
+=head1 SYNOPSIS
+
+ use Net::OpenID::Yadis;
+
+ my $disc = Net::OpenID::Yadis->new(
+ consumer => $consumer, # Net::OpenID::Consumer object
+ );
+
+ my $xrd = $disc->discover("http://id.example.com/") or Carp::croak($disc->err);
+
+ print $disc->identity_url; # Yadis URL (Final URL if redirected)
+ print $disc->xrd_url; # Yadis Resourse Descriptor URL
+
+ foreach my $srv (@$xrd) { # Loop for Each Service in Yadis Resourse Descriptor
+ print $srv->priority; # Service priority (sorted)
+ print $srv->Type; # Identifier of some version of some service (scalar, array or array ref)
+ print $srv->URI; # URI that resolves to a resource providing the service (scalar, array or array ref)
+ print $srv->extra_field("Delegate","http://openid.net/xmlns/1.0");
+ # Extra field of some service
+ }
+
+ # If you are interested only in OpenID. (either 1.1 or 2.0)
+ my $xrd = $self->services(
+ 'http://specs.openid.net/auth/2.0/signon',
+ 'http://specs.openid.net/auth/2.0/server',
+ 'http://openid.net/signon/1.1',
+ );
+
+ # If you want to choose random server by code-ref.
+ my $xrd = $self->services(sub{($_[int(rand(@_))])});
+
+=head1 DESCRIPTION
+
+This module provides an implementation of the Yadis protocol, which does
+XRDS-based service discovery on URLs.
+
+This module was originally developed by OHTSUKA Ko-hei as L<Net::Yadis::Discovery>,
+but was forked and simplified for inclusion in the core OpenID Consumer package.
+
+This simplified version is tailored for the needs of Net::OpenID::Consumer; for other
+uses, L<Net::Yadis::Discovery> is probably a better choice.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item C<new>
+
+my $disc = Net::OpenID::Yadis->new([ %opts ]);
+
+You can set the C<consumer> in the constructor. See the corresponding
+method description below.
+
+=back
+
+=head1 EXPORT
+
+This module exports three constant values to use with discover method.
+
+=over 4
+
+=item C<YR_GET>
+
+If you set this, module check Yadis URL start from HTTP GET request. This is the default.
+
+=item C<YR_XRDS>
+
+If you set this, this module consider Yadis URL as Yadis Resource Descriptor URL.
+If not so, an error is returned.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $disc->B<consumer>($consumer)
+
+=item $disc->B<consumer>
+
+Get or set the Net::OpenID::Consumer object that this object is associated with.
+
+=item $disc->B<discover>($url,[$request_method])
+
+Given a user-entered $url (which could be missing http://, or have
+extra whitespace, etc), returns either array/array ref of Net::OpenID::Yadis::Service
+objects, or undef on failure.
+
+$request_method is optional, and if set this, you can change the HTTP
+request method of fetching Yadis URL.
+See EXPORT to know the value you can set, and default is YR_HEAD.
+
+If this method returns undef, you can rely on the following errors
+codes (from $csr->B<errcode>) to decide what to present to the user:
+
+=over 8
+
+=item xrd_parse_error
+
+=item xrd_format_error
+
+=item too_many_hops
+
+=item no_yadis_document
+
+=item url_fetch_err
+
+=item empty_url
+
+=item url_gone
+
+=back
+
+=item $disc->B<xrd_objects>
+
+Returns array/array ref of Net::OpenID::Yadis objects.
+It is same what could be got by discover method.
+
+=item $disc->B<identity_url>
+
+Returns Yadis URL.
+If not redirected, it is same with the argument of discover method.
+
+=item $disc->B<xrd_url>
+
+Returns Yadis Resource Descriptor URL.
+
+=item $disc->B<servers>($protocol,$protocol,...)
+
+=item $disc->B<servers>($protocol=>[$version1,$version2],...)
+
+=item $disc->B<servers>($protocol,....,$code_ref);
+
+Filter method of xrd_objects.
+
+If no opton is defined, returns same result with xrd_objects method.
+
+protocol names or Type URLs are given, filter only given protocol.
+Two or more protocols are given, return and results of filtering.
+
+Sample:
+ $disc->servers("openid","http://lid.netmesh.org/sso/1.0");
+
+If reference of version numbers array is given after protocol names,
+filter only given version of protocol.
+
+Sample:
+ $disc->servers("openid"=>['1.0','1.1'],"lid"=>['1.0']);
+
+If you want to use version numbers limitation with type URL, you can use
+\ver as place holder of version number.
+
+Sample:
+ $disc->servers("http://lid.netmesh.org/sso/\ver"=>['1.0','2.0']);
+
+If code reference is given as argument , you can make your own filter rule.
+code reference is executed at the last of filtering logic, like this:
+
+ @results = $code_ref->(@temporary_results)
+
+Sample: If you want to filter OpenID server and get only first one:
+ ($openid_server) = $disc->servers("openid",sub{$_[0]});
+
+=item $disc->B<err>
+
+Returns the last error, in form "errcode: errtext"
+
+=item $disc->B<errcode>
+
+Returns the last error code.
+
+=item $disc->B<errtext>
+
+Returns the last error text.
+
+=back
+
+=head1 COPYRIGHT
+
+This module is Copyright (c) 2006 OHTSUKA Ko-hei.
+All rights reserved.
+
+You may distribute under the terms of either the GNU General Public
+License or the Artistic License, as specified in the Perl README file.
+
+=head1 WARRANTY
+
+This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
+
+=head1 SEE ALSO
+
+Yadis website: L<http://yadis.org/>
+
+L<Net::OpenID::Yadis::Service>
+
+L<Net::OpenID::Consumer>
+
+=head1 AUTHORS
+
+Based on L<Net::Yadis::Discovery> by OHTSUKA Ko-hei <nene at kokogiko.net>
+
+Martin Atkins <mart at degeneration.co.uk>
+
+=cut
diff --git a/lib/Net/OpenID/Yadis/Service.pm b/lib/Net/OpenID/Yadis/Service.pm
new file mode 100644
index 0000000..0aed9df
--- /dev/null
+++ b/lib/Net/OpenID/Yadis/Service.pm
@@ -0,0 +1,74 @@
+
+package Net::OpenID::Yadis::Service;
+
+use strict;
+use warnings;
+
+sub URI { Net::OpenID::Yadis::_pack_array(shift->{'URI'}) }
+sub Type { Net::OpenID::Yadis::_pack_array(shift->{'Type'}) }
+sub priority { shift->{'priority'} }
+
+sub extra_field {
+ my $self = shift;
+ my ($field,$xmlns) = @_;
+ $xmlns and $field = "\{$xmlns\}$field";
+ $self->{$field};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Net::OpenID::Yadis::Service - Class representing an XRDS Service element
+
+=head1 SYNOPSIS
+
+ use Net::OpenID::Yadis;
+ my $disc = Net::OpenID::Yadis->new();
+ my @xrd = $disc->discover("http://id.example.com/") or Carp::croak($disc->err);
+
+ foreach my $srv (@xrd) { # Loop for Each Service in Yadis Resourse Descriptor
+ print $srv->priority; # Service priority (sorted)
+ print $srv->Type; # Identifier of some version of some service (scalar, array or array ref)
+ print $srv->URI; # URI that resolves to a resource providing the service (scalar, array or array ref)
+ print $srv->extra_field("Delegate","http://openid.net/xmlns/1.0");
+ # Extra field of some service
+ }
+
+=head1 DESCRIPTION
+
+After L<Net::OpenID::Yadis> performs discovery, the result is a list
+of instances of this class.
+
+=head1 METHODS
+
+=over 4
+
+=item $srv->B<priority>
+
+The priority value for the service.
+
+=item $srv->B<Type>
+
+The URI representing the kind of service provided at the endpoint for this record.
+
+=item $srv->B<URI>
+
+The URI of the service endpoint.
+
+=item $srv->B<extra_field>( $fieldname , $namespace )
+
+Fetch the value of extension fields not provided directly by this class.
+
+If C<$namespace> is not specified, the default is the namespace whose name is the empty string.
+
+=head1 COPYRIGHT, WARRANTY, AUTHOR
+
+See L<Net::OpenID::Yadis> for author, copyrignt and licensing information.
+
+=head1 SEE ALSO
+
+L<Net::OpenID::Yadis>
+
+Yadis website: L<http://yadis.org/>
diff --git a/t/01-misc.t b/t/01-misc.t
index b807ebd..be02d08 100644
--- a/t/01-misc.t
+++ b/t/01-misc.t
@@ -8,6 +8,9 @@ my $csr = Net::OpenID::Consumer->new;
ok($csr, "instantiated");
ok($csr->args(CGI::Subclass->new), "can set CGI subclass as args");
+package CGI::Subclass;
+use base 'CGI';
+
package CGI;
no warnings 'redefine';
@@ -16,7 +19,4 @@ sub new {
return bless {}, $class;
}
-package CGI::Subclass;
-use base 'CGI';
-
1;
diff --git a/t/02-canonical.t b/t/02-canonical.t
new file mode 100644
index 0000000..217abca
--- /dev/null
+++ b/t/02-canonical.t
@@ -0,0 +1,35 @@
+use strict;
+use warnings;
+no warnings 'redefine';
+use Net::OpenID::Consumer;
+use Test::More;
+
+my @tests = qw(
+ example.com http://example.com/
+ http://example.com http://example.com/
+ https://example.com https://example.com/
+ https://example.com/ https://example.com/
+ http://example.com/user http://example.com/user
+ http://example.com/user/ http://example.com/user/
+ http://example.com/ http://example.com/
+);
+
+{
+ use integer;
+ plan tests => (@tests / 2);
+}
+
+# stop Consumer to fetch HTML content from the URL
+local *Net::OpenID::Consumer::_find_semantic_info = sub {
+ my($self, $url, $final_url_ref) = @_;
+ $$final_url_ref = $url;
+ return { "openid.server" => "http://example.com/op" };
+};
+local *Net::OpenID::Yadis::discover = sub {};
+
+while (my($url, $normalized) = splice(@tests, 0, 2)) {
+ my $csr = Net::OpenID::Consumer->new;
+ my $identity = $csr->claimed_identity($url);
+ is $identity->claimed_url, $normalized, "$url -> $normalized";
+}
+
diff --git a/t/03-messages.t b/t/03-messages.t
new file mode 100644
index 0000000..b06bc1e
--- /dev/null
+++ b/t/03-messages.t
@@ -0,0 +1,150 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 40;
+use Net::OpenID::IndirectMessage;
+
+my $openid2_ns = 'http://specs.openid.net/auth/2.0';
+my $sreg_ns = 'http://openid.net/extensions/sreg/1.1';
+
+my %basic_v2_args = (
+ 'openid.mode' => 'id_res',
+ 'openid.ns' => $openid2_ns,
+ 'openid.test' => 'success',
+);
+
+my %basic_v1_args = (
+ 'openid.mode' => 'id_res',
+ 'openid.test' => 'success',
+);
+
+my %sreg_args = (
+ 'openid.sreg.nickname' => 'Frank',
+ 'openid.sreg.fullname' => 'Frank the Goat',
+);
+
+my $good_v2_args = args({
+ %basic_v2_args,
+});
+
+my $good_v1_args = args({
+ %basic_v1_args,
+});
+
+my $sreg_v1_args = args({
+ %basic_v1_args,
+ %sreg_args,
+});
+
+my $sreg_v2_args = args({
+ %basic_v2_args,
+ %sreg_args,
+ 'openid.ns.sreg' => $sreg_ns,
+});
+
+my $sreg_v1_in_openid_v2 = args ({
+ %basic_v2_args,
+ %sreg_args,
+});
+
+my $nonsense_args = args({
+ 'kumquats' => 'yes',
+ 'madprops' => 'no',
+ 'language' => 'spranglish',
+});
+
+my $missing_mode_v2 = args({
+ 'openid.ns' => 'http://specs.openid.net/auth/2.0',
+});
+
+my $unsupported_version_args = args({
+ %basic_v2_args,
+ 'openid.ns' => 'http://example.com/openid/some-future-version',
+});
+
+my $empty_args = args({});
+
+my $basic_test = sub {
+ my $args = shift;
+ my $version = shift;
+
+ is($args->protocol_version, $version, "detected version $version");
+ is($args->mode, 'id_res', "v$version mode correct");
+ is($args->get('test'), 'success', "v$version test correct");
+ is($args->get('missing'), undef, "v$version missing correctly");
+ should_die(sub { $args->get('sreg.fullname'); }, "v$version access invalid keyname croaks");
+ should_die(sub { $args->get(); }, "v$version missing keyname croaks");
+
+};
+
+# A valid OpenID 2.0 message
+$basic_test->($good_v2_args, 2);
+
+# A valid OpenID 1.1 message
+$basic_test->($good_v1_args, 1);
+
+# OpenID 1.1 message to consumer when we only support 2.0 or above
+is(args(\%basic_v1_args, minimum_version => 2), undef, "2.0-only doesn't understand 1.1");
+
+my $sreg_test = sub {
+ my $args = shift;
+ my $version = shift;
+
+ ok($args->has_ext($sreg_ns), "v$version has sreg namespace");
+ ok($args->get_ext($sreg_ns, 'nickname'), "v$version has sreg nickname");
+ is($args->get_ext($sreg_ns, 'nonsense'), undef, "v$version has no sreg nonsense");
+ my $sreg = $args->get_ext($sreg_ns);
+ is(keys(%$sreg), 2, "v$version two sreg args");
+ ok(defined $sreg->{nickname}, "v$version has sreg nickname in hash");
+ ok(defined $sreg->{fullname}, "v$version has sreg fullname in hash");
+ should_die(sub { $args->get_ext(); }, "v$version missing namespace croaks");
+};
+
+# SREG in a valid 2.0 message
+$sreg_test->($sreg_v2_args, 2);
+
+# SREG in a valid 1.1 message
+$sreg_test->($sreg_v1_args, 1);
+
+my $missing_extension_test = sub {
+ my $args = shift;
+ my $version = shift;
+
+ is($args->has_ext('nonsense'), 0, "v$version no nonsense extension");
+ is($args->get_ext('nonsense', 'nonsense'), undef, "v$version no nonsense extension argument");
+ is(keys(%{$args->get_ext('nonsense')}), 0, "v$version nonsense extension empty hash");
+};
+
+# A namespace that doesn't exist in a 2.0 message
+$missing_extension_test->($good_v2_args, 2);
+
+# A namespace that doesn't exist in a 1.1 message
+$missing_extension_test->($good_v1_args, 1);
+
+# V1 SREG in V2 Message
+is($sreg_v1_in_openid_v2->has_ext($sreg_ns), 0, "no v1 sreg in v2 message");
+
+# Some args that aren't an OpenID message at all
+is($nonsense_args, undef, "nonsense args give undef");
+is($missing_mode_v2, undef, "v2 with missing mode gives undef");
+is($unsupported_version_args, undef, "unsupported version gives undef");
+is($empty_args, undef, "empty hash gives undef");
+
+# Passing in garbage into the constructor
+should_die(sub { args("HELLO WORLD!"); }, "passing string into constructor croaks");
+should_die(sub { args(); }, "passing nothing into constructor croaks");
+
+sub args {
+ return Net::OpenID::IndirectMessage->new(@_);
+}
+
+sub should_die {
+ my ($coderef, $message) = @_;
+
+ eval {
+ $coderef->();
+ };
+ $@ ? pass($message) : fail($message);
+}
+
+1;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-openid-consumer-perl.git
More information about the Pkg-perl-cvs-commits
mailing list