zlax/ljr
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

init

Browse Source
This commit is contained in:
ivan
2019-02-06 00:49:12 +03:00
commit 8dbb1bb605
4796 changed files with 506072 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

127
wcmtools/openid/perl/Net-OpenID-Consumer/ChangeLog Executable file
View File

@@ -0,0 +1,127 @@
0.12:
* required_root in constructor/method/validated_identity
* allow https identities
* version 1.1 of the protocol
* expand entities in link rel
* reject cached association validation if expiry is in past
0.11:
* document common error codes from claimed_identity, and
cleanup some error handling/codes
* support openid.mode=cancel
* respect replace_after and expiry. do clock compensation
between local clock and server.
* invalidate_handle support
0.10:
* handle openid.delegate properly (was losing state because I'd
put a URL parameter onto the wrong URL)
* copy all signed parameters into POST args in dumb mode,
not a static set (to be future-proof)
0.09:
* switch to DH/HMAC protocol, not DSA protocol
0.08:
* more openssl-binary temp file changes. on second failure (which
was previously missing a new method), it also propogates up the
error message now, instead of dying, to be more consistent with
the other DSA checkers, which never die
0.07:
* bugfix: use URI::Fetch 0.02, not "0.02" in quotes
* bugfix: don't set cache if no cache
0.06:
* wrap Crypt::OpenSSL::DSA verify in eval {} as it can croak
* use URI::Fetch, which does caching and proper HTTP behavior
* let user get/set cache, which is then propogated down to URI::Fetch
* optionally use new pure-perl version of Crypt::DSA which now
does ASN.1 serialization/deserialization in both signatures and
public keys. brings total options of DSA verify techniques up
to 3.
* tmpdir option (and smart auto-configuration) for people using
OpenSSL binaries to verify signatures.
* security fix when doing DSA checks with system openssl binary
(was previously parsing the wrong status)
* misc reported bugfixes
0.05:
* stupid push_url_arg bugfix
* doc fix in example code (no post_grant in check_url)
0.04:
* tons more docs: in both ClaimedIdentity and VerifiedIdentity
* Consumer now observes atom/rss/foaf/foafmaker at the same time
as openid.server, and passes it along to VerifiedIdentity,
where it's accessible, and VerifiedIdentity knows whether or
not those urls are under the trusted one or not, and makes them
differently available to callers
* bug fixes, doc fixes
* post_grant moved to user_setup_url, not check_url
* delayed_return added to check_url
0.03:
* setting args in constructor was broken
* renamed get_claimed_identity to just claimed_identity to be
consistent
* all methods now croak if called with too many arguments
* added ClaimedIdentity->identity_server to get just one,
as selected by plugin, instead of array of them all
0.02:
* POD docs for Net/OpenID/Consumer.pm
* accepts CGI, Apache, Apache::Request, and CODE arguments now for
GET argument retrievers, in addition to just HASH references
* openid.server auto-discovery only happens within first <head> tag
* if using Crypt::OpenSSL::DSA, now requires 0.12 due to bugs found
in 0.11.
* DSA verification using OpenSSL binary no longer spews "Verification OK"
to stdout
0.01:
* fetching of page (with configurable user agent object; I
recommend you use LWPx::ParanoidAgent, now available on CPAN)
and returning a "ClaimedIdentity" object of what the user claims
they are, but is not verified yet
* auto-discovery of openid servers
* hook to let you provide your subref to do openid server
selection, given multiple options
* generation of "check" URL to send user to to get redirect
* reading of response parameters, returning either a
user_setup_url or a VerifiedIdentity object (doing DSA
validation with either Crypt::OpenSSL::DSA or your openssl
binary)
* start of JSON responses for javascript UI

9
wcmtools/openid/perl/Net-OpenID-Consumer/MANIFEST Executable file
View File

@@ -0,0 +1,9 @@
Makefile.PL
ChangeLog
MANIFEST
lib/Net/OpenID/Consumer.pm
lib/Net/OpenID/VerifiedIdentity.pm
lib/Net/OpenID/ClaimedIdentity.pm
lib/Net/OpenID/Association.pm
t/00-use.t
META.yml Module meta-data (added by MakeMaker)

17
wcmtools/openid/perl/Net-OpenID-Consumer/Makefile.PL Executable file
View File

@@ -0,0 +1,17 @@
use ExtUtils::MakeMaker;
WriteMakefile( 'NAME' => 'Net::OpenID::Consumer',
'VERSION_FROM' => 'lib/Net/OpenID/Consumer.pm',
'PREREQ_PM' => {
'LWP::UserAgent' => 0,
'HTTP::Request' => 0,
'MIME::Base64' => 0,
'Digest::SHA1' => 0,
'URI' => 0,
'Time::Local' => 0,
'URI::Fetch' => 0.02,
'Crypt::DH' => 0.05,
},
($] >= 5.005 ?
(ABSTRACT_FROM => 'lib/Net/OpenID/Consumer.pm',
AUTHOR => 'Brad Fitzpatrick <brad@danga.com>') : ()),
);

231
wcmtools/openid/perl/Net-OpenID-Consumer/lib/Net/OpenID/Association.pm Executable file
View File

