This is an automated email from the git hooks/post-receive script.
gregoa pushed a commit to annotated tag v1.030099_001
in repository libnet-openid-common-perl.
commit 4bba69ab8fd0829fd9c6d8850835712270072a7e
Author: mart <mart@5176148d-0815-0410-95d9-e2102c905069>
Date: Thu Nov 13 04:09:20 2008 +0000
Create Net::OpenID::Common and move some bits out of ::Consumer into it so
that future versions of ::Server can use them:
* Net::OpenID::IndirectMessage can be used to make Server support
extensions in the same way that Consumer does.
* Net::OpenID::Yadis can be used by Server to implement RP endpoint
discovery.
* Net::OpenID::URIFetch is a dependency of Net::OpenID::Yadis.
git-svn-id:
http://code.sixapart.com/svn/openid/trunk/perl/Net-OpenID-Common@159
5176148d-0815-0410-95d9-e2102c905069
---
ChangeLog | 1 +
MANIFEST | 13 ++
Makefile.PL | 17 ++
lib/Net/OpenID/Common.pm | 210 ++++++++++++++++++
lib/Net/OpenID/IndirectMessage.pm | 255 +++++++++++++++++++++
lib/Net/OpenID/URIFetch.pm | 183 +++++++++++++++
lib/Net/OpenID/Yadis.pm | 453 ++++++++++++++++++++++++++++++++++++++
lib/Net/OpenID/Yadis/Service.pm | 74 +++++++
t/00-use-indirectmessage.t | 9 +
t/01-use-urifetch.t | 9 +
t/02-use-yadis.t | 9 +
t/03-use-common.t | 9 +
t/04-messages.t | 150 +++++++++++++
13 files changed, 1392 insertions(+)
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..fb272d9
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1 @@
+ * Initial version with stuff moved out of Net::OpenID::Consumer.
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..7f4c68b
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,13 @@
+Makefile.PL
+ChangeLog
+MANIFEST
+lib/Net/OpenID/Common.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-indirectmessage.t
+t/01-use-urifetch.t
+t/02-use-yadis.t
+t/03-use-common.t
+t/04-messages.t
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..2eff417
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,17 @@
+use ExtUtils::MakeMaker;
+WriteMakefile( 'NAME' => 'Net::OpenID::Common',
+ 'VERSION_FROM' => 'lib/Net/OpenID/Common.pm',
+ 'PREREQ_PM' => {
+ 'LWP::UserAgent' => 0,
+ 'HTTP::Request' => 0,
+ 'HTTP::Status' => 0,
+ 'XML::Simple' => 0,
+ 'Time::Local' => 0,
+ 'Digest::SHA1' => 0,
+ 'MIME::Base64' => 0,
+ 'Math::BigInt' => 0,
+ },
+ ($] >= 5.005 ?
+ (ABSTRACT_FROM => 'lib/Net/OpenID/Common.pm',
+ AUTHOR => 'Martin Atkins <m...@degeneration.co.uk>') :
()),
+ );
diff --git a/lib/Net/OpenID/Common.pm b/lib/Net/OpenID/Common.pm
new file mode 100644
index 0000000..690375c
--- /dev/null
+++ b/lib/Net/OpenID/Common.pm
@@ -0,0 +1,210 @@
+
+package Net::OpenID::Common;
+
+$VERSION = 1.01;
+
+=head1 NAME
+
+Net::OpenID::Common - Libraries shared between L<Net::OpenID::Consumer> and
L<Net::OpenID::Server>
+
+=head1 DESCRIPTION
+
+The Consumer and Server implementations share a few libraries which live with
this module. This module is here largely to hold the version number and this
documentation, though it also incorporates some utility functions inherited
from previous versions of L<Net::OpenID::Consumer>.
+
+=head1 COPYRIGHT
+
+This package is Copyright (c) 2005 Brad Fitzpatrick, and (c) 2008 Martin
Atkins. 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. If you need more
liberal licensing terms, please contact the maintainer.
+
+=head1 MAINTAINER
+
+Maintained by Martin Atkins <m...@degeneration.co.uk>
+
+=cut
+
+# This package should totally be called Net::OpenID::util, but
+# it was historically named wrong so we're just leaving it
+# like this to avoid confusion.
+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);
+}
+sub hmac_sha1 {
+ hmac($_[0], $_[1], \&Digest::SHA1::sha1, 64);
+}
+sub hmac {
+ my($data, $key, $hash_func, $block_size) = @_;
+ $block_size ||= 64;
+ $key = &$hash_func($key) if length($key) > $block_size;
+
+ my $k_ipad = $key ^ (chr(0x36) x $block_size);
+ my $k_opad = $key ^ (chr(0x5c) x $block_size);
+
+ &$hash_func($k_opad, &$hash_func($k_ipad, $data));
+}
+
+sub parse_keyvalue {
+ my $reply = shift;
+ my %ret;
+ $reply =~ s/\r//g;
+ foreach (split /\n/, $reply) {
+ next unless /^(\S+?):(.*)/;
+ $ret{$1} = $2;
+ }
+ return %ret;
+}
+
+sub ejs
+{
+ my $a = $_[0];
+ $a =~ s/[\"\'\\]/\\$&/g;
+ $a =~ s/\r?\n/\\n/gs;
+ $a =~ s/\r//;
+ return $a;
+}
+
+# Data::Dumper for JavaScript
+sub js_dumper {
+ my $obj = shift;
+ if (ref $obj eq "HASH") {
+ my $ret = "{";
+ foreach my $k (keys %$obj) {
+ $ret .= "$k: " . js_dumper($obj->{$k}) . ",";
+ }
+ chop $ret;
+ $ret .= "}";
+ return $ret;
+ } elsif (ref $obj eq "ARRAY") {
+ my $ret = "[" . join(", ", map { js_dumper($_) } @$obj) . "]";
+ return $ret;
+ } else {
+ return $obj if $obj =~ /^\d+$/;
+ return "\"" . ejs($obj) . "\"";
+ }
+}
+
+sub eurl
+{
+ my $a = $_[0];
+ $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
+ $a =~ tr/ /+/;
+ return $a;
+}
+
+sub push_url_arg {
+ my $uref = shift;
+ $$uref =~ s/[&?]$//;
+ my $got_qmark = ($$uref =~ /\?/);
+
+ while (@_) {
+ my $key = shift;
+ my $value = shift;
+ $$uref .= $got_qmark ? "&" : ($got_qmark = 1, "?");
+ $$uref .= eurl($key) . "=" . eurl($value);
+ }
+}
+
+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);
+ $mon++;
+ $year += 1900;
+
+ return sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
+ $year, $mon, $mday,
+ $hour, $min, $sec);
+}
+
+sub w3c_to_time {
+ my $hms = shift;
+ return 0 unless
+ $hms =~ /^(\d{4,4})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)Z$/;
+
+ my $time;
+ eval {
+ $time = Time::Local::timegm($6, $5, $4, $3, $2 - 1, $1);
+ };
+ return 0 if $@;
+ return $time;
+}
+
+sub bi2bytes {
+ my $bigint = shift;
+ die "Can't deal with negative numbers" if $bigint->is_negative;
+
+ my $bits = $bigint->as_bin;
+ die unless $bits =~ s/^0b//;
+
+ # prepend zeros to round to byte boundary, or to unset high bit
+ my $prepend = (8 - length($bits) % 8) || ($bits =~ /^1/ ? 8 : 0);
+ $bits = ("0" x $prepend) . $bits if $prepend;
+
+ return pack("B*", $bits);
+}
+
+sub bi2arg {
+ return b64(bi2bytes($_[0]));
+}
+
+sub b64 {
+ my $val = MIME::Base64::encode_base64($_[0]);
+ $val =~ s/\s+//g;
+ return $val;
+}
+
+sub d64 {
+ return MIME::Base64::decode_base64($_[0]);
+}
+
+sub bytes2bi {
+ return Math::BigInt->new("0b" . unpack("B*", $_[0]));
+}
+
+sub arg2bi {
+ return undef unless defined $_[0] and $_[0] ne "";
+ # don't acccept base-64 encoded numbers over 700 bytes. which means
+ # those over 4200 bits.
+ return Math::BigInt->new("0") if length($_[0]) > 700;
+ return bytes2bi(MIME::Base64::decode_base64($_[0]));
+}
+
+
+1;
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/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;
+
+@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,@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 <n...@kokogiko.net>
+
+Martin Atkins <m...@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/00-use-indirectmessage.t b/t/00-use-indirectmessage.t
new file mode 100644
index 0000000..43411ed
--- /dev/null
+++ b/t/00-use-indirectmessage.t
@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 1;
+use Net::OpenID::IndirectMessage;
+
+ok(1);
+
+1;
diff --git a/t/01-use-urifetch.t b/t/01-use-urifetch.t
new file mode 100644
index 0000000..8d9c2c4
--- /dev/null
+++ b/t/01-use-urifetch.t
@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 1;
+use Net::OpenID::URIFetch;
+
+ok(1);
+
+1;
diff --git a/t/02-use-yadis.t b/t/02-use-yadis.t
new file mode 100644
index 0000000..79f653e
--- /dev/null
+++ b/t/02-use-yadis.t
@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 1;
+use Net::OpenID::Yadis;
+
+ok(1);
+
+1;
diff --git a/t/03-use-common.t b/t/03-use-common.t
new file mode 100644
index 0000000..ff18a3c
--- /dev/null
+++ b/t/03-use-common.t
@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 1;
+use Net::OpenID::Common;
+
+ok(1);
+
+1;
diff --git a/t/04-messages.t b/t/04-messages.t
new file mode 100644
index 0000000..b06bc1e
--- /dev/null
+++ b/t/04-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-common-perl.git
_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
