1package Net::OpenID::Yadis; 2$Net::OpenID::Yadis::VERSION = '1.20'; 3use strict; 4use warnings; 5 6use base qw(Exporter); 7use Carp (); 8use Net::OpenID::URIFetch; 9use XML::Simple; 10use Net::OpenID::Yadis::Service; 11use Net::OpenID::Common; 12use HTTP::Headers::Util qw(split_header_words); 13use Encode; 14 15our @EXPORT = qw(YR_HEAD YR_GET YR_XRDS); 16 17use constant YR_GET => 1; 18use constant YR_XRDS => 2; 19 20use fields ( 21 'last_errcode', # last error code we got 22 'last_errtext', # last error code we got 23 'debug', # debug flag or codeblock 24 'consumer', # consumer object 25 'identity_url', # URL to be identified 26 'xrd_url', # URL of XRD file 27 'xrd_objects', # Yadis XRD decoded objects 28 ); 29 30sub new { 31 my $self = shift; 32 $self = fields::new( $self ) unless ref $self; 33 my %opts = @_; 34 35 $self->consumer(delete($opts{consumer})); 36 37 $self->{debug} = delete $opts{debug}; 38 39 Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts; 40 41 return $self; 42} 43 44sub consumer { &_getset; } 45 46sub identity_url { &_getset; } 47sub xrd_url { &_getset; } 48sub xrd_objects { _pack_array(&_getset); } 49sub _getset { 50 my $self = shift; 51 my $param = (caller(1))[3]; 52 $param =~ s/.+:://; 53 54 if (@_) { 55 my $val = shift; 56 Carp::croak("Too many parameters") if @_; 57 $self->{$param} = $val; 58 } 59 return $self->{$param}; 60} 61 62sub _debug { 63 my $self = shift; 64 return unless $self->{debug}; 65 66 if (ref $self->{debug} eq "CODE") { 67 $self->{debug}->($_[0]); 68 } else { 69 print STDERR "[DEBUG Net::OpenID::Yadis] $_[0]\n"; 70 } 71} 72 73sub _fail { 74 my $self = shift; 75 my ($code, $text) = @_; 76 77 $text ||= { 78 'xrd_parse_error' => "Error occured since parsing yadis document.", 79 'xrd_format_error' => "This is not yadis document (not xrds format).", 80 'too_many_hops' => 'Too many hops by X-XRDS-Location.', 81 'empty_url' => 'Empty URL', 82 'no_yadis_document' => 'Cannot find yadis Document', 83 'url_gone' => 'URL is no longer available', 84 }->{$code}; 85 86 $self->{last_errcode} = $code; 87 $self->{last_errtext} = $text; 88 89 $self->_debug("fail($code) $text"); 90 wantarray ? () : undef; 91} 92sub err { 93 my $self = shift; 94 $self->{last_errcode} . ": " . $self->{last_errtext}; 95} 96sub errcode { 97 my $self = shift; 98 $self->{last_errcode}; 99} 100sub errtext { 101 my $self = shift; 102 $self->{last_errtext}; 103} 104sub _clear_err { 105 my $self = shift; 106 $self->{last_errtext} = ''; 107 $self->{last_errcode} = ''; 108} 109 110sub _get_contents { 111 my $self = shift; 112 my ($url, $final_url_ref, $content_ref, $headers_ref) = @_; 113 114 # we do NOT do <body> elimination here because 115 # if it's an HTML document, we are only ever looking at the headers, and 116 # if it's a YADIS document, <body> elimination is not appropriate 117 # (YADIS is not HTML; film at 11) 118 my $res = Net::OpenID::URIFetch->fetch($url, $self->consumer); 119 120 if ($res) { 121 $$final_url_ref = $res->final_uri; 122 my $headers = $res->headers; 123 foreach my $k (keys %$headers) { 124 $headers_ref->{$k} ||= $headers->{$k}; 125 } 126 $$content_ref = $res->content; 127 return 1; 128 } 129 else { 130 return undef; 131 } 132} 133 134sub parse_content_type { 135 # stolen from HTTP::Headers but returns lc charset 136 my $h = shift; 137 $h = $h->[0] if ref($h); 138 $h = "" unless defined $h; 139 my ($v) = (split_header_words($h), []); 140 my($ct, undef, %ct_param) = @$v; 141 $ct ||= ''; 142 $ct = lc($ct); 143 $ct =~ s/\s+//; 144 my $charset = lc($ct_param{charset} || ''); 145 $charset =~ s/^\s+//; 146 $charset =~ s/\s+\z//; 147 return ($ct, $charset); 148} 149 150sub discover { 151 my $self = shift; 152 my $url = shift or return $self->_fail("empty_url"); 153 my $count = shift || YR_GET; 154 Carp::croak("Too many parameters") if @_; 155 156 # trim whitespace 157 $url =~ s/^\s+//; 158 $url =~ s/\s+$//; 159 return $self->_fail("empty_url") unless $url; 160 161 my $final_url; 162 my %headers; 163 164 my $xrd; 165 $self->_get_contents($url, \$final_url, \$xrd, \%headers) or return; 166 167 $self->identity_url($final_url) if ($count < YR_XRDS); 168 169 # (1) found YADIS/XRDS-Location headers 170 if ($count < YR_XRDS and 171 my $doc_url = $headers{'x-yadis-location'} || $headers{'x-xrds-location'} 172 ) { 173 return $self->discover($doc_url, YR_XRDS); 174 } 175 176 # (2) is content type YADIS document? 177 my ($ctype, $charset) = parse_content_type($headers{'content-type'}); 178 if ($ctype eq 'application/xrds+xml') { 179 #survey says Yes! 180 $self->xrd_url($final_url); 181 182 return $self->parse_xrd($xrd); 183 } 184 185 # (3) YADIS/XRDS-location might be in a <meta> tag. 186 if ( $ctype eq 'text/html' and 187 my ($meta) = grep { 188 my $heqv = lc($_->{'http-equiv'}||''); 189 $heqv eq 'x-yadis-location' || $heqv eq 'x-xrds-location' 190 } 191 @{OpenID::util::html_extract_linkmetas($xrd)->{meta}||[]} 192 ) { 193 return $self->discover($meta->{content}, YR_XRDS); 194 } 195 return $self->_fail($count == YR_GET ? "no_yadis_document" : "too_many_hops"); 196} 197 198sub parse_xrd { 199 my $self = shift; 200 my $xrd = shift; 201 Carp::croak("Too many parameters") if @_; 202 203 my $xs_hash = XMLin($xrd) or return $self->_fail("xrd_parse_error"); 204 ($xs_hash->{'xmlns'} and $xs_hash->{'xmlns'} eq 'xri://$xrd*($v*2.0)') or $self->_fail("xrd_format_error"); 205 my %xmlns; 206 foreach (map { /^(xmlns:(.+))$/ and [$1,$2] } keys %$xs_hash) { 207 next unless ($_); 208 $xmlns{$_->[1]} = $xs_hash->{$_->[0]}; 209 } 210 my @priority; 211 my @nopriority; 212 foreach my $service (_pack_array($xs_hash->{'XRD'}{'Service'})) { 213 bless $service, "Net::OpenID::Yadis::Service"; 214 $service->{'Type'} or next; 215 $service->{'URI'} ||= $self->identity_url; 216 217 foreach my $sname (keys %$service) { 218 foreach my $ns (keys %xmlns) { 219 $service->{"{$xmlns{$ns}}$1"} = delete $service->{$sname} if ($sname =~ /^${ns}:(.+)$/); 220 } 221 } 222 defined($service->{'priority'}) ? push(@priority,$service) : push(@nopriority,$service); 223 # Services without priority fields are lowest priority 224 } 225 my @service = sort {$a->{'priority'} <=> $b->{'priority'}} @priority; 226 push (@service,@nopriority); 227 foreach (grep {/^_protocol/} keys %$self) { delete $self->{$_} } 228 229 $self->xrd_objects(\@service); 230} 231 232sub _pack_array { wantarray ? ref($_[0]) eq 'ARRAY' ? @{$_[0]} : ($_[0]) : $_[0] } 233 234sub services { 235 my $self = shift; 236 my %protocols; 237 my @protocols; 238 my $code_ref; 239 my $protocol = undef; 240 241 Carp::croak("You haven't called the discover method yet") unless $self->xrd_objects; 242 243 foreach my $option (@_) { 244 Carp::croak("No further arguments allowed after code reference argument") if $code_ref; 245 my $ref = ref($option); 246 if ($ref eq 'CODE') { 247 $code_ref = $option; 248 } else { 249 my $default = {versionarray => []}; 250 251 $protocols{$option} = $default; 252 $protocol = $option; 253 push @protocols, $option; 254 } 255 } 256 257 my @servers; 258 @servers = $self->xrd_objects if (keys %protocols == 0); 259 foreach my $key (@protocols) { 260 my $regex = $protocols{$key}->{urlregex} || $key; 261 my @ver = @{$protocols{$key}->{versionarray}}; 262 my $ver_regex = @ver ? '('.join('|',map { $_ =~ s/\./\\./g; $_ } @ver).')' : '.+' ; 263 $regex =~ s/\\ver/$ver_regex/; 264 265 push (@servers,map { $protocols{$key}->{objectclass} ? bless($_ , $protocols{$key}->{objectclass}) : $_ } grep {join(",",$_->Type) =~ /$regex/} $self->xrd_objects); 266 } 267 268 @servers = $code_ref->(@servers) if ($code_ref); 269 270 wantarray ? @servers : \@servers; 271} 272 2731; 274__END__ 275 276=head1 NAME 277 278Net::OpenID::Yadis - Perform Yadis discovery on URLs 279 280=head1 VERSION 281 282version 1.20 283 284=head1 SYNOPSIS 285 286 use Net::OpenID::Yadis; 287 288 my $disc = Net::OpenID::Yadis->new( 289 consumer => $consumer, # Net::OpenID::Consumer object 290 ); 291 292 my $xrd = $disc->discover("http://id.example.com/") or Carp::croak($disc->err); 293 294 print $disc->identity_url; # Yadis URL (Final URL if redirected) 295 print $disc->xrd_url; # Yadis Resourse Descriptor URL 296 297 foreach my $srv (@$xrd) { # Loop for Each Service in Yadis Resourse Descriptor 298 print $srv->priority; # Service priority (sorted) 299 print $srv->Type; # Identifier of some version of some service (scalar, array or array ref) 300 print $srv->URI; # URI that resolves to a resource providing the service (scalar, array or array ref) 301 print $srv->extra_field("Delegate","http://openid.net/xmlns/1.0"); 302 # Extra field of some service 303 } 304 305 # If you are interested only in OpenID. (either 1.1 or 2.0) 306 my $xrd = $self->services( 307 'http://specs.openid.net/auth/2.0/signon', 308 'http://specs.openid.net/auth/2.0/server', 309 'http://openid.net/signon/1.1', 310 ); 311 312 # If you want to choose random server by code-ref. 313 my $xrd = $self->services(sub{($_[int(rand(@_))])}); 314 315=head1 DESCRIPTION 316 317This module provides an implementation of the Yadis protocol, which does 318XRDS-based service discovery on URLs. 319 320This module was originally developed by OHTSUKA Ko-hei as L<Net::Yadis::Discovery>, 321but was forked and simplified for inclusion in the core OpenID Consumer package. 322 323This simplified version is tailored for the needs of Net::OpenID::Consumer; for other 324uses, L<Net::Yadis::Discovery> is probably a better choice. 325 326=head1 CONSTRUCTOR 327 328=over 4 329 330=item C<new> 331 332my $disc = Net::OpenID::Yadis->new([ %opts ]); 333 334You can set the C<consumer> in the constructor. See the corresponding 335method description below. 336 337=back 338 339=head1 EXPORT 340 341This module exports three constant values to use with discover method. 342 343=over 4 344 345=item C<YR_GET> 346 347If you set this, module check Yadis URL start from HTTP GET request. This is the default. 348 349=item C<YR_XRDS> 350 351If you set this, this module consider Yadis URL as Yadis Resource Descriptor URL. 352If not so, an error is returned. 353 354=back 355 356=head1 METHODS 357 358=over 4 359 360=item $disc->B<consumer>($consumer) 361 362=item $disc->B<consumer> 363 364Get or set the Net::OpenID::Consumer object that this object is associated with. 365 366=item $disc->B<discover>($url,[$request_method]) 367 368Given a user-entered $url (which could be missing http://, or have 369extra whitespace, etc), returns either array/array ref of Net::OpenID::Yadis::Service 370objects, or undef on failure. 371 372$request_method is optional, and if set this, you can change the HTTP 373request method of fetching Yadis URL. 374See EXPORT to know the value you can set, and default is YR_HEAD. 375 376If this method returns undef, you can rely on the following errors 377codes (from $csr->B<errcode>) to decide what to present to the user: 378 379=over 8 380 381=item xrd_parse_error 382 383=item xrd_format_error 384 385=item too_many_hops 386 387=item no_yadis_document 388 389=item url_fetch_err 390 391=item empty_url 392 393=item url_gone 394 395=back 396 397=item $disc->B<xrd_objects> 398 399Returns array/array ref of Net::OpenID::Yadis objects. 400It is same what could be got by discover method. 401 402=item $disc->B<identity_url> 403 404Returns Yadis URL. 405If not redirected, it is same with the argument of discover method. 406 407=item $disc->B<xrd_url> 408 409Returns Yadis Resource Descriptor URL. 410 411=item $disc->B<servers>($protocol,$protocol,...) 412 413=item $disc->B<servers>($protocol=>[$version1,$version2],...) 414 415=item $disc->B<servers>($protocol,....,$code_ref); 416 417Filter method of xrd_objects. 418 419If no option is defined, returns same result with xrd_objects method. 420 421protocol names or Type URLs are given, filter only given protocol. 422Two or more protocols are given, return and results of filtering. 423 424Sample: 425 $disc->servers("openid","http://lid.netmesh.org/sso/1.0"); 426 427If reference of version numbers array is given after protocol names, 428filter only given version of protocol. 429 430Sample: 431 $disc->servers("openid"=>['1.0','1.1'],"lid"=>['1.0']); 432 433If you want to use version numbers limitation with type URL, you can use 434\ver as place holder of version number. 435 436Sample: 437 $disc->servers("http://lid.netmesh.org/sso/\ver"=>['1.0','2.0']); 438 439If code reference is given as argument , you can make your own filter rule. 440code reference is executed at the last of filtering logic, like this: 441 442 @results = $code_ref->(@temporary_results) 443 444Sample: If you want to filter OpenID server and get only first one: 445 ($openid_server) = $disc->servers("openid",sub{$_[0]}); 446 447=item $disc->B<err> 448 449Returns the last error, in form "errcode: errtext" 450 451=item $disc->B<errcode> 452 453Returns the last error code. 454 455=item $disc->B<errtext> 456 457Returns the last error text. 458 459=back 460 461=head1 COPYRIGHT 462 463This module is Copyright (c) 2006 OHTSUKA Ko-hei. 464All rights reserved. 465 466You may distribute under the terms of either the GNU General Public 467License or the Artistic License, as specified in the Perl README file. 468 469=head1 WARRANTY 470 471This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND. 472 473=head1 SEE ALSO 474 475Yadis website: L<http://yadis.org/> 476 477L<Net::OpenID::Yadis::Service> 478 479L<Net::OpenID::Consumer> 480 481=head1 AUTHORS 482 483Based on L<Net::Yadis::Discovery> by OHTSUKA Ko-hei <nene@kokogiko.net> 484 485Martin Atkins <mart@degeneration.co.uk> 486 487=cut 488