@@ -0,0 +1,231 @@
use strict;
use Carp ();
############################################################################
package Net::OpenID::Association;
use fields (
'server', # author-identity identity server endpoint
'secret', # the secret for this association
'handle', # the 255-character-max ASCII printable handle (33-126)
'expiry', # unixtime, adjusted, of when this association expires
'type', # association type
);
use Storable ();
use Digest::SHA1 qw(sha1);
sub new {
my Net::OpenID::Association $self = shift;
$self = fields::new( $self ) unless ref $self;
my %opts = @_;
for my $f (qw( server secret handle expiry type )) {
$self->{$f} = delete $opts{$f};
}
Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
return $self;
}
sub handle {
my $self = shift;
die if @_;
$self->{'handle'};
}
sub secret {
my $self = shift;
die if @_;
$self->{'secret'};
}
sub server {
my Net::OpenID::Association $self = shift;
Carp::croak("Too many parameters") if @_;
return $self->{server};
}
sub expired {
my Net::OpenID::Association $self = shift;
return time() > $self->{'expiry'};
}
sub usable {
my Net::OpenID::Association $self = shift;
return 0 unless $self->{'handle'} =~ /^[\x21-\x7e]{1,255}$/;
return 0 unless $self->{'expiry'} =~ /^\d+$/;
return 0 unless $self->{'secret'};
return 0 if $self->expired;
return 1;
}
# return a handle for an identity server, or undef if
# no local storage/cache is available, in which case the caller
# 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) = @_;
# closure to return undef (dumb consumer mode) and log why
my $dumb = sub {
$csr->_debug("server_assoc: dumb mode: $_[0]");
return undef;
};
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);
if ($assoc && $assoc->usable) {
$csr->_debug("Found association from cache (handle=$handle)");
return $assoc;
}
}
# make a new association
my $dh = _default_dh();
my %post = (
"openid.mode" => "associate",
"openid.assoc_type" => "HMAC-SHA1",
"openid.session_type" => "DH-SHA1",
"openid.dh_consumer_public" => OpenID::util::bi2arg($dh->pub_key),
);
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));
$csr->_debug("Associate mode request: " . $req->content);
my $ua = $csr->ua;
my $res = $ua->request($req);
# uh, some failure, let's go into dumb mode?
return $dumb->("http_failure_no_associate") unless $res && $res->is_success;
my $recv_time = time();
my $content = $res->content;
my %args = OpenID::util::parse_keyvalue($content);
$csr->_debug("Response to associate mode: [$content] parsed = " . join(",", %args));
return $dumb->("unknown_assoc_type") unless $args{'assoc_type'} eq "HMAC-SHA1";
my $stype = $args{'session_type'};
return $dumb->("unknown_session_type") if $stype && $stype ne "DH-SHA1";
# protocol version 1.1
my $expires_in = $args{'expires_in'};
# protocol version 1.0 (DEPRECATED)
if (! $expires_in) {
if (my $issued = OpenID::util::w3c_to_time($args{'issued'})) {
my $expiry = OpenID::util::w3c_to_time($args{'expiry'});
my $replace_after = OpenID::util::w3c_to_time($args{'replace_after'});
# seconds ahead (positive) or behind (negative) the server is
$expires_in = ($replace_after || $expiry) - $issued;
}
}
# between 1 second and 2 years
return $dumb->("bogus_expires_in") unless $expires_in > 0 && $expires_in < 63072000;
my $ahandle = $args{'assoc_handle'};
my $secret;
if ($stype ne "DH-SHA1") {
$secret = OpenID::util::d64($args{'mac_key'});
} else {
my $server_pub = OpenID::util::arg2bi($args{'dh_server_public'});
my $dh_sec = $dh->compute_secret($server_pub);
$secret = OpenID::util::d64($args{'enc_mac_key'}) ^ sha1(OpenID::util::bi2bytes($dh_sec));
}
return $dumb->("secret_not_20_bytes") unless length($secret) == 20;
my %assoc = (
handle => $ahandle,
server => $server,
secret => $secret,
type => $args{'assoc_type'},
expiry => $recv_time + $expires_in,
);
my $assoc = Net::OpenID::Association->new( %assoc );
return $dumb->("assoc_undef") unless $assoc;
$cache->set("hassoc:$server:$ahandle", Storable::freeze(\%assoc));
$cache->set("shandle:$server", $ahandle);
return $assoc;
}
# returns association, or undef if it can't be found
sub handle_assoc {
my ($csr, $server, $handle) = @_;
# closure to return undef (dumb consumer mode) and log why
my $dumb = sub {
$csr->_debug("handle_assoc: dumb mode: $_[0]");
return undef;
};
return $dumb->("no_handle") unless $handle;
my $cache = $csr->cache;
return $dumb->("no_cache") unless $cache;
my $frozen = $cache->get("hassoc:$server:$handle");
return $dumb->("not_in_cache") unless $frozen;
my $param = eval { Storable::thaw($frozen) };
return $dumb->("not_a_hashref") unless ref $param eq "HASH";
return Net::OpenID::Association->new( %$param );
}
sub invalidate_handle {
my ($csr, $server, $handle) = @_;
my $cache = $csr->cache
or return;
$cache->set("hassoc:$server:$handle", "");
}
sub _default_dh {
my $dh = Crypt::DH->new;
$dh->p("155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443");
$dh->g("2");
$dh->generate_keys;
return $dh;
}
1;
__END__
=head1 NAME
Net::OpenID::Association - a relationship with an identity server
=head1 DESCRIPTION
Internal class.
=head1 COPYRIGHT, WARRANTY, AUTHOR
See L<Net::OpenID::Consumer> for author, copyrignt and licensing information.
=head1 SEE ALSO
L<Net::OpenID::Consumer>
L<Net::OpenID::VerifiedIdentity>
L<Net::OpenID::Server>
Website: L<http://www.danga.com/openid/>

207
wcmtools/openid/perl/Net-OpenID-Consumer/lib/Net/OpenID/ClaimedIdentity.pm Executable file
View File

@@ -0,0 +1,207 @@
use strict;
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
);
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 )) {
$self->{$f} = delete $opts{$f};
}
# lowercase the scheme and hostname
$self->{'identity'} =~ s!^(https?://.+?)(/(?:.*))?$!lc($1) . $2!ie;
Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
return $self;
}
sub claimed_url {
my Net::OpenID::ClaimedIdentity $self = shift;
Carp::croak("Too many parameters") if @_;
return $self->{'identity'};
}
sub identity_server {
my Net::OpenID::ClaimedIdentity $self = shift;
Carp::croak("Too many parameters") if @_;
return $self->{server};
}
sub check_url {
my Net::OpenID::ClaimedIdentity $self = shift;
my (%opts) = @_;
my $return_to = delete $opts{'return_to'};
my $trust_root = delete $opts{'trust_root'};
my $delayed_ret = delete $opts{'delayed_return'};
Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
Carp::croak("Invalid/missing return_to") unless $return_to =~ m!^https?://!;
my $csr = $self->{consumer};
my $ident_server = $self->{server} or
Carp::croak("No identity server");
# get an assoc (or undef for dumb mode)
my $assoc = Net::OpenID::Association::server_assoc($csr, $ident_server);
my $identity_arg = $self->{'delegate'} || $self->{'identity'};
# make a note back to ourselves that we're using a delegate
if ($self->{'delegate'}) {
OpenID::util::push_url_arg(\$return_to,
"oic.identity", $self->{identity});
}
# add a HMAC-signed time so we can verify the return_to URL wasn't spoofed
my $sig_time = time();
my $c_secret = $csr->_get_consumer_secret($sig_time);
my $sig = substr(OpenID::util::hmac_sha1_hex($sig_time, $c_secret), 0, 20);
OpenID::util::push_url_arg(\$return_to,
"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) : ()),
($assoc ?
("openid.assoc_handle", $assoc->handle) : ()),
);
$self->{consumer}->_debug("check_url for (del=$self->{delegate}, id=$self->{identity}) = $curl");
return $curl;
}
1;
__END__
=head1 NAME
Net::OpenID::ClaimedIdentity - a not-yet-verified OpenID identity
=head1 SYNOPSIS
use Net::OpenID::Consumer;
my $csr = Net::OpenID::Consumer->new;
....
my $cident = $csr->claimed_identity("bradfitz.com")
or die $csr->err;
if ($AJAX_mode) {
my $url = $cident->claimed_url;
my $openid_server = $cident->identity_server;
# ... return JSON with those to user agent (whose request was
# XMLHttpRequest, probably)
}
if ($CLASSIC_mode) {
my $check_url = $cident->check_url(
delayed_return => 1,
return_to => "http://example.com/get-identity.app",
trust_root => "http://*.example.com/",
);
WebApp::redirect($check_url);
}
=head1 DESCRIPTION
After L<Net::OpenID::Consumer> crawls a user's declared identity URL
and finds openid.server link tags in the HTML head, you get this
object. It represents an identity that can be verified with OpenID
(the link tags are present), but hasn't been actually verified yet.
=head1 METHODS
=over 4
=item $url = $cident->B<claimed_url>
The URL, now canonicalized, that the user claims to own. You can't
know whether or not they do own it yet until you send them off to the
check_url, though.
=item $id_server = $cident->B<identity_server>
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<check_url>( %opts )
Makes the URL that you have to somehow send the user to in order to
validate their identity. The options to put in %opts are:
=over
=item C<return_to>
The URL that the identity server should redirect the user with either
a verified identity signature -or- a user_setup_url (if the assertion
couldn't be made). This URL may contain query parameters, and the
identity server must preserve them.
=item C<trust_root>
The URL that you want the user to actually see and declare trust for.
Your C<return_to> URL must be at or below your trust_root. Sending
the trust_root is optional, and defaults to your C<return_to> value,
but it's highly recommended (and prettier for users) to see a simple
trust_root. Note that the trust root may contain a wildcard at the
beginning of the host, like C<http://*.example.com/>
=item C<delayed_return>
If set to a true value, the check_url returned will indicate to the
user's identity server that it has permission to control the user's
user-agent for awhile, giving them real pages (not just redirects) and
lets them bounce around the identity server site for awhile until
the requested assertion can be made, and they can finally be redirected
back to your return_to URL above.
The default value, false, means that the identity server will
immediately return to your return_to URL with either a "yes" or "no"
answer. In the "no" case, you'll instead have control of what to do,
and you'll be sent the identity server's user_setup_url where you'll
have to somehow send the user (be it link, redirect, or pop-up
window).
When writing a dynamic "AJAX"-style application, you can't use
delayed_return because the remote site can't usefully take control of
a 1x1 pixel hidden IFRAME, so you'll need to get the user_setup_url
and present it to the user somehow.
=back
=back
=head1 COPYRIGHT, WARRANTY, AUTHOR
See L<Net::OpenID::Consumer> for author, copyrignt and licensing information.
=head1 SEE ALSO
L<Net::OpenID::Consumer>
L<Net::OpenID::VerifiedIdentity>
L<Net::OpenID::Server>
Website: L<http://www.danga.com/openid/>

947
wcmtools/openid/perl/Net-OpenID-Consumer/lib/Net/OpenID/Consumer.pm Executable file
View File

@@ -0,0 +1,947 @@
# LICENSE: You're free to distribute this under the same terms as Perl itself.
use strict;
use Carp ();
use LWP::UserAgent;
use URI::Fetch 0.02;
############################################################################
package Net::OpenID::Consumer;
use vars qw($VERSION);
$VERSION = "0.12";
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
);
use Net::OpenID::ClaimedIdentity;
use Net::OpenID::VerifiedIdentity;
use Net::OpenID::Association;
use MIME::Base64 ();
use Digest::SHA1 ();
use Crypt::DH 0.05;
use Time::Local;
use HTTP::Request;
sub new {
my Net::OpenID::Consumer $self = shift;
$self = fields::new( $self ) unless ref $self;
my %opts = @_;
$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->{debug} = delete $opts{debug};
Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
return $self;
}
sub cache { &_getset; }
sub consumer_secret { &_getset; }
sub required_root { &_getset; }
sub _getset {
my Net::OpenID::Consumer $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 Net::OpenID::Consumer $self = shift;
return unless $self->{debug};
if (ref $self->{debug} eq "CODE") {
$self->{debug}->($_[0]);
} else {
print STDERR "[DEBUG Net::OpenID::Consumer] $_[0]\n";
}
}
# given something that can have GET arguments, returns a subref to get them:
# Apache
# Apache::Request
# CGI
# HASH of get args
# CODE returning get arg, given key
# ...
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 (ref $what eq "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)");
}
if ($getter) {
$self->{args} = $getter;
}
}
$self->{args};
}
sub ua {
my Net::OpenID::Consumer $self = shift;
$self->{ua} = shift if @_;
Carp::croak("Too many parameters") if @_;
# make default one on first access
unless ($self->{ua}) {
my $ua = $self->{ua} = LWP::UserAgent->new;
$ua->timeout(10);
}
$self->{ua};
}
sub _fail {
my Net::OpenID::Consumer $self = shift;
my ($code, $text) = @_;
$text ||= {
'no_identity_server' => "The provided URL doesn't declare its OpenID identity server.",
'empty_url' => "No URL entered.",
'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.",
}->{$code};
$self->{last_errcode} = $code;
$self->{last_errtext} = $text;
$self->_debug("fail($code) $text");
wantarray ? () : undef;
}
sub json_err {
my Net::OpenID::Consumer $self = shift;
return OpenID::util::js_dumper({
err_code => $self->{last_errcode},
err_text => $self->{last_errtext},
});
}
sub err {
my Net::OpenID::Consumer $self = shift;
$self->{last_errcode} . ": " . $self->{last_errtext};
}
sub errcode {
my Net::OpenID::Consumer $self = shift;
$self->{last_errcode};
}
sub errtext {
my Net::OpenID::Consumer $self = shift;
$self->{last_errtext};
}
sub _get_url_contents {
my Net::OpenID::Consumer $self = shift;
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);
# 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;
return $ures->content;
}
sub _find_semantic_info {
my Net::OpenID::Consumer $self = shift;
my $url = shift;
my $final_url_ref = shift;
my $trim_hook = sub {
my $htmlref = shift;
# trim everything past the body. this is in case the user doesn't
# have a head document and somebody was able to inject their own
# head. -- brad choate
$$htmlref =~ s/<body\b.*//is;
};
my $doc = $self->_get_url_contents($url, $final_url_ref, $trim_hook) or
return;
# find <head> content of document (notably: the first head, if an attacker
# has added others somehow)
return $self->_fail("no_head_tag", "Couldn't find OpenID servers due to no head tag")
unless $doc =~ m!<head[^>]*>(.*?)</head>!is;
my $head = $1;
my $ret = {
'openid.server' => undef,
'openid.delegate' => undef,
'foaf' => undef,
'foaf.maker' => undef,
'rss' => undef,
'atom' => undef,
};
# analyze link/meta tags
while ($head =~ m!<(link|meta)\b([^>]+)>!g) {
my ($type, $val) = ($1, $2);
my $temp;
# OpenID servers / delegated identities
# <link rel="openid.server" href="http://www.livejournal.com/misc/openid.bml" />
if ($type eq "link" &&
$val =~ /\brel=.openid\.(server|delegate)./i && ($temp = $1) &&
$val =~ m!\bhref=[\"\']([^\"\']+)[\"\']!i) {
$ret->{"openid.$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" &&
$val =~ m!title=.foaf.!i &&
$val =~ m!rel=.meta.!i &&
$val =~ m!type=.application/rdf\+xml.!i &&
$val =~ m!href=[\"\']([^\"\']+)[\"\']!i) {
$ret->{"foaf"} = $1;
next;
}
# FOAF maker info
# <meta name="foaf:maker" content="foaf:mbox_sha1sum '4caa1d6f6203d21705a00a7aca86203e82a9cf7a'" />
if ($type eq "meta" &&
$val =~ m!name=.foaf:maker.!i &&
$val =~ m!content=([\'\"])(.*?)\1!i) {
$ret->{"foaf.maker"} = $2;
next;
}
if ($type eq "meta" &&
$val =~ m!name=.foaf:maker.!i &&
$val =~ m!content=([\'\"])(.*?)\1!i) {
$ret->{"foaf.maker"} = $2;
next;
}
# RSS
# <link rel="alternate" type="application/rss+xml" title="RSS" href="http://www.livejournal.com/~brad/data/rss" />
if ($type eq "link" &&
$val =~ m!rel=.alternate.!i &&
$val =~ m!type=.application/rss\+xml.!i &&
$val =~ m!href=[\"\']([^\"\']+)[\"\']!i) {
$ret->{"rss"} = $1;
next;
}
# Atom
# <link rel="alternate" type="application/atom+xml" title="Atom" href="http://www.livejournal.com/~brad/data/rss" />
if ($type eq "link" &&
$val =~ m!rel=.alternate.!i &&
$val =~ m!type=.application/atom\+xml.!i &&
$val =~ m!href=[\"\']([^\"\']+)[\"\']!i) {
$ret->{"atom"} = $1;
next;
}
}
# map the 4 entities that the spec asks for
my $emap = {
'lt' => '<',
'gt' => '>',
'quot' => '"',
'amp' => '&',
};
foreach my $k (keys %$ret) {
next unless $ret->{$k};
$ret->{$k} =~ s/&(\w+);/$emap->{$1} || ""/eg;
}
$self->_debug("semantic info ($url) = " . join(", ", %$ret));
return $ret;
}
sub _find_openid_server {
my Net::OpenID::Consumer $self = shift;
my $url = shift;
my $final_url_ref = shift;
my $sem_info = $self->_find_semantic_info($url, $final_url_ref) or
return;
return $self->_fail("no_identity_server") unless $sem_info->{"openid.server"};
$sem_info->{"openid.server"};
}
# returns Net::OpenID::ClaimedIdentity
sub claimed_identity {
my Net::OpenID::Consumer $self = shift;
my $url = shift;
Carp::croak("Too many parameters") if @_;
# 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!^http://.+/!i;
my $final_url;
my $sem_info = $self->_find_semantic_info($url, \$final_url) or
return;
my $id_server = $sem_info->{"openid.server"} or
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";
}
sub user_setup_url {
my Net::OpenID::Consumer $self = shift;
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");
OpenID::util::push_url_arg(\$setup_url, "openid.post_grant", $post_grant)
if $setup_url && $post_grant;
return $setup_url;
}
sub verified_identity {
my Net::OpenID::Consumer $self = shift;
my %opts = @_;
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";
# 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 $sig64 = $self->args("openid.sig") or return $self->_fail("no_sig");
my $returnto = $self->args("openid.return_to") or return $self->_fail("no_return_to");
my $signed = $self->args("openid.signed");
my $real_ident = $self->args("oic.identity") || $a_ident;
# check that returnto is for the right host
return $self->_fail("bogus_return_to") if $rr && $returnto !~ /^\Q$rr\E/;
# check age/signature of return_to
my $now = time();
{
my ($sig_time, $sig) = split(/\-/, $self->args("oic.time") || "");
# complain if more than an hour since we sent them off
return $self->_fail("time_expired") if $sig_time < $now - 3600;
# also complain if the signature is from the future by more than 30 seconds,
# which compensates for potential clock drift between nodes in a web farm.
return $self->_fail("time_in_future") if $sig_time - 30 > $now;
# and check that the time isn't faked
my $c_secret = $self->_get_consumer_secret($sig_time);
my $good_sig = substr(OpenID::util::hmac_sha1_hex($sig_time, $c_secret), 0, 20);
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 $server = $sem_info->{"openid.server"} or
return $self->_fail("no_identity_server");
# 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;
}
my $assoc_handle = $self->args("openid.assoc_handle");
$self->_debug("verified_identity: assoc_handle: $assoc_handle");
my $assoc = Net::OpenID::Association::handle_assoc($self, $server, $assoc_handle);
if ($assoc) {
$self->_debug("verified_identity: verifying with found association");
return $self->_fail("expired_association")
if $assoc->expired;
# verify the token
my $token = "";
foreach my $p (split(/,/, $signed)) {
$token .= "$p:" . $self->args("openid.$p") . "\n";
}
my $good_sig = OpenID::util::b64(OpenID::util::hmac_sha1($token, $assoc->secret));
return $self->_fail("signature_mismatch") unless $sig64 eq $good_sig;
} else {
$self->_debug("verified_identity: verifying using HTTP (dumb mode)");
# didn't find an association. have to do dumb consumer mode
# and check it with a POST
my %post = (
"openid.mode" => "check_authentication",
"openid.assoc_handle" => $assoc_handle,
"openid.signed" => $signed,
"openid.sig" => $sig64,
);
# and copy in all signed parameters that we don't already have into %post
foreach my $param (split(/,/, $signed)) {
next unless $param =~ /^\w+$/;
next if $post{"openid.$param"};
$post{"openid.$param"} = $self->args("openid.$param");
}
# 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")) {
$post{"openid.invalidate_handle"} = $ih;
}
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));
my $ua = $self->ua;
my $res = $ua->request($req);
# uh, some failure, let's go into dumb mode?
return $self->_fail("naive_verify_failed_network") unless $res && $res->is_success;
my $content = $res->content;
my %args = OpenID::util::parse_keyvalue($content);
# delete the handle from our cache
if (my $ih = $args{'invalidate_handle'}) {
Net::OpenID::Association::invalidate_handle($self, $server, $ih);
}
return $self->_fail("naive_verify_failed_return") unless
$args{'is_valid'} eq "true" || # protocol 1.1
$args{'lifetime'} > 0; # DEPRECATED protocol 1.0
}
$self->_debug("verified identity! = $real_ident");
# 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,
);
}
sub supports_consumer_secret { 1; }
sub _get_consumer_secret {
my Net::OpenID::Consumer $self = shift;
my $time = shift;
my $ss;
if (ref $self->{consumer_secret} eq "CODE") {
$ss = $self->{consumer_secret};
} elsif ($self->{consumer_secret}) {
$ss = sub { return $self->{consumer_secret}; };
} else {
Carp::croak("You haven't defined a consumer_secret value or subref.\n");
}
my $sec = $ss->($time);
Carp::croak("Consumer secret too long") if length($sec) > 255;
return $sec;
}
package OpenID::util;
# 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 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]));
}
__END__
=head1 NAME
Net::OpenID::Consumer - library for consumers of OpenID identities
=head1 SYNOPSIS
use Net::OpenID::Consumer;
my $csr = Net::OpenID::Consumer->new(
ua => LWPx::ParanoidAgent->new,
cache => Some::Cache->new,
args => $cgi,
consumer_secret => ...,
required_root => "http://site.example.com/",
);
# a user entered, say, "bradfitz.com" as their identity. The first
# step is to fetch that page, parse it, and get a
# Net::OpenID::ClaimedIdentity object:
my $claimed_identity = $csr->claimed_identity("bradfitz.com");
# now your app has to send them at their identity server's endpoint
# to get redirected to either a positive assertion that they own
# that identity, or where they need to go to login/setup trust/etc.
my $check_url = $claimed_identity->check_url(
return_to => "http://example.com/openid-check.app?yourarg=val",
trust_root => "http://example.com/",
);
# so you send the user off there, and then they come back to
# openid-check.app, then you see what the identity server said;
if (my $setup_url = $csr->user_setup_url) {
# redirect/link/popup user to $setup_url
} elsif ($csr->user_cancel) {
# restore web app state to prior to check_url
} elsif (my $vident = $csr->verified_identity) {
my $verified_url = $vident->url;
print "You are $verified_url !";
} else {
die "Error validating identity: " . $csr->err;
}
=head1 DESCRIPTION
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/
=head1 CONSTRUCTOR
=over 4
=item C<new>
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.
=back
=head1 METHODS
=over 4
=item $csr->B<ua>($user_agent)
=item $csr->B<ua>
Getter/setter for the LWP::UserAgent (or subclass) instance which will
be used when web donwloads are needed. It's highly recommended that
you use LWPx::ParanoidAgent, or at least read its documentation so
you're aware of why you should care.
=item $csr->B<cache>($cache)
=item $csr->B<cache>
Getter/setter for the optional (but recommended!) cache instance you
want to use for storing fetched parts of pages. (identity server
public keys, and the E<lt>headE<gt> section of user's HTML pages)
The $cache object can be anything that has a -E<gt>get($key) and
-E<gt>set($key,$value) methods. See L<URI::Fetch> for more
information. This cache object is just passed to L<URI::Fetch>
directly.
=item $nos->B<consumer_secret>($scalar)
=item $nos->B<consumer_secret>($code)
=item $code = $nos->B<consumer_secret>; ($secret) = $code->($time);
The consumer secret is used to generate self-signed nonces for the
return_to URL, to prevent spoofing.
In the simplest (and least secure) form, you configure a static secret
value with a scalar. If you use this method and change the scalar
value, any outstanding requests from the last 30 seconds or so will fail.
The more robust (but more complicated) form is to supply a subref that
returns a secret based on the provided I<$time>, a unix timestamp.
And if one doesn't exist for that time, create, store and return it
(with appropriate locking so you never return different secrets for
the same time.)
Your secret may not exceed 255 characters.
=item $csr->B<args>($ref)
=item $csr->B<args>($param)
=item $csr->B<args>
Can be used in 1 of 3 ways:
1. Setting the way which the Consumer instances obtains GET parameters:
$csr->args( $reference )
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)
2. Get a paramater:
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.
3. Get the getter:
my $code = $csr->args;
Without arguments, returns a subref that returns the value given a
parameter name.
=item $nos->B<required_root>($url_prefix)
=item $url_prefix = $nos->B<required_root>
If provided, this is the required string that all return_to URLs must
start with. If it doesn't match, it'll be considered invalid (spoofed
from another site)
=item $csr->B<claimed_identity>($url)
Given a user-entered $url (which could be missing http://, or have
extra whitespace, etc), returns either a Net::OpenID::ClaimedIdentity
object, or undef on failure.
Note that this identity is NOT verified yet. It's only who the user
claims they are, but they could be lying.
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 no_identity_server
=item empty_url
=item bogus_url
=item no_head_tag
=item url_fetch_err
=back
=item $csr->B<user_setup_url>( [ %opts ] )
Returns the URL the user must return to in order to login, setup trust,
or do whatever the identity server needs them to do in order to make
the identity assertion which they previously initiated by entering
their claimed identity URL. Returns undef if this setup URL isn't
required, in which case you should ask for the verified_identity.
The base URL this this function returns can be modified by using the
following options in %opts:
=over
=item C<post_grant>
What you're asking the identity server to do with the user after they
setup trust. Can be either C<return> or C<close> to return the user
back to the return_to URL, or close the browser window with
JavaScript. If you don't specify, the behavior is undefined (probably
the user gets a dead-end page with a link back to the return_to URL).
In any case, the identity server can do whatever it wants, so don't
depend on this.
=back
=item $csr->B<user_cancel>
Returns true if the user declined to share their identity, false
otherwise. (This function is literally one line: returns true if
"openid.mode" eq "cancel")
It's then your job to restore your app to where it was prior to
redirecting them off to the user_setup_url, using the other query
parameters that you'd sent along in your return_to URL.
=item $csr->B<verified_identity>( [ %opts ] )
Returns a Net::OpenID::VerifiedIdentity object, or undef.
Verification includes double-checking the reported identity URL
declares the identity server, verifying the signature, etc.
The options in %opts may contain:
=over
=item C<required_root>
Sets the required_root just for this request. Values returns to its
previous value afterwards.
=back
=item $csr->B<err>
Returns the last error, in form "errcode: errtext"
=item $csr->B<errcode>
Returns the last error code.
=item $csr->B<errtext>
Returns the last error text.
=item $csr->B<json_err>
Returns the last error code/text in JSON format.
=back
=head1 COPYRIGHT
This module is Copyright (c) 2005 Brad Fitzpatrick.
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 WARRANTY
This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
=head1 SEE ALSO
OpenID website: http://www.danga.com/openid/
L<Net::OpenID::ClaimedIdentity> -- part of this module
L<Net::OpenID::VerifiedIdentity> -- part of this module
L<Net::OpenID::Server> -- another module, for acting like an OpenID server
=head1 AUTHORS
Brad Fitzpatrick <brad@danga.com>

268
wcmtools/openid/perl/Net-OpenID-Consumer/lib/Net/OpenID/VerifiedIdentity.pm Executable file
View File

@@ -0,0 +1,268 @@
use strict;
use Carp ();
############################################################################
package Net::OpenID::VerifiedIdentity;
use fields (
'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
'consumer', # The Net::OpenID::Consumer module which created us
);
use URI;
sub new {
my Net::OpenID::VerifiedIdentity $self = shift;
$self = fields::new( $self ) unless ref $self;
my %opts = @_;
$self->{'consumer'} = delete $opts{'consumer'};
if ($self->{'identity'} = delete $opts{'identity'}) {
unless ($self->{'id_uri'} = URI->new($self->{identity})) {
return $self->{'consumer'}->_fail("invalid_uri");
}
}
for my $par (qw(foaf foafmaker rss atom)) {
$self->$par(delete $opts{$par});
}
Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
return $self;
}
sub url {
my Net::OpenID::VerifiedIdentity $self = shift;
return $self->{'identity'};
}
sub display {
my Net::OpenID::VerifiedIdentity $self = shift;
return DisplayOfURL($self->{'identity'});
}
sub foafmaker { &_getset; }
sub foaf { &_getset_semurl; }
sub rss { &_getset_semurl; }
sub atom { &_getset_semurl; }
sub declared_foaf { &_dec_semurl; }
sub declared_rss { &_dec_semurl; }
sub declared_atom { &_dec_semurl; }
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 _getset_semurl {
my $self = shift;
my $param = (caller(1))[3];
$param =~ s/.+:://;
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;
}
my $uri = $self->{$param};
return $uri && _url_is_under($self->{'id_uri'}, $uri) ? $uri->as_string : undef;
}
sub _dec_semurl {
my $self = shift;
my $param = (caller(1))[3];
$param =~ s/.+::declared_//;
my $uri = $self->{$param};
return $uri ? $uri->as_string : undef;
}
sub DisplayOfURL {
my $url = shift;
my $dev_mode = shift;
return $url unless
$url =~ m!^https?://([^/]+)(/.*)?$!;
my ($host, $path) = ($1, $2);
$host = lc($host);
if ($dev_mode) {
$host =~ s!^dev\.!!;
$host =~ s!:\d+!!;
}
$host =~ s/:.+//;
$host =~ s/^www\.//i;
if (length($path) <= 1) {
return $host;
}
# obvious username
if ($path =~ m!^/~([^/]+)/?$! ||
$path =~ m!^/(?:users?|members?)/([^/]+)/?$!) {
return "$1 [$host]";
}
if ($host =~ m!^profile\.(.+)!i) {
my $site = $1;
if ($path =~ m!^/([^/]+)/?$!) {
return "$1 [$site]";
}
}
return $url;
}
# FIXME: duplicated in Net::OpenID::Server
sub _url_is_under {
my ($root, $test, $err_ref) = @_;
my $err = sub {
$$err_ref = shift if $err_ref;
return undef;
};
my $ru = ref $root ? $root : URI->new($root);
return $err->("invalid root scheme") unless $ru->scheme =~ /^https?$/;
my $tu = ref $test ? $test : URI->new($test);
return $err->("invalid test scheme") unless $tu->scheme =~ /^https?$/;
return $err->("schemes don't match") unless $ru->scheme eq $tu->scheme;
return $err->("ports don't match") unless $ru->port == $tu->port;
# check hostnames
my $ru_host = $ru->host;
my $tu_host = $tu->host;
my $wildcard_host = 0;
if ($ru_host =~ s!^\*\.!!) {
$wildcard_host = 1;
}
unless ($ru_host eq $tu_host) {
if ($wildcard_host) {
return $err->("host names don't match") unless
$tu_host =~ /\.\Q$ru_host\E$/;
} else {
return $err->("host names don't match");
}
}
# check paths
my $ru_path = $ru->path || "/";
my $tu_path = $tu->path || "/";
$ru_path .= "/" unless $ru_path =~ m!/$!;
$tu_path .= "/" unless $tu_path =~ m!/$!;
return $err->("path not a subpath") unless $tu_path =~ m!^\Q$ru_path\E!;
return 1;
}
1;
__END__
=head1 NAME
Net::OpenID::VerifiedIdentity - object representing a verified OpenID identity
=head1 SYNOPSIS
use Net::OpenID::Consumer;
my $csr = Net::OpenID::Consumer->new;
....
my $vident = $csr->verified_identity
or die $csr->err;
my $url = $vident->url;
=head1 DESCRIPTION
After L<Net::OpenID::Consumer> verifies a user's identity and does the
signature checks, it gives you this Net::OpenID::VerifiedIdentity
object, from which you can learn more about the user.
=head1 METHODS
=over 4
=item $vident->B<url>
Returns the URL (as a scalar) that was verified. (Remember, an OpenID
is just a URL.)
=item $vident->B<display>
Returns the a short "display form" of the verified URL using a couple
brain-dead patterns. For instance, the identity
"http://www.foo.com/~bob/" will map to "bob [foo.com]" The www. prefix
is removed, as well as http, and a username is looked for, in either
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!
=item $vident->B<rss>
=item $vident->B<atom>
=item $vident->B<foaf>
=item $vident->B<declared_rss>
=item $vident->B<declared_atom>
=item $vident->B<declared_foaf>
Returns the absolute URLs (as scalars) of the user's RSS, Atom, and
FOAF XML documents that were also found in their HTML's E<lt>headE<gt>
section. The short versions will only return a URL if they're below
the root URL that was verified. If you want to get at the user's
declared rss/atom/foaf, even if it's on a different host or parent
directory, use the delcared_* versions, which don't have the additional
checks.
2005-05-24: A future module will take a Net::OpenID::VerifiedIdentity
object and create an OpenID profile object so you don't have to
manually parse all those documents to get profile information.
=item $vident->B<foafmaker>
Returns the value of the C<foaf:maker> meta tag, if declared.
=back
=head1 COPYRIGHT, WARRANTY, AUTHOR
See L<Net::OpenID::Consumer> for author, copyrignt and licensing information.
=head1 SEE ALSO
L<Net::OpenID::Consumer>
L<Net::OpenID::ClaimedIdentity>
L<Net::OpenID::Server>
Website: L<http://www.danga.com/openid/>

9
wcmtools/openid/perl/Net-OpenID-Consumer/t/00-use.t Executable file
View File

@@ -0,0 +1,9 @@
#!/usr/bin/perl
use strict;
use Test::More tests => 1;
use Net::OpenID::Consumer;
ok(1);
1;

60
wcmtools/openid/perl/Net-OpenID-Server/ChangeLog Executable file
View File

@@ -0,0 +1,60 @@
0.09:
* version 1.1 of the protocol, with 1.0 as a "compat" option
(where both 1.0 and 1.1 response keys are sent) compat is either
on, off, or unspecified, in which case it's on by default for
one month
0.08:
* security fix, as pointed out by meepbear: check_authentication
shouldn't honor signature verification requests using
assoc_handles that were given out in associate requests. that
means that we must be able to distinguish (internally) handles
that were given out to "dumb" consumbers (stateless) vs. ones we
gave out in associate requests.
for more information, see:
http://lists.danga.com/pipermail/yadis/2005-July/001144.html
0.07:
* openid.mode=cancel support
* invalidate_handle support
* fix a call to error_page that should've been _error_page
* _secret_of_handle now only takes an assoc_handle, not
also an assoc_type, as an assoc_handle should always
self-imply its type
0.06:
* make rand_chars public
* remove old DSA-based code
* test suite for new DH/HMAC-based code
0.05:
* start implementing the new DH + HMAC-SHA1 spec, instead
of being DSA-based. The DSA code is still working for now,
and it'll do either protocol, but it'll be removed in time.
0.04:
* add "signed_return" method and docs
* require Convert::PEM 0.07, which was always required,
but I forgot its version number before
* add "redirect_for_setup" option on handle_page and docs
0.03:
* stupid push_url_arg bugfix
* more tests
0.02:
* checkid_immediate vs checkid_setup mode (handle_page can return
$type of "setup")
0.01:
* initial release. test suite works. no example app yet.
* requires Crypt::DSA or Crypt::OpenSSL::DSA

7
wcmtools/openid/perl/Net-OpenID-Server/MANIFEST Executable file
View File

@@ -0,0 +1,7 @@
Makefile.PL
ChangeLog
MANIFEST
lib/Net/OpenID/Server.pm
t/00-use.t
t/01-newproto.t
META.yml Module meta-data (added by MakeMaker)

13
wcmtools/openid/perl/Net-OpenID-Server/Makefile.PL Executable file
View File

@@ -0,0 +1,13 @@
use ExtUtils::MakeMaker;
WriteMakefile( 'NAME' => 'Net::OpenID::Server',
'VERSION_FROM' => 'lib/Net/OpenID/Server.pm',
'PREREQ_PM' => {
'URI' => 0,
'MIME::Base64' => 0,
'Digest::SHA1' => 0,
'Crypt::DH' => 0.05,
},
($] >= 5.005 ?
(ABSTRACT_FROM => 'lib/Net/OpenID/Server.pm',
AUTHOR => 'Brad Fitzpatrick <brad@danga.com>') : ()),
);

1111
wcmtools/openid/perl/Net-OpenID-Server/lib/Net/OpenID/Server.pm Executable file
View File

File diff suppressed because it is too large Load Diff

130
wcmtools/openid/perl/Net-OpenID-Server/t/00-all.t Executable file
View File

@@ -0,0 +1,130 @@
#!/usr/bin/perl
use strict;
use Test::More 'no_plan';
use Data::Dumper;
use Net::OpenID::Server;
use Crypt::OpenSSL::DSA;
use Math::BigInt;
for my $num (1..1080) {
my $bi = Math::BigInt->new("$num");
my $bytes = Net::OpenID::Server::_bi2bytes($bi);
my $bi2 = Net::OpenID::Server::_bytes2bi($bytes);
is($bi,$bi2);
printf "$bi = $bi2\n";
}
exit 0;
my ($query_string, %get_vars, $ctype, $content);
my $parse = sub {
%get_vars = map { durl($_) } split(/[&=]/, $query_string);
};
my $pub_key_file = "test.openid_public.key";
my $priv_key_file = "test.openid_private.key";
my $nos = Net::OpenID::Server->new(
args => \%get_vars,
public_key => $pub_key_file,
private_key => $priv_key_file,
);
ok($nos);
# generate a key
my $dsa = Crypt::OpenSSL::DSA->generate_parameters( 512 );
$dsa->generate_key;
print "done.\n";
$dsa->write_pub_key($pub_key_file);
$dsa->write_priv_key($priv_key_file);
my $read_pub_key = sub {
open (F, $pub_key_file);
my $content = do { local $/; <F>; };
close F;
return $content;
};
my $read_priv_key = sub {
open (F, $priv_key_file);
my $content = do { local $/; <F>; };
close F;
return $content;
};
# see if we get our public key back
$query_string = "openid.mode=getpubkey";
$parse->();
$nos->private_key("BOGUS");
for (1..3) {
$nos->public_key($pub_key_file) if $_ == 1;
$nos->public_key($read_pub_key) if $_ == 2;
$nos->public_key($read_pub_key->()) if $_ == 3;
($ctype, $content) = $nos->handle_page;
ok($ctype eq "text/plain");
ok($content =~ /\-\-\-BEGIN/ && $content =~ /\-\-\-END/);
}
# see if we get a user_setup_url vs. signature
$query_string = "openid.is_identity=http://bradfitz.com/&openid.return_to=http://return.example.com/%3Ffoo%3Dbar";
$parse->();
$nos->get_user(sub { return "brad"; });
$nos->is_identity(sub {
my ($u, $url) = @_;
return $u eq "brad" && $url eq "http://bradfitz.com/";
});
# first an untrusted case:
$nos->is_trusted(sub { 0; });
$nos->setup_url("http://setup.example.com/?set1=set2");
($ctype, $content) = $nos->handle_page or die $nos->err;
ok($ctype eq "redirect");
ok($content =~ m!user_setup_url=http://setup\.example\.com!);
ok($content =~ m!return\.example\.com/\?foo=bar\&open!);
# now a trusted case, but with bogus private key:
$nos->is_trusted(sub { 1; });
$nos->private_key("BOGUS");
($ctype, $content) = $nos->handle_page;
ok(! $ctype);
$nos->private_key($priv_key_file);
($ctype, $content) = $nos->handle_page;
ok($ctype eq "redirect");
ok($content =~ m!return\.example\.com/\?foo=bar\&open!);
ok($content =~ m!\&openid\.sig=M!);
$nos->private_key($read_priv_key);
($ctype, $content) = $nos->handle_page;
ok($ctype eq "redirect");
ok($content =~ m!return\.example\.com/\?foo=bar\&open!);
ok($content =~ m!\&openid\.sig=M!);
# checking two types of failure cases
$nos->setup_url("http://setup.example.com/");
$nos->is_trusted(sub { 0; });
# immediate mode:
$query_string = "openid.mode=checkid_immediate&openid.is_identity=http://bradfitz.com/&openid.return_to=http://return.example.com/%3Ffoo%3Dbar";
$parse->();
($ctype, $content) = $nos->handle_page;
ok($ctype eq "redirect");
# setup mode:
$query_string = "openid.mode=checkid_setup&openid.is_identity=http://bradfitz.com/&openid.return_to=http://return.example.com/%3Ffoo%3Dbar";
$parse->();
($ctype, $content) = $nos->handle_page;
ok($ctype eq "setup");
ok($content->{return_to} eq "http://return.example.com/?foo=bar");
sub durl
{
my ($a) = @_;
$a =~ tr/+/ /;
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
return $a;
}

318
wcmtools/openid/perl/Net-OpenID-Server/t/01-newproto.t Executable file
View File

@@ -0,0 +1,318 @@
#!/usr/bin/perl
use strict;
use Test::More 'no_plan';
use Data::Dumper;
use Net::OpenID::Server;
use Crypt::DH;
use Digest::SHA1 qw(sha1 sha1_hex);
for (my $num=1; $num <= 2000; $num += 20) {
my $bi = Math::BigInt->new("$num");
my $bytes = Net::OpenID::Server::_bi2bytes($bi);
my $bi2 = Net::OpenID::Server::_bytes2bi($bytes);
is($bi,$bi2);
}
my ($query_string, %get, %post, $ctype, $content);
my $parse = sub {
%get = map { durl($_) } split(/[&=]/, $query_string);
};
my %res;
my $nos = Net::OpenID::Server->new(
get_args => \%get,
post_args => \%post,
server_secret => "o3kjn3nf9832hf32nfo32nfdo32nro32n29332",
setup_url => "http://server.com/setup.app",
);
ok($nos);
my ($secret, $ahandle);
assoc_clear();
login_success();
assoc_dh();
login_success();
login_im_fail();
login_setup_fail();
login_setup_fail2();
login_bogus_handle();
sub assoc_clear {
%get = ();
# regular associate
%post = (
"openid.mode" => "associate",
"openid.assoc_type" => "HMAC-SHA1",
);
($ctype, $content) = $nos->handle_page;
is($ctype, "text/plain");
%res = parse_reply($content);
ok($res{assoc_handle});
$ahandle = $res{'assoc_handle'};
ok($ahandle !~ /\bSTLS\./);
is($res{assoc_type}, "HMAC-SHA1");
ok(good_date($res{expiry}));
ok(good_date($res{issued}));
ok($res{mac_key});
$secret = $res{'mac_key'};
}
# DH associate
sub assoc_dh {
my $dh = Crypt::DH->new;
$dh->p("155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443");
$dh->g("2");
$dh->generate_keys;
%get = ();
%post = (
"openid.mode" => "associate",
"openid.assoc_type" => "HMAC-SHA1",
"openid.session_type" => "DH-SHA1",
"openid.dh_consumer_public" => _bi2arg($dh->pub_key),
);
($ctype, $content) = $nos->handle_page;
is($ctype, "text/plain");
%res = parse_reply($content);
ok($res{assoc_handle});
ok($res{dh_server_public});
is($res{assoc_type}, "HMAC-SHA1");
is($res{session_type}, "DH-SHA1");
ok(good_date($res{expiry}));
ok(good_date($res{issued}));
ok($res{enc_mac_key});
ok(! $res{mac_key});
my $server_pub = _arg2bi($res{'dh_server_public'});
my $dh_sec = $dh->compute_secret($server_pub);
$ahandle = $res{'assoc_handle'};
ok($ahandle !~ /\bSTLS\./);
is(length(_d64($res{'enc_mac_key'})), 20);
is(length(sha1(_bi2bytes($dh_sec))), 20);
$secret = _d64($res{'enc_mac_key'}) ^ sha1(_bi2bytes($dh_sec));
is(length($secret), 20);
}
# try to login, with success
sub login_success {
$nos->is_identity(sub { 1; });
$nos->is_trusted(sub { 1; });
$nos->get_user(sub { "brad"; });
%post = ();
%get = (
"openid.mode" => "checkid_immediate",
"openid.identity" => "http://bradfitz.com/",
"openid.return_to" => "http://trust.root/return/",
"openid.trust_root" => "http://trust.root/",
"openid.assoc_handle" => $ahandle,
);
($ctype, $content) = $nos->handle_page;
is($ctype, "redirect");
ok($content =~ s!^http://trust.root/return/\?!!);
my %rarg = map { durl($_) } split(/[\&\=]/, $content);
my $token = "";
foreach my $p (split(/,/, $rarg{'openid.signed'})) {
$token .= "$p:" . $rarg{"openid.$p"} . "\n";
}
my $good_sig = _b64(hmac_sha1($token, $secret));
ok($rarg{'openid.sig'}, $good_sig);
# and verify that check_authentication never lets this succeed
%get = ();
%post = (
"openid.mode" => "check_authentication",
);
foreach my $p ("assoc_handle", "sig", "signed", "invalidate_handle",
split(/,/, $rarg{"openid.signed"}))
{
$post{"openid.$p"} ||= $rarg{"openid.$p"};
}
($ctype, $content) = $nos->handle_page;
is($ctype, "text/plain");
%rarg = parse_reply($content);
ok($rarg{"error"} =~ /bad_handle/);
}
# try to login, with success
sub login_bogus_handle {
$nos->is_identity(sub { 1; });
$nos->is_trusted(sub { 1; });
$nos->get_user(sub { "brad"; });
%post = ();
%get = (
"openid.mode" => "checkid_immediate",
"openid.identity" => "http://bradfitz.com/",
"openid.return_to" => "http://trust.root/return/",
"openid.trust_root" => "http://trust.root/",
"openid.assoc_handle" => "GIBBERISH",
);
($ctype, $content) = $nos->handle_page;
is($ctype, "redirect");
ok($content =~ s!^http://trust.root/return/\?!!);
my %rarg = map { durl($_) } split(/[\&\=]/, $content);
is($rarg{'openid.invalidate_handle'}, "GIBBERISH");
ok($rarg{'openid.assoc_handle'} =~ /\bSTLS\./);
# try to verify it with check_authentication
%get = ();
%post = (
"openid.mode" => "check_authentication",
);
foreach my $p ("assoc_handle", "sig", "signed", "invalidate_handle",
split(/,/, $rarg{"openid.signed"}))
{
$post{"openid.$p"} ||= $rarg{"openid.$p"};
}
($ctype, $content) = $nos->handle_page;
is($ctype, "text/plain");
%rarg = parse_reply($content);
ok($rarg{"lifetime"} > 0);
is($rarg{"invalidate_handle"}, "GIBBERISH");
}
# try to login, but fail (immediately)
sub login_im_fail {
$nos->is_identity(sub { 0; });
$nos->is_trusted(sub { 1; });
$nos->get_user(sub { "brad"; });
%post = ();
%get = (
"openid.mode" => "checkid_immediate",
"openid.identity" => "http://bradfitz.com/",
"openid.return_to" => "http://trust.root/return/",
"openid.trust_root" => "http://trust.root/",
"openid.assoc_handle" => $ahandle,
);
($ctype, $content) = $nos->handle_page;
is($ctype, "redirect");
ok($content =~ s!^http://trust.root/return/\?!!);
my %rarg = map { durl($_) } split(/[\&\=]/, $content);
is($rarg{'openid.mode'}, "id_res");
ok($rarg{'openid.user_setup_url'} =~ m!setup\.app.+bradfitz!);
}
# try to login, but fail (w/ setup)
sub login_setup_fail {
$nos->is_identity(sub { 0; });
$nos->is_trusted(sub { 1; });
$nos->get_user(sub { "brad"; });
%post = ();
%get = (
"openid.mode" => "checkid_setup",
"openid.identity" => "http://bradfitz.com/",
"openid.return_to" => "http://trust.root/return/",
"openid.trust_root" => "http://trust.root/",
"openid.assoc_handle" => $ahandle,
);
($ctype, $content) = $nos->handle_page;
is($ctype, "setup");
ok(ref $content eq "HASH");
}
# try to login, but fail (w/ setup redirect)
sub login_setup_fail2 {
$nos->is_identity(sub { 0; });
$nos->is_trusted(sub { 1; });
$nos->get_user(sub { "brad"; });
%post = ();
%get = (
"openid.mode" => "checkid_setup",
"openid.identity" => "http://bradfitz.com/",
"openid.return_to" => "http://trust.root/return/",
"openid.trust_root" => "http://trust.root/",
"openid.assoc_handle" => $ahandle,
);
($ctype, $content) = $nos->handle_page(redirect_for_setup => 1);
is($ctype, "redirect");
ok($content =~ m!^http://.+setup\.app\?!);
}
sub good_date {
return $_[0] =~ /^(\d{4,4})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)Z$/;
}
sub parse_reply {
my $reply = shift;
my %ret;
foreach (split /\n/, $reply) {
next unless /^(\S+?):(.+)/;
$ret{$1} = $2;
}
return %ret;
}
sub durl
{
my ($a) = @_;
$a =~ tr/+/ /;
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
return $a;
}
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 {
my $b64 = MIME::Base64::encode_base64(_bi2bytes($_[0]));
$b64 =~ s/\s+//g;
return $b64;
}
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]));
}
# From Digest::HMAC
sub hmac_sha1_hex {
unpack("H*", &hmac_sha1);
}
sub hmac_sha1 {
hmac($_[0], $_[1], \&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));
